kill some 5.28 warnings

[spider.git] / perl / Filter.pm

diff --git a/perl/Filter.pm b/perl/Filter.pm
index fd9111826d209c25c1557b191cc1edd4f2048e08..a422b014a926d31eb2779cbd9a587a4ff695a686 100644 (file)
--- a/perl/Filter.pm
+++ b/perl/Filter.pm
@@ -231,13 +231,15 @@ sub it
        my $hops = $self->{hops} if exists $self->{hops};
 
        if (isdbg('filter')) {
+               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);
 }
@@ -370,17 +372,23 @@ sub parse
        my $filter;
        my ($flag, $call);
        my $s;
-       my $user;
+       my $user = '';
        
        # check the line for non legal characters
        dbg("Filter::parse line: '$line'") if isdbg('filter');
        return ('ill', $dxchan->msg('e19')) if $line !~ /{.*}/ && $line =~ /[^\s\w,_\-\*\/\(\)\$!]/;
+
+       $line = lc $line;
+
+       # disguise regexes
+       $line =~ s/\{(.*)\}/'{'. unpack('H*', $1) . '}'/eg;
+       dbg("Filter parse line after regex check: '$line'") if isdbg('filter');
        
        # add some spaces for ease of parsing
        $line =~ s/([\(\!\)])/ $1 /g;
-       $line = lc $line;
        
        my @f = split /\s+/, $line;
+
        my $conj = ' && ';
        my $not = "";
        my $lasttok = '';
@@ -485,14 +493,15 @@ sub parse
                                                }
                                                if ($fref->[1] eq 'a' || $fref->[1] eq 't') {
                                                        my @t;
-                                                       for (@val) {
-                                                               s/\*//g;        # remove any trailing *
-                                                               if (/^\{.*\}$/) { # we have a regex 
-                                                                       s/^\{//;
-                                                                   s/\}$//;
-                                                                       return  ('regex', $dxchan->msg('e38', $_)) unless (qr{$_})
+                                                       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 = pack('H*', $r);
+                                                                       dbg("Filter::parse regex a: '$v'") if isdbg('filter'); 
+                                                                       return  ('regex', $dxchan->msg('e38', $v)) unless (qr{$v});
                                                                }
-                                                               push @t, "\$r->[$fref->[2]]=~m{$_}i";
+                                                               push @t, "\$r->[$fref->[2]]=~m{$v}i";
                                                        }
                                                        $s .= "(" . join(' || ', @t) . ")";
                                                } elsif ($fref->[1] eq 'c') {
@@ -533,19 +542,21 @@ sub parse
                                                last;
                                        }
                                }
-                               return ('unknown', $dxchan->msg('e20', $tok)) unless $found;
+                               return (1, $dxchan->msg('e20', $tok)) unless $found;
                        } else {
-                               return ('no', $dxchan->msg('filter2', $tok));
+                               return (1, $dxchan->msg('filter2', $tok));
                        }
                        $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/\&\&/ and /g;
+               $user =~ s/\|\|/ or /g;
+               $user =~ s/\!/ not /g;
+               $user =~ s/\s+/ /g;
+       }
        
        return (0, $filter, $fno, $user, $s);
 }
@@ -554,13 +565,13 @@ sub parse
 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;
+       
        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";
 
@@ -574,7 +585,8 @@ sub cmd
        
        $r = $filter->write;
        return (1,$r) if $r;
-       
+
+       $filter->install(1);            # 'delete'
        $filter->install;
 
     return (0, $filter, $fno);