X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FFilter.pm;h=5947b856f15cff628b458091ae440e81dcb99062;hb=704d88d7e4a8ff06024b35fc27eb94732b0a8d9f;hp=2b30c8cdea5c8484ca348e21442464cf50c9fe65;hpb=c20a2c1e01d707d6c3fa25067df93d491aba8fff;p=spider.git diff --git a/perl/Filter.pm b/perl/Filter.pm index 2b30c8cd..5947b856 100644 --- a/perl/Filter.pm +++ b/perl/Filter.pm @@ -44,6 +44,12 @@ sub init } +sub new +{ + my ($class, $sort, $call, $flag) = @_; + $flag = ($flag) ? "in_" : ""; + return bless {sort => $sort, name => "$flag$call.pl" }, $class; +} # this reads in a filter statement and returns it as a list # @@ -72,55 +78,166 @@ sub read_in my $s = readfilestr($fn); my $newin = eval $s; dbg('conn', "$@") if $@; - return bless [ @$in ], 'Filter::Old' if $in; + if ($in) { + $newin = new('Filter::Old', $sort, $call, $flag); + $newin->{filter} = $in; + } 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 +# +# this routine accepts a composite filter with a reject component and then an accept +# the filter returns 0 if an entry is matched by any reject rule and also if any +# accept rule fails otherwise it returns 1 +# +# the either set of rules may be missing meaning an implicit 'ok' +# +# reject rules are implicitly 'or' logic (any reject rules which fires kicks it out) +# accept rules are implicitly 'and' logic (all accept rules must pass to indicate a match) +# +# unlike the old system, this is kept as a hash of hashes so that you can +# easily change them by program. +# +# you can have a [any] number of 'filters', they are tried in random order until one matches +# +# an example in machine readable form:- +# bless ({ +# name => 'G7BRN.pl', +# sort => 'spots', +# filter1 => { +# user_rej => { +# by_dxcc => 'W,VE', +# }, +# reject => { +# by_dxcc => [6, 'n', 226,197], +# }, +# user_acc => { +# freq => '0/30000', +# }, +# accept => { +# freq => [0, 'r', 0, 30000], +# }, +# }, +# filter2 => { +# user_acc => { +# freq => 'vhf', +# by_zone => '14,15,16', +# }, +# accept => { +# freq => [0, 'r', 50000,52000,70000,70500,144000,148000], +# by_zone => [11, 'n', 14,15,16], +# } +# }, +# }, 'Filter'); +# +# in user commands:- +# +# clear/spots 1 2 +# accept/spots 1 freq 0/30000 +# reject/spots 1 by_dxcc W,VE +# accept/spots 2 freq vhf +# accept/spots 2 by_zone 14,15,16 +# +# no filter no implies filter 1 +# +# The field nos are the same as for the 'Old' filters +# +# The user_* fields are there so that the structure can be listed easily +# in human readable form when required. They are not used in the filtering +# process itself. +# +# This defines an HF filter and a VHF filter (as it happens) +# + +sub it { my $self = shift; - my $sort = shift; - my $call = shift; - my $fn = "$filterbasefn/$sort"; - - - # make the output directory - mkdir $fn, 0777 unless -e $fn; - - # write out the file - $fn = "$fn/$call.pl"; - unless (open FILTER, ">$fn") { - warn "can't open $fn $!" ; - return; + my $hops = undef; + my $filter; + my $r; + + my ($key, $ref, $field, $fieldsort, $comp); + L1: foreach $key (grep {/^filter/ } keys %$self) { + my $filter = $self->{$key}; + $r = 0; + if ($filter->{reject}) { + foreach $ref (values %{$filter->{reject}}) { + ($field, $fieldsort) = @$ref[0,1]; + my $val = $_[$field]; + if ($fieldsort eq 'n') { + next L1 if grep $_ == $val, @{$ref}[2..$#$ref]; + } elsif ($fieldsort eq 'r') { + my $i; + for ($i = 2; $i < @$ref; $i += 2) { + next L1 if $val >= $ref->[$i] && $val <= $ref->[$i+1]; + } + } elsif ($fieldsort eq 'a') { + next L1 if grep $val =~ m{$_}, @$ref[2..$#$ref]; + } + } + } + if ($filter->{accept}) { + foreach $ref (values %{$filter->{accept}}) { + ($field, $fieldsort) = @$ref[0,1]; + my $val = $_[$field]; + if ($fieldsort eq 'n') { + next L1 unless grep $_ == $val, @{$ref}[2..$#$ref]; + } elsif ($fieldsort eq 'r') { + my $i; + for ($i = 2; $i < @$ref; $i += 2) { + next L1 unless $val >= $ref->[$i] && $val <= $ref->[$i+1]; + } + } elsif ($fieldsort eq 'a') { + next L1 unless grep $val =~ m{$_}, @{$ref}[2..$#$ref]; + } + } + } + $r = 1; + last; } - my $today = localtime; - print FILTER "#!/usr/bin/perl -# -# Filter for $call stored $today -# -\$in = [ -"; + # hops are done differently + if ($self->{hops}) { + my $h; + while (($comp, $ref) = each %{$self->{hops}}) { + ($field, $h) = @$ref; + if ($_[$field] =~ m{$comp}) { + $hops = $h; + last; + } + } + } + return ($r, $hops); +} - my $ref; - for $ref (@_) { - my ($action, $field, $fieldsort, $comp, $actiondata) = @{$ref}; - print FILTER "\t[ $action, $field, $fieldsort,"; - if ($fieldsort eq 'n' || $fieldsort eq 'r') { - print FILTER "[ ", join (',', $comp), " ],"; - } elsif ($fieldsort eq 'a') { - my $f = $comp; - print FILTER "'$f'"; - } - print FILTER " ],\n"; +# 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 $fn = $self->{name}; + my $dir = "$filterbasefn/$sort"; + mkdir $dir, 0775 unless -e $dir; + my $fh = new IO::File ">$dir/$fn" or return "$dir/$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; } - print FILTER "];\n"; - close FILTER; + return undef; +} + +sub print +{ + my $self = shift; + return $self->{name}; } package Filter::Old; @@ -161,7 +278,8 @@ use vars qw(@ISA); # sub it { - my $filter = shift; # this is now a bless ref of course but so what + my $self = shift; + my $filter = $self->{filter}; # this is now a bless ref of course but so what my ($action, $field, $fieldsort, $comp, $actiondata); my $ref;