mirror of
https://codeberg.org/scip/note.git
synced 2025-12-16 20:21:04 +01:00
331 lines
6.8 KiB
Perl
331 lines
6.8 KiB
Perl
#!/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: ***
|