X-Git-Url: http://dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FFilter.pm;h=10021a4eada0e886660e65b44e699451bd8fb452;hb=76027e074b381b0cdc76b3c23ac751802ee174fe;hp=f9fa611a8ef37ad4d931d4d1a4a862d8fc4fa1a7;hpb=2b58ccdf81685a1167a43c38705a0d84b9d8d661;p=spider.git diff --git a/perl/Filter.pm b/perl/Filter.pm index f9fa611a..10021a4e 100644 --- a/perl/Filter.pm +++ b/perl/Filter.pm @@ -10,7 +10,7 @@ # # Copyright (c) 1999 Dirk Koopman G1TLH # -# $Id$ +# # # The NEW INSTRUCTIONS # @@ -30,24 +30,23 @@ use DXVars; 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; -$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 @@ -91,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}; @@ -112,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; @@ -195,14 +251,14 @@ sub it my $key; my $type = 'Dunno'; my $asc = '?'; - + my $r = @keys > 0 ? 0 : 1; foreach $key (@keys) { $filter = $self->{$key}; 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 { @@ -212,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 { @@ -225,44 +281,19 @@ sub it my $hops = $self->{hops} if exists $self->{hops}; if (isdbg('filter')) { - my $args = join '\',\'', @_; + 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; @@ -297,10 +328,23 @@ sub install $in = "in" if $name =~ s/^IN_//; $name =~ s/.PL$//; - my $dxchan = DXChannel->get($name); - if ($dxchan) { + my $dxchan; + my @dxchan; + if ($name eq 'NODE_DEFAULT') { + @dxchan = DXChannel::get_all_nodes(); + } elsif ($name eq 'USER_DEFAULT') { + @dxchan = DXChannel::get_all_users(); + } else { + $dxchan = DXChannel::get($name); + push @dxchan, $dxchan if $dxchan; + } + foreach $dxchan (@dxchan) { my $n = "$in$sort" . "filter"; - $dxchan->$n($remove ? undef : $self); + my $i = $in ? 'IN_' : ''; + my $ref = $dxchan->$n(); + if (!$ref || ($ref && uc $ref->{name} eq "$i$name.PL")) { + $dxchan->$n($remove ? undef : $self); + } } } @@ -332,6 +376,8 @@ sub delete } } + + package Filter::Cmd; use strict; @@ -341,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; @@ -380,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++; @@ -390,53 +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 ' || '; - next; - } elsif ($tok eq 'and') { - $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 'not' || $tok eq '!') { - $not = '!'; + } elsif ($tok eq '') { next; } + if (@f) { my $val = shift @f; my @val = split /,/, $val; - if ($s) { - $s .= $conj ; - $s .= $not; - $user .= $conj; - $user .= $not; - $conj = ' && '; - $not = ""; - } - $user .= "$tok $val"; + dbg("filter::parse: tok '$tok' val '$val'") if isdbg('filter'); + $user .= " $tok $val"; my $fref; my $found; @@ -450,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) { @@ -471,6 +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) { @@ -478,46 +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)); + $s = $tok =~ /^{.*}$/ ? '{' . decode_regex($tok) . '}' : $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); - return (1,$filter) if $r; + 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"; @@ -526,12 +606,13 @@ sub cmd $filter->{$fn}->{$type}->{user} = $user; $filter->{$fn}->{$type}->{asc} = $s; - $r = $filter->compile($fn, $type); - return (1,$r) if $r; + $r = $filter->compile($fn, $type); # NOTE: returns an ERROR, therefore 0 = success + return (0,$r) if $r; $r = $filter->write; return (1,$r) if $r; - + + $filter->install(1); # 'delete' $filter->install; return (0, $filter, $fno); @@ -562,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. @@ -602,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) } } }