X-Git-Url: http://dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FFilter.pm;h=b71ee95a5b81833acb4a1fc566592b832071529f;hb=ab811a0c902225075a9bd69749f65594079433a9;hp=8acce7f383bdca5b235433509f94e1e4e98fcc7f;hpb=b85ee0ca2b03ee2c5be20bd430cfa00757b7ebdb;p=spider.git diff --git a/perl/Filter.pm b/perl/Filter.pm index 8acce7f3..b71ee95a 100644 --- a/perl/Filter.pm +++ b/perl/Filter.pm @@ -10,7 +10,7 @@ # # Copyright (c) 1999 Dirk Koopman G1TLH # -# $Id$ +# # # The NEW INSTRUCTIONS # @@ -30,6 +30,7 @@ use DXVars; use DXUtil; use DXDebug; use Data::Dumper; +use Prefix; use strict; @@ -85,11 +86,13 @@ 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}; - dbg('err', "Error compiling $ar $sort $name: $@"); + dbg("Error compiling $ar $sort $name: $@"); Log('err', "Error compiling $ar $sort $name: $@"); } $rr = $@; @@ -107,17 +110,26 @@ sub read_in $in = undef; my $s = readfilestr($fn); my $newin = eval $s; - dbg('conn', "$@") 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; } @@ -184,15 +196,18 @@ sub it { my $self = shift; - my $hops = undef; - my $filter; my @keys = sort $self->getfilkeys; 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}}(\@_)) { $r = 0; last; @@ -201,6 +216,8 @@ sub it } } if ($filter->{accept} && exists $filter->{accept}->{code}) { + $type = 'accept'; + $asc = $filter->{accept}->{user}; if (&{$filter->{accept}->{code}}(\@_)) { $r = 1; last; @@ -210,16 +227,17 @@ sub it } } - # hops are done differently - if ($self->{hops}) { - my ($comp, $ref); - while (($comp, $ref) = each %{$self->{hops}}) { - my ($field, $h) = @$ref; - if ($_[$field] =~ m{$comp}) { - $hops = $h; - last; - } - } + # hops are done differently (simply) + my $hops = $self->{hops} if exists $self->{hops}; + + if (isdbg('filter')) { + my $args = join '\',\'', map {defined $_ ? $_ : 'undef'} @_; + my $true = $r ? "OK " : "REJ"; + my $sort = $self->{sort}; + my $dir = $self->{name} =~ /^in_/i ? "IN " : "OUT"; + + my $h = $hops || ''; + dbg("$true $dir: $type/$sort with $asc on '$args' $h") if isdbg('filter'); } return ($r, $hops); } @@ -281,14 +299,27 @@ sub install my $remove = shift; my $name = uc $self->{name}; my $sort = $self->{sort}; - my ($in) = $name =~ s/^IN_//; + my $in = ""; + $in = "in" if $name =~ s/^IN_//; $name =~ s/.PL$//; - my $dxchan = DXChannel->get($name); - if ($dxchan) { - $in = lc $in if $in; + 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); + } } } @@ -342,7 +373,7 @@ 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 $line =~ /[^\s\w,_\-\*\/\(\)!]/; # add some spaces for ease of parsing $line =~ s/([\(\)])/ $1 /g; @@ -354,7 +385,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; @@ -369,7 +400,7 @@ sub parse } $filter = Filter::read_in($sort, $call, $flag); - $filter = Filter->new($sort, $call, $flag) unless $filter; + $filter = Filter->new($sort, $call, $flag) if !$filter || $filter->isa('Filter::Old'); $ntoken++; next; @@ -418,12 +449,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; @@ -459,6 +494,16 @@ sub parse push @t, "\$r->[$fref->[2]]==$_"; } $s .= "(" . join(' || ', @t) . ")"; + } 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) . ")"; + } 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) { @@ -466,6 +511,13 @@ 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]"); } @@ -498,7 +550,9 @@ sub cmd return $dxchan->msg('filter5') unless $line; my ($r, $filter, $fno, $user, $s) = $self->parse($dxchan, $sort, $line); - return (1,$filter) if $r; + my $u = DXUser::get_current($user); + return (1, $dxchan->msg('isow', $user)) if $u && $u->isolate; + return (1, $filter) if $r; my $fn = "filter$fno";