X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FFilter.pm;h=a83a5217ec86678014c42b0cffd7020305944052;hb=2c425058cd4f040ae0313063a32e6a9d9a1f60d3;hp=2c32bf025981465e9ae9b8f374fddeb2fa53527c;hpb=72568e838d146250a78fea19bd4bbafc760e6a49;p=spider.git diff --git a/perl/Filter.pm b/perl/Filter.pm index 2c32bf02..a83a5217 100644 --- a/perl/Filter.pm +++ b/perl/Filter.pm @@ -10,7 +10,7 @@ # # Copyright (c) 1999 Dirk Koopman G1TLH # -# $Id$ +# # # The NEW INSTRUCTIONS # @@ -34,12 +34,6 @@ use Prefix; 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"; @@ -92,7 +86,9 @@ 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; + $ref->{$ar}->{code} = eval "sub { $s }" ; if ($@) { my $sort = $ref->{sort}; my $name = $ref->{name}; @@ -114,17 +110,26 @@ sub read_in $in = undef; my $s = readfilestr($fn); my $newin = eval $s; - dbg($@) if $@; + 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; } @@ -305,7 +310,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) { @@ -368,7 +373,8 @@ sub parse my $user; # check the line for non legal characters - return ('ill', $dxchan->msg('e19')) if $line =~ /[^\s\w,_\-\*\/\(\)]/; + return ('ill', $dxchan->msg('e19')) if $dxchan->priv < 8 and $line =~ /{.*}/; + return ('ill', $dxchan->msg('e19')) if $line !~ /{.*}/ && $line =~ /[^\s\w,_\-\*\/\(\)!]/; # add some spaces for ease of parsing $line =~ s/([\(\)])/ $1 /g; @@ -380,7 +386,7 @@ sub parse 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 (@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; @@ -444,12 +450,16 @@ sub parse if ($s) { $s .= $conj ; - $s .= $not; $user .= $conj; - $user .= $not; $conj = ' && '; - $not = ""; } + + if ($not) { + $s .= $not; + $user .= $not; + $not = ''; + } + $user .= "$tok $val"; my $fref; @@ -464,18 +474,23 @@ 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"; + s/\*//g; # remove any trailing * + if (/^\{.*\}$/) { # we have a regex + s/^\{//; + s/\}$//; + return ('regex', $dxchan->msg('e38', $_)) unless (qr{$_}) + } + push @t, "\$r->[$fref->[2]]=~m{$_}i"; } $s .= "(" . join(' || ', @t) . ")"; } 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) . ")"; } elsif ($fref->[1] eq 'n') { @@ -486,24 +501,15 @@ sub parse } $s .= "(" . join(' || ', @t) . ")"; } elsif ($fref->[1] =~ /^n[ciz]$/ ) { # for DXCC, ITU, CQ Zone - my @n; my $cmd = $fref->[1]; - foreach my $v (@val) { - if ($v =~ /^\d+$/) { - push @n, $v unless grep $_ eq $v, @n; - } else { - my @pre = Prefix::extract($v); - return ('numpre', $dxchan->msg('e27', $_)) unless @pre; - shift @pre; - foreach my $p (@pre) { - my $n = $p->dxcc if $cmd eq 'nc' ; - $n = $p->itu if $cmd eq 'ni' ; - $n = $p->cq if $cmd eq 'nz' ; - push @n, $n unless grep $_ eq $n, @n; - } - } - } - $s .= "(" . join(' || ', map {"\$r->[$fref->[2]]==$_"} @n) . ")"; + my @pre = Prefix::to_ciz($cmd, @val); + return ('numpre', $dxchan->msg('e27', $_)) unless @pre; + $s .= "(" . join(' || ', map {"\$r->[$fref->[2]]==$_"} @pre) . ")"; + } 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) . "))"; } elsif ($fref->[1] eq 'r') { my @t; for (@val) { @@ -511,13 +517,6 @@ 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) . ")"; } else { confess("invalid letter $fref->[1]"); } @@ -550,7 +549,7 @@ sub cmd return $dxchan->msg('filter5') unless $line; my ($r, $filter, $fno, $user, $s) = $self->parse($dxchan, $sort, $line); - my $u = DXUser->get_current($user); + my $u = DXUser::get_current($user); return (1, $dxchan->msg('isow', $user)) if $u && $u->isolate; return (1, $filter) if $r; @@ -597,8 +596,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. @@ -637,9 +639,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) } } }