X-Git-Url: http://gb7djk.dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FFilter.pm;h=2c32bf025981465e9ae9b8f374fddeb2fa53527c;hb=72568e838d146250a78fea19bd4bbafc760e6a49;hp=b927dc1f0700c0917e9bccbc61f0f345123c2c54;hpb=20a1e972197e2d479bd35da2deb2bce22209a10e;p=spider.git diff --git a/perl/Filter.pm b/perl/Filter.pm index b927dc1f..2c32bf02 100644 --- a/perl/Filter.pm +++ b/perl/Filter.pm @@ -30,9 +30,16 @@ use DXVars; use DXUtil; use DXDebug; use Data::Dumper; +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"; @@ -89,7 +96,7 @@ sub compile 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,7 +114,7 @@ sub read_in $in = undef; my $s = readfilestr($fn); my $newin = eval $s; - dbg('conn', "$@") if $@; + dbg($@) if $@; if ($in) { $newin = new('Filter::Old', $sort, $call, $flag); $newin->{filter} = $in; @@ -187,10 +194,15 @@ sub it 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; @@ -199,6 +211,8 @@ sub it } } if ($filter->{accept} && exists $filter->{accept}->{code}) { + $type = 'accept'; + $asc = $filter->{accept}->{user}; if (&{$filter->{accept}->{code}}(\@_)) { $r = 1; last; @@ -211,6 +225,15 @@ sub it # 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); } @@ -271,14 +294,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); + } } } @@ -449,6 +485,25 @@ sub parse push @t, "\$r->[$fref->[2]]==$_"; } $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) . ")"; } elsif ($fref->[1] eq 'r') { my @t; for (@val) { @@ -495,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";