X-Git-Url: http://www.dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FFilter.pm;h=7119ed13e113a5ca84b05d0c6831a8e1e4b83a61;hb=refs%2Fheads%2Fstaging;hp=0ca71917db987cb5637ebe5bec404b1ddb611e64;hpb=8178d787d7cc8040fa8958197582bba5c80e6f59;p=spider.git diff --git a/perl/Filter.pm b/perl/Filter.pm index 0ca71917..7119ed13 100644 --- a/perl/Filter.pm +++ b/perl/Filter.pm @@ -10,7 +10,7 @@ # # Copyright (c) 1999 Dirk Koopman G1TLH # -# $Id$ +# # # The NEW INSTRUCTIONS # @@ -31,24 +31,22 @@ use DXUtil; use DXDebug; use Data::Dumper; use Prefix; +use DXLog; +use DXJSON; use strict; -use vars qw($VERSION $BRANCH); -$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); -$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0)); -$main::build += $VERSION; -$main::branch += $BRANCH; - use vars qw ($filterbasefn $in); $filterbasefn = "$main::root/filter"; $in = undef; +my $json; + # initial filter system sub init { - + $json = DXJSON->new->indent(1); } sub new @@ -92,7 +90,10 @@ sub compile my $rr; if ($ref->{$ar} && exists $ref->{$ar}->{asc}) { - $ref->{$ar}->{code} = eval "sub { my \$r=shift; return $ref->{$ar}->{asc}; }" ; + my $s = $ref->{$ar}->{asc}; # an optimisation? + $s =~ s/\$r/\$_[0]/g; +# $s =~ s/\\\\/\\/g; + $ref->{$ar}->{code} = eval "sub { $s }" ; if ($@) { my $sort = $ref->{sort}; my $name = $ref->{name}; @@ -113,24 +114,78 @@ sub read_in if ($fn = getfn($sort, $call, $flag)) { $in = undef; my $s = readfilestr($fn); - my $newin = eval $s; - dbg($@) if $@; + my $newin; + if ($s =~ /^\s*{/) { + eval {$newin = $json->decode($s, __PACKAGE__)}; + } else { + $newin = eval $s; + } + if ($@) { + dbg($@); + unlink($fn); + return undef; + } if ($in) { $newin = new('Filter::Old', $sort, $call, $flag); $newin->{filter} = $in; - } else { + } elsif (ref $newin && $newin->can('getfilkeys')) { my $filter; my $key; foreach $key ($newin->getfilkeys) { $newin->compile($key, 'reject'); $newin->compile($key, 'accept'); } + } else { + # error on reading file, delete and exit + dbg("empty or unreadable filter: $fn, deleted"); + unlink($fn); + return undef; } return $newin; } return undef; } + +# this writes out the filter in a form suitable to be read in by 'read_in' +# It expects a list of references to filter lines +sub write +{ + my $self = shift; + my $sort = $self->{sort}; + my $name = $self->{name}; + my $dir = "$filterbasefn/$sort"; + my $fn = "$dir/$name"; + + mkdir $dir, 0775 unless -e $dir; + rename $fn, "$fn.o" if -e $fn; + my $fh = new IO::File ">$fn"; + if ($fh) { +# my $dd = new Data::Dumper([ $self ]); +# $dd->Indent(1); +# $dd->Terse(1); +# $dd->Quotekeys($] < 5.005 ? 1 : 0); + # $fh->print($dd->Dumpxs); + + # remove code references, do the encode, then put them back again (they can't be represented anyway) + my $key; + foreach $key ($self->getfilkeys) { + $self->{$key}->{reject}->{code} = undef if exists $self->{$key}->{reject}; + $self->{$key}->{accept}->{code} = undef if exists $self->{$key}->{accept}; + } + $fh->print($json->encode($self)); + foreach $key ($self->getfilkeys) { + $self->compile($key, 'reject'); + $self->compile($key, 'accept'); + } + $fh->close; + } else { + rename "$fn.o", $fn if -e "$fn.o"; + return "$fn $!"; + } + return undef; +} + sub getfilters { my $self = shift; @@ -203,7 +258,7 @@ sub it if ($filter->{reject} && exists $filter->{reject}->{code}) { $type = 'reject'; $asc = $filter->{reject}->{user}; - if (&{$filter->{reject}->{code}}(\@_)) { + if (&{$filter->{reject}->{code}}(ref $_[0] ? $_[0] : \@_)) { $r = 0; last; } else { @@ -213,7 +268,7 @@ sub it if ($filter->{accept} && exists $filter->{accept}->{code}) { $type = 'accept'; $asc = $filter->{accept}->{user}; - if (&{$filter->{accept}->{code}}(\@_)) { + if (&{$filter->{accept}->{code}}(ref $_[0] ? $_[0] : \@_)) { $r = 1; last; } else { @@ -226,44 +281,19 @@ sub it my $hops = $self->{hops} if exists $self->{hops}; if (isdbg('filter')) { - my $args = join '\',\'', map {defined $_ ? $_ : 'undef'} @_; + my $call = $self->{name}; + my $args = join '\',\'', map {defined $_ ? $_ : 'undef'} (ref $_[0] ? @{$_[0]} : @_); my $true = $r ? "OK " : "REJ"; my $sort = $self->{sort}; my $dir = $self->{name} =~ /^in_/i ? "IN " : "OUT"; - + + $call =~ s/\.PL$//i; my $h = $hops || ''; - dbg("$true $dir: $type/$sort with $asc on '$args' $h") if isdbg('filter'); + dbg("Filter: $call $true $dir: $type/$sort with '$asc' on '$args' $h") if isdbg('filter'); } return ($r, $hops); } -# this writes out the filter in a form suitable to be read in by 'read_in' -# It expects a list of references to filter lines -sub write -{ - my $self = shift; - my $sort = $self->{sort}; - my $name = $self->{name}; - my $dir = "$filterbasefn/$sort"; - my $fn = "$dir/$name"; - - mkdir $dir, 0775 unless -e $dir; - rename $fn, "$fn.o" if -e $fn; - my $fh = new IO::File ">$fn"; - if ($fh) { - my $dd = new Data::Dumper([ $self ]); - $dd->Indent(1); - $dd->Terse(1); - $dd->Quotekeys($] < 5.005 ? 1 : 0); - $fh->print($dd->Dumpxs); - $fh->close; - } else { - rename "$fn.o", $fn if -e "$fn.o"; - return "$fn $!"; - } - return undef; -} - sub print { my $self = shift; @@ -305,7 +335,7 @@ sub install } elsif ($name eq 'USER_DEFAULT') { @dxchan = DXChannel::get_all_users(); } else { - $dxchan = DXChannel->get($name); + $dxchan = DXChannel::get($name); push @dxchan, $dxchan if $dxchan; } foreach $dxchan (@dxchan) { @@ -346,6 +376,8 @@ sub delete } } + + package Filter::Cmd; use strict; @@ -355,32 +387,56 @@ use DXDebug; use vars qw(@ISA); @ISA = qw(Filter); +sub encode_regex +{ + my $s = shift; + $s =~ s/\{(.*?)\}/'{'. unpack('H*', $1) . '}'/eg if $s; + return $s; +} + +sub decode_regex +{ + my $r = shift; + my ($v) = $r =~ /^\{(.*?)}$/; + return pack('H*', $v); +} + + # the general purpose command processor # this is called as a subroutine not as a method sub parse { - my ($self, $dxchan, $sort, $line) = @_; + my ($self, $dxchan, $sort, $line, $forcenew) = @_; my $ntoken = 0; my $fno = 1; my $filter; my ($flag, $call); my $s; - my $user; + my $user = ''; # check the line for non legal characters - return ('ill', $dxchan->msg('e19')) if $line =~ /[^\s\w,_\-\*\/\(\)!]/; + dbg("Filter::parse line: '$line'") if isdbg('filter'); + my @ch = $line =~ m|([^\s\w,_\.:\/\-\*\(\)\$!])|g; + return ('ill', $dxchan->msg('e19', join(' ', @ch))) if $line !~ /{.*}/ && @ch; + + $line = lc $line; + + # disguise regexes + + dbg("Filter parse line after regex check: '$line'") if isdbg('filter'); + $line = encode_regex($line); # add some spaces for ease of parsing - $line =~ s/([\(\)])/ $1 /g; - $line = lc $line; + $line =~ s/([\(\!\)])/ $1 /g; my @f = split /\s+/, $line; - my $conj = ' && '; - my $not = ""; + dbg("filter parse: tokens '" . join("' '", @f) . "'") if isdbg('filter'); + + my $lasttok = ''; while (@f) { if ($ntoken == 0) { - if (@f && $dxchan->priv >= 8 && ((is_callsign(uc $f[0]) && DXUser->get(uc $f[0])) || $f[0] =~ /(?:node|user)_default/)) { + if (!$forcenew && @f && $dxchan->priv >= 8 && ((is_callsign(uc $f[0]) && DXUser::get(uc $f[0])) || $f[0] =~ /(?:node|user)_default/)) { $call = shift @f; if ($f[0] eq 'input') { shift @f; @@ -394,7 +450,7 @@ sub parse $fno = shift @f; } - $filter = Filter::read_in($sort, $call, $flag); + $filter = Filter::read_in($sort, $call, $flag) unless $forcenew; $filter = Filter->new($sort, $call, $flag) if !$filter || $filter->isa('Filter::Old'); $ntoken++; @@ -404,57 +460,30 @@ sub parse # do the rest of the filter tokens if (@f) { my $tok = shift @f; - if ($tok eq '(') { - if ($s) { - $s .= $conj; - $user .= $conj; - $conj = ""; - } - if ($not) { - $s .= $not; - $user .= $not; - $not = ""; - } - $s .= $tok; - $user .= $tok; - next; - } elsif ($tok eq ')') { - $conj = ' && '; - $not =""; - $s .= $tok; - $user .= $tok; - next; - } elsif ($tok eq 'all') { + + dbg("filter::parse: tok '$tok'") if isdbg('filter'); + + if ($tok eq 'all') { $s .= '1'; $user .= $tok; last; - } elsif ($tok eq 'or') { - $conj = ' || ' if $conj ne ' || '; + } elsif (grep $tok eq $_, qw{and or not ( )}) { + $s .= ' && ' if $tok eq 'and'; + $s .= ' || ' if $tok eq 'or'; + $s .= ' !' if $tok eq 'not'; + $s .= $tok if $tok eq '(' or $tok eq ')'; + $user .= " $tok "; next; - } elsif ($tok eq 'and') { - $conj = ' && ' if $conj ne ' && '; - next; - } elsif ($tok eq 'not' || $tok eq '!') { - $not = '!'; + } elsif ($tok eq '') { next; } + if (@f) { my $val = shift @f; my @val = split /,/, $val; - if ($s) { - $s .= $conj ; - $user .= $conj; - $conj = ' && '; - } - - if ($not) { - $s .= $not; - $user .= $not; - $not = ''; - } - - $user .= "$tok $val"; + dbg("filter::parse: tok '$tok' val '$val'") if isdbg('filter'); + $user .= " $tok $val"; my $fref; my $found; @@ -468,20 +497,31 @@ sub parse } @val = @nval; } - if ($fref->[1] eq 'a') { + if ($fref->[1] eq 'a' || $fref->[1] eq 't') { my @t; - for (@val) { - s/\*//g; - push @t, "\$r->[$fref->[2]]=~/$_/i"; + foreach my $v (@val) { + $v =~ s/\*//g; # remove any trailing * + if (my ($r) = $v =~ /^\{(.*)\}$/) { # we have a regex + dbg("Filter::parse regex b: '\{$r\}'") if isdbg('filter'); + $v = decode_regex($v); + dbg("Filter::parse regex a: '$v'") if isdbg('filter'); + return ('regex', $dxchan->msg('e38', $v)) unless (qr{$v}); + push @t, "\$r->[$fref->[2]]=~m{$v}i"; + $v = "{$r}"; # put it back together again for humans + } else { + push @t, "\$r->[$fref->[2]]=~m{$v}i"; + } } $s .= "(" . join(' || ', @t) . ")"; + dbg("filter parse: s '$s'") if isdbg('filter'); } elsif ($fref->[1] eq 'c') { my @t; for (@val) { s/\*//g; - push @t, "\$r->[$fref->[2]]=~/^\U$_/"; + push @t, "\$r->[$fref->[2]]=~m{^\U$_}"; } $s .= "(" . join(' || ', @t) . ")"; + dbg("filter parse: s '$s'") if isdbg('filter'); } elsif ($fref->[1] eq 'n') { my @t; for (@val) { @@ -489,16 +529,19 @@ sub parse push @t, "\$r->[$fref->[2]]==$_"; } $s .= "(" . join(' || ', @t) . ")"; + dbg("filter parse: s '$s'") if isdbg('filter'); } elsif ($fref->[1] =~ /^n[ciz]$/ ) { # for DXCC, ITU, CQ Zone my $cmd = $fref->[1]; my @pre = Prefix::to_ciz($cmd, @val); return ('numpre', $dxchan->msg('e27', $_)) unless @pre; $s .= "(" . join(' || ', map {"\$r->[$fref->[2]]==$_"} @pre) . ")"; + dbg("filter parse: s '$s'") if isdbg('filter'); } elsif ($fref->[1] =~ /^ns$/ ) { # for DXCC, ITU, CQ Zone my $cmd = $fref->[1]; my @pre = Prefix::to_ciz($cmd, @val); return ('numpre', $dxchan->msg('e27', $_)) unless @pre; $s .= "(" . "!\$USDB::present || grep \$r->[$fref->[2]] eq \$_, qw(" . join(' ' ,map {uc} @pre) . "))"; + dbg("filter parse: s '$s'") if isdbg('filter'); } elsif ($fref->[1] eq 'r') { my @t; for (@val) { @@ -506,48 +549,55 @@ sub parse push @t, "(\$r->[$fref->[2]]>=$1 && \$r->[$fref->[2]]<=$2)"; } $s .= "(" . join(' || ', @t) . ")"; - } elsif ($fref->[1] eq 't') { - my @t; - for (@val) { - s/\*//g; - push @t, "\$r->[$fref->[2]]=~/$_/i"; - } - $s .= "(" . join(' || ', @t) . ")"; + dbg("filter parse: s '$s'") if isdbg('filter'); } else { - confess("invalid letter $fref->[1]"); + confess("invalid filter function $fref->[1]"); } ++$found; last; } } - return ('unknown', $dxchan->msg('e20', $tok)) unless $found; + return (1, $dxchan->msg('e20', $lasttok)) unless $found; } else { - return ('no', $dxchan->msg('filter2', $tok)); + my $s = '{' . decode_regex($tok) . '}' if $tok =~ /^{.*}$/; + return (1, $dxchan->msg('filter2', $s)); } + $lasttok = $tok; } - } - # tidy up the user string - $user =~ s/\&\&/ and /g; - $user =~ s/\|\|/ or /g; - $user =~ s/\!/ not /g; - $user =~ s/\s+/ /g; + # tidy up the user string (why I have to stick in an if statement when I have initialised it I have no idea! 5.28 bug? + if ($user) { + $user =~ s/\)\s*\(/ and /g; + $user =~ s/\&\&/ and /g; + $user =~ s/\|\|/ or /g; + $user =~ s/\!/ not /g; + $user =~ s/\s+/ /g; + $user =~ s/\{(.*?)\}/'{'. pack('H*', $1) . '}'/eg; + $user =~ s/^\s+//; + dbg("filter parse: user '$user'") if isdbg('filter'); + } + + if ($s) { + $s =~ s/\)\s*\(/ && /g; + dbg("filter parse: s '$s'") if isdbg('filter'); + } + - return (0, $filter, $fno, $user, "$s"); + return (0, $filter, $fno, $user, $s); } # a filter accept/reject command sub cmd { my ($self, $dxchan, $sort, $type, $line) = @_; - return $dxchan->msg('filter5') unless $line; my ($r, $filter, $fno, $user, $s) = $self->parse($dxchan, $sort, $line); - my $u = DXUser->get_current($user); - return (1, $dxchan->msg('isow', $user)) if $u && $u->isolate; return (1, $filter) if $r; + + my $u = DXUser::get_current($user); + return (1, $dxchan->msg('isow', $user)) if $u && $u->isolate; my $fn = "filter$fno"; @@ -561,7 +611,8 @@ sub cmd $r = $filter->write; return (1,$r) if $r; - + + $filter->install(1); # 'delete' $filter->install; return (0, $filter, $fno); @@ -592,8 +643,11 @@ use vars qw(@ISA); # to 'Filter::it' # # The fieldsort is the type of field that we are dealing with which -# currently can be 'a', 'n', 'r' or 'd'. 'a' is alphanumeric, 'n' is -# numeric, 'r' is ranges of pairs of numeric values and 'd' is default. +# currently can be 'a', 'n', 'r' or 'd'. +# 'a' is alphanumeric +# 'n' is# numeric +# 'r' is ranges of pairs of numeric values +# 'd' is default (effectively, don't filter) # # Filter::it basically goes thru the list of comparisons from top to # bottom and when one matches it will return the action and the action data as a list. @@ -632,9 +686,9 @@ sub it return ($action, $actiondata) if $val >= $range[$i] && $val <= $range[$i+1]; } } elsif ($fieldsort eq 'a') { - return ($action, $actiondata) if $_[$field] =~ m{$comp}; + return ($action, $actiondata) if $_[$field] =~ m{$comp}i; } else { - return ($action, $actiondata); # the default action + return ($action, $actiondata); # the default action (just pass through) } } }