note/Tools.pm

#!/usr/bin/perl -w
#
# generic tool functions
#
# Copyright (c) 2000 ConSol* GmbH, Munich.
# All Rights Reserved. Unauthorized use forbidden.
#
# $Id: Tools.pm,v 1.11 2000/08/04 17:41:40 tom Exp $
package Consol::Util::Tools;

use Exporter ();
use strict;
use Carp qw(cluck);
use FileHandle ();
use Date::Manip;
use Data::Dumper;
use vars qw(@ISA @EXPORT @EXPORT_OK @EXPORT_TAGS $DEBUG);

@ISA=qw(Exporter);
# auto export subs
@EXPORT=qw(getyesterdate debug generate_regex crypt_data);
@EXPORT_OK=qw();
@EXPORT_TAGS=();


=head1 NAME

Tools - general utilitiy package, no OOP.

=head1 SYNOPSIS

use Tools qw (getyesterdate debug);


=head1 SUB getyesterdate

 my $onedayago = getyesterdate();

returns the date one day ago in the following format: YYYYMMDD

=cut

sub getyesterdate
{
    my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
    my($lastmonth, $lastyear);
    $year += 1900;
    $mon += 1;

    if ($mon == 1) {
      $lastmonth = 12;
      $lastyear  = $year - 1;
    }
    else {
      $lastmonth = $mon - 1;
      $lastyear = $year;
    }
    my @DAYS_IN_MONTH = qw(0 31 28 31 30 31 30 31 31 30 31 30 31);
    my ($day,@days);
    if ((($year % 4) == 0) && ((($year % 100) != 0) || (($year % 400) == 0))) {
      $DAYS_IN_MONTH[2]++;
    }

    if ($mday == 1) {
      $mday = $DAYS_IN_MONTH[$lastmonth];
      $year = $lastyear;
      $mon  = $lastmonth;
    }
    else {
      $mday--;
    }
    $mon =~ s/^(\d)$/0$1/;
    $hour =~ s/^(\d)$/0$1/;
    $min =~ s/^(\d)$/0$1/;
    $sec =~ s/^(\d)$/0$1/;
    $mday =~ s/^(\d)$/0$1/;
    return "$year$mon$mday";
}


=head1 SUB debug

 BEGIN { $DEBUG = 1; }
 debug("some odd errors occured");

prints the given message to STDERR if $DEBUG is true (1).
It adds the packagename and the linenumber of the caller to the output.

=cut

sub debug {
  my(@msg) = @_;
  return if(!$DEBUG);
  my($package, $filename, $line) = caller;
  print "$package $line: @msg\n";
}





=head1 SUB generate_regex

This subroutine generates valid perlcode based on userinput
for further validation using B<eval>. You can catch exceptions
using the B<$@> variable. A user supplied expression an contain
AND, OR, brackets (), wildcards (* for any characters, ? for one character),
or even valid perl regex(in this special case, it will not transformed
in any way). See below for example usage!

 $code = generate_regex(
			-string => "(max AND moritz) OR (tina AND ute)",
                        -case   => 1,
			-if     => 1,
			);

If you set B<-if> to B<1> the following output will be created:

 $match = 1 if(  (/max/i   and /moritz/i  )  or  (/tina/i   and /ute/i  ) );

otherwise you will only get a code fragment:

 (/max/i   and /moritz/i  )  or  (/tina/i   and /ute/i  )

If you set B<-case> to B<1>, the code will search case sensitive.

If B<-string> is empty, "/^/" will be returned.

Sample usage:

 #!/usr/bin/perl
 use Tools qw(generate_regex);
 my $match = undef;
 my $input = <>;
 chomp $input;
 my $regex = generate_regex(-string => $input, -if => 1);
 eval $regex;
 if ($@) {
   die "invalid expression: $@\n";
 }
 open FILE, "<textfile" or die $!;
 while (<FILE>) {
   eval $regex;
   if ($match) {
     print "$. matched the expression \"$input\"\n";
   }
 }
 close FILE;

Allowed expressions:

 "Hans Wurst"                                   # exact match
 max AND moritz                                 # AND
 max OR moritz                                  # OR
 (max AND moritz) OR tina                       # combined with ()
 ((max AND moritz) AND tina) OR (hans AND mike) # more complicated with ()
 (*aol.com OR *gmx.de) AND (*free* OR *money*)  # slightly more complicated with wildcards
 /^[a-zA-Z]+?.*\d{4}$/                          # yes, a user can also supply a regex!

