perl/Filter.pm

   1 #
   2 # The User/Sysop Filter module
   3 #
   4 # The way this works is that the filter routine is actually
   5 # a predefined function that returns 0 if it is OK and 1 if it
   6 # is not when presented with a list of things.
   7 #
   8 # This set of routines provide a means of maintaining the filter
   9 # scripts which are compiled in when an entity connects.
  10 #
  11 # Copyright (c) 1999 Dirk Koopman G1TLH
  12 #
  13 # $Id$
  14 #
  15 # The NEW INSTRUCTIONS
  16 #
  17 # use the commands accept/spot|ann|wwv|wcy and reject/spot|ann|wwv|wcy
  18 # also show/filter spot|ann|wwv|wcy
  19 #
  20 # The filters live in a directory tree of their own in $main::root/filter
  21 #
  22 # Each type of filter (e.g. spot, wwv) live in a tree of their own so you
  23 # can have different filters for different things for the same callsign.
  24 #
  25
  26
  27 package Filter;
  28
  29 use DXVars;
  30 use DXUtil;
  31 use DXDebug;
  32 use Data::Dumper;
  33
  34 use strict;
  35
  36 use vars qw ($filterbasefn $in);
  37
  38 $filterbasefn = "$main::root/filter";
  39 $in = undef;
  40
  41 # initial filter system
  42 sub init
  43 {
  44
  45 }
  46
  47 sub new
  48 {
  49         my ($class, $sort, $call, $flag) = @_;
  50         $flag = ($flag) ? "in_" : "";
  51         return bless {sort => $sort, name => "$flag$call.pl" }, $class;
  52 }
  53
  54 # this reads in a filter statement and returns it as a list
  55 #
  56 # The filter is stored in straight perl so that it can be parsed and read
  57 # in with a 'do' statement. The 'do' statement reads the filter into
  58 # @in which is a list of references
  59 #
  60 sub read_in
  61 {
  62         my ($sort, $call, $flag) = @_;
  63
  64     # first uppercase
  65         $flag = ($flag) ? "in_" : "";
  66         $call = uc $call;
  67         my $fn = "$filterbasefn/$sort/$flag$call.pl";
  68
  69         # otherwise lowercase
  70         unless (-e $fn) {
  71                 $call = lc $call;
  72                 $fn = "$filterbasefn/$sort/$flag$call.pl";
  73         }
  74
  75         # load it
  76         if (-e $fn) {
  77                 $in = undef;
  78                 my $s = readfilestr($fn);
  79                 my $newin = eval $s;
  80                 dbg('conn', "$@") if $@;
  81                 if ($in) {
  82                         $newin = new('Filter::Old', $sort, $call, $flag);
  83                         $newin->{filter} = $in;
  84                 }
  85                 return $newin;
  86         }
  87         return undef;
  88 }
  89
  90 #
  91 # this routine accepts a composite filter with a reject component and then an accept
  92 # the filter returns 0 if an entry is matched by any reject rule and also if any
  93 # accept rule fails otherwise it returns 1
  94 #
  95 # the either set of rules may be missing meaning an implicit 'ok'
  96 #
  97 # reject rules are implicitly 'or' logic (any reject rules which fires kicks it out)
  98 # accept rules are implicitly 'and' logic (all accept rules must pass to indicate a match)
  99 #
 100 # unlike the old system, this is kept as a hash of hashes so that you can
 101 # easily change them by program.
 102 #
 103 # you can have a [any] number of 'filters', they are tried in random order until one matches
 104 #
 105 # an example in machine readable form:-
 106 #   bless ({
 107 #       name => 'G7BRN.pl',
 108 #       sort => 'spots',
 109 #       filter1 => {
 110 #                       user_rej => {
 111 #                               by_dxcc => 'W,VE',
 112 #                       },
 113 #               reject => {
 114 #                       by_dxcc => [6, 'n', 226,197],
 115 #               },
 116 #                       user_acc => {
 117 #                               freq => '0/30000',
 118 #                       },
 119 #               accept => {
 120 #                       freq => [0, 'r', 0, 30000],
 121 #               },
 122 #       },
 123 #       filter2 => {
 124 #                       user_acc => {
 125 #                               freq => 'vhf',
 126 #                               by_zone => '14,15,16',
 127 #                       },
 128 #               accept => {
 129 #                       freq => [0, 'r', 50000,52000,70000,70500,144000,148000],
 130 #                       by_zone => [11, 'n', 14,15,16],
 131 #               }
 132 #       },
 133 #   }, 'Filter');
 134 #
 135 # in user commands:-
 136 #
 137 #   clear/spots 1 2
 138 #   accept/spots 1 freq 0/30000
 139 #   reject/spots 1 by_dxcc W,VE
 140 #   accept/spots 2 freq vhf
 141 #   accept/spots 2 by_zone 14,15,16
 142 #
 143 # no filter no implies filter 1
 144 #
 145 # The field nos are the same as for the 'Old' filters
 146 #
 147 # The user_* fields are there so that the structure can be listed easily
 148 # in human readable form when required. They are not used in the filtering
 149 # process itself.
 150 #
 151 # This defines an HF filter and a VHF filter (as it happens)
 152 #
 153
 154 sub it
 155 {
 156         my $self = shift;
 157
 158         my $hops = undef;
 159         my $filter;
 160         my $r;
 161
 162         my ($key, $ref, $field, $fieldsort, $comp);
 163         L1: foreach $key (grep {/^filter/ } keys %$self) {
 164                         my $filter = $self->{$key};
 165                         $r = 0;
 166                         if ($filter->{reject}) {
 167                                 foreach $ref (values %{$filter->{reject}}) {
 168                                         ($field, $fieldsort) = @$ref[0,1];
 169                                         my $val = $_[$field];
 170                                         if ($fieldsort eq 'n') {
 171                                                 next L1 if grep $_ == $val, @{$ref}[2..$#$ref];
 172                                         } elsif ($fieldsort eq 'r') {
 173                                                 my $i;
 174                                                 for ($i = 2; $i < @$ref; $i += 2) {
 175                                                         next L1 if $val >= $ref->[$i] && $val <= $ref->[$i+1];
 176                                                 }
 177                                         } elsif ($fieldsort eq 'a') {
 178                                                 next L1  if grep $val =~ m{$_}, @$ref[2..$#$ref];
 179                                         }
 180                                 }
 181                         }
 182                         if ($filter->{accept}) {
 183                                 foreach $ref (values %{$filter->{accept}}) {
 184                                         ($field, $fieldsort) = @$ref[0,1];
 185                                         my $val = $_[$field];
 186                                         if ($fieldsort eq 'n') {
 187                                                 next L1 unless grep $_ == $val, @{$ref}[2..$#$ref];
 188                                         } elsif ($fieldsort eq 'r') {
 189                                                 my $i;
 190                                                 for ($i = 2; $i < @$ref; $i += 2) {
 191                                                         next L1 unless $val >= $ref->[$i] && $val <= $ref->[$i+1];
 192                                                 }
 193                                         } elsif ($fieldsort eq 'a') {
 194                                                 next L1 unless grep $val =~ m{$_}, @{$ref}[2..$#$ref];
 195                                         }
 196                                 }
 197                         }
 198                         $r = 1;
 199                         last;
 200         }
 201
 202         # hops are done differently
 203         if ($self->{hops}) {
 204                 my $h;
 205                 while (($comp, $ref) = each %{$self->{hops}}) {
 206                         ($field, $h) = @$ref;
 207                         if ($_[$field] =~ m{$comp}) {
 208                                 $hops = $h;
 209                                 last;
 210                         }
 211                 }
 212         }
 213         return ($r, $hops);
 214 }
 215
 216 # this writes out the filter in a form suitable to be read in by 'read_in'
 217 # It expects a list of references to filter lines
 218 sub write
 219 {
 220         my $self = shift;
 221         my $sort = $self->{sort};
 222         my $name = $self->{name};
 223         my $dir = "$filterbasefn/$sort";
 224         my $fn = "$dir/$name";
 225
 226         mkdir $dir, 0775 unless -e $dir;
 227     rename $fn, "$fn.o" if -e $fn;
 228         my $fh = new IO::File ">$fn";
 229         if ($fh) {
 230                 my $dd = new Data::Dumper([ $self ]);
 231                 $dd->Indent(1);
 232                 $dd->Terse(1);
 233                 $dd->Quotekeys($] < 5.005 ? 1 : 0);
 234                 $fh->print($dd->Dumpxs);
 235                 $fh->close;
 236         } else {
 237                 rename "$fn.o", $fn if -e "$fn.o";
 238                 return "$fn $!";
 239         }
 240         return undef;
 241 }
 242
 243 sub print
 244 {
 245         my $self = shift;
 246         return $self->{name};
 247 }
 248
 249 package Filter::Old;
 250
 251 use strict;
 252 use vars qw(@ISA);
 253 @ISA = qw(Filter);
 254
 255 # the OLD instructions!
 256 #
 257 # Each filter file has the same structure:-
 258 #
 259 # <some comment>
 260 # @in = (
 261 #      [ action, fieldno, fieldsort, comparison, action data ],
 262 #      ...
 263 # );
 264 #
 265 # The action is usually 1 or 0 but could be any numeric value
 266 #
 267 # The fieldno is the field no in the list of fields that is presented
 268 # to 'Filter::it'
 269 #
 270 # The fieldsort is the type of field that we are dealing with which
 271 # currently can be 'a', 'n', 'r' or 'd'. 'a' is alphanumeric, 'n' is
 272 # numeric, 'r' is ranges of pairs of numeric values and 'd' is default.
 273 #
 274 # Filter::it basically goes thru the list of comparisons from top to
 275 # bottom and when one matches it will return the action and the action data as a list.
 276 # The fields
 277 # are the element nos of the list that is presented to Filter::it. Element
 278 # 0 is the first field of the list.
 279 #
 280
 281 #
 282 # takes the reference to the filter (the first argument) and applies
 283 # it to the subsequent arguments and returns the action specified.
 284 #
 285 sub it
 286 {
 287         my $self = shift;
 288         my $filter = $self->{filter};            # this is now a bless ref of course but so what
 289
 290         my ($action, $field, $fieldsort, $comp, $actiondata);
 291         my $ref;
 292
 293         # default action is 1
 294         $action = 1;
 295         $actiondata = "";
 296         return ($action, $actiondata) if !$filter;
 297
 298         for $ref (@{$filter}) {
 299                 ($action, $field, $fieldsort, $comp, $actiondata) = @{$ref};
 300                 if ($fieldsort eq 'n') {
 301                         my $val = $_[$field];
 302                         return ($action, $actiondata)  if grep $_ == $val, @{$comp};
 303                 } elsif ($fieldsort eq 'r') {
 304                         my $val = $_[$field];
 305                         my $i;
 306                         my @range = @{$comp};
 307                         for ($i = 0; $i < @range; $i += 2) {
 308                                 return ($action, $actiondata)  if $val >= $range[$i] && $val <= $range[$i+1];
 309                         }
 310                 } elsif ($fieldsort eq 'a') {
 311                         return ($action, $actiondata)  if $_[$field] =~ m{$comp};
 312                 } else {
 313                         return ($action, $actiondata);      # the default action
 314                 }
 315         }
 316 }
 317
 318
 319 1;
 320 __END__