=cut


sub generate_regex {
  #
  # interface sub for generate_search()
  #
  my %params = @_;
  my($result);
  $result = &generate_search($params{-string}, $params{-case});
  if ($params{-if}) {
    $result = qq(\$match = 1 if($result););
  }
  return $result;
}



sub generate_search {
    #
    # get user input and create perlcode ready for eval
    #  sample input:
    # "ann.a OR eg???on AND u*do$"
    #  resulting output:
    # "$match = $_ if(/ann\.a/i or /eg...on/i and /u.*do\$/i );
    #
    my($string,$case) = @_;

    if ($string =~ /^\/.+?\/$/) {
      return $string;
    }
    elsif (!$string) {
      return "/^/";
    }

    # per default case sensitive
    $case = ($case ? "" : "i");

    # we will get a / in front of the first word too!
    $string = " " . $string . " ";

    # check for apostrophs
    $string =~ s/(?<=\s)(\(??)("[^"]+"|\S+)(\)??)(?=\s)/$1 . &check_exact($2) . $3/ge;

    # remove odd spaces infront of and after <20>and<6E> and <20>or<6F>
    $string =~ s/\s\s*(AND|OR)\s\s*/ $1 /g;

    # remove odd spaces infront of <20>(<28> and after <20>)<29>
    $string =~ s/(\s*\()/\(/g;
    $string =~ s/(\)\s*)/\)/g;

    # remove first and last space so it will not masked!
    $string =~ s/^\s//;
    $string =~ s/\s$//;

    # mask spaces if not infront of or after <20>and<6E> and <20>or<6F>
    $string =~ s/(?<!AND)(?<!OR)(\s+?)(?!AND|OR)/'\s' x length($1)/ge;

    # add first space again
    $string = " " . $string;

    # lowercase AND and OR
    $string =~ s/(\s??OR\s??|\s??AND\s??)/\L$1\E/g;

    # surround brackets with at least one space
    $string =~ s/(?<!\\)(\)|\()/ $1 /g;

    # surround strings with slashes
    $string =~ s/(?<=\s)(\S+)/ &check_or($1, $case) /ge;

    # remove slashes on <20>and<6E> and <20>or<6F>
    $string =~ s/\/(and|or)\/$case/$1/g;

    # remove spaces inside /string/ constructs
    $string =~ s/(?<!and)(?<!or)\s*\//\//g;

    $string =~ s/\/\s*(?!and|or)/\//g;

    return $string;
}

sub check_or {
  #
  # surrounds string with slashes if it is not
  # <20>and<6E> or <20>or<6F>
  #
  my($str, $case) = @_;
  if ($str =~ /^\s*(or|and)\s*$/) {
    return " $str ";
  }
  elsif ($str =~ /(?<!\\)[)(]/) {
    return $str;
  }
  else {
    return " \/$str\/$case ";
  }
}


sub check_exact {
  #
  # helper for generate_search()
  # masks special chars if string
  # not inside ""
  #
  my($str) = @_;

  my %globs = (
	       '*' => '.*',
	       '?' => '.',
	       '[' => '[',
	       ']' => ']',
	       '+' => '\+',
	       '.' => '\.',
	       '$' => '\$',
	       '@' => '\@',
	      );

  # mask backslash
  $str =~ s/\\/\\\\/g;

  if ($str =~ /^"/ && $str =~ /"$/) {
    # mask bracket-constructs
    $str =~ s/(\(|\))/\\$1/g;
  }
  $str =~ s/(.)/$globs{$1} || "$1"/ge;

  $str =~ s/^"//;
  $str =~ s/"$//;

  # mask spaces
  $str =~ s/\s/\\s/g;
  return $str;
}








sub crypt_data {
  #
  # enrypt a passwd
  #
  my($cleartext) = @_;
  debug("\"$cleartext\"");
  return if(!$cleartext);

  # create a random salt
  my @range=('0'..'9','a'..'z','A'..'Z');

  my $salt=$range[rand(int($#range)+1)] . $range[rand(int($#range)+1)];

  return crypt($cleartext, "$salt");
}



=head1 AUTHOR

Thomas Linden

=cut

1;

# Local Variables: ***
# perl-master-file: ../../webmin/index.pl ***
# End: ***