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::Cmd;
 250
 251 use strict;
 252 use vars qw(@ISA);
 253 @ISA = qw(Filter);
 254
 255 # the general purpose command processor
 256 # this is called as a subroutine not as a method
 257 sub process_cmd
 258 {
 259         my ($self, $dxchan, $line) = @_;
 260         my $ntoken = 0;
 261         my $fno = 1;
 262         my $filter;
 263         my ($flag, $call);
 264
 265         # check the line for non legal characters
 266         return ('ill', $dxchan->msg('e19')) if $line =~ /[^\s\w,_\/]/;
 267
 268         while (my @f = split /\s+/, $line) {
 269                 if ($ntoken == 0) {
 270
 271                         if (@f && $dxchan->priv >= 9 && DXUser->get($f[0])) {
 272                                 $call = shift @f;
 273                                 if ($f[0] eq 'input') {
 274                                         shift @f;
 275                                         $flag++;
 276                                 }
 277                         } else {
 278                                 $call = $dxchan->call;
 279                         }
 280
 281                         if (@f && $f[0] =~ /^\d+$/) {
 282                                 $fno = shift @f;
 283                         }
 284
 285                         $filter = Filter::read_in('spots', $call, $flag) or new Filter ('spots', $call, $flag);
 286
 287                         $ntoken++;
 288                         next;
 289                 }
 290
 291                 # do the rest of the filter tokens
 292                 if (@f) {
 293                         my $tok = shift @f;
 294                         if (@f) {
 295                                 my $val = shift @f;
 296
 297                                 my $fref;
 298                                 foreach $fref (@$self) {
 299                                         if ($fref->[0] eq $tok) {
 300
 301                                         }
 302                                 }
 303                         } else {
 304                                 return ('no', $dxchan->msg('filter2', $tok));
 305                         }
 306                 }
 307
 308         }
 309         $flag = $flag ? "in_" : "";
 310         return (0, $dxchan->msg('filter1', $fno, "$flag$call"));
 311 }
 312
 313 package Filter::Old;
 314
 315 use strict;
 316 use vars qw(@ISA);
 317 @ISA = qw(Filter);
 318
 319 # the OLD instructions!
 320 #
 321 # Each filter file has the same structure:-
 322 #
 323 # <some comment>
 324 # @in = (
 325 #      [ action, fieldno, fieldsort, comparison, action data ],
 326 #      ...
 327 # );
 328 #
 329 # The action is usually 1 or 0 but could be any numeric value
 330 #
 331 # The fieldno is the field no in the list of fields that is presented
 332 # to 'Filter::it'
 333 #
 334 # The fieldsort is the type of field that we are dealing with which
 335 # currently can be 'a', 'n', 'r' or 'd'. 'a' is alphanumeric, 'n' is
 336 # numeric, 'r' is ranges of pairs of numeric values and 'd' is default.
 337 #
 338 # Filter::it basically goes thru the list of comparisons from top to
 339 # bottom and when one matches it will return the action and the action data as a list.
 340 # The fields
 341 # are the element nos of the list that is presented to Filter::it. Element
 342 # 0 is the first field of the list.
 343 #
 344
 345 #
 346 # takes the reference to the filter (the first argument) and applies
 347 # it to the subsequent arguments and returns the action specified.
 348 #
 349 sub it
 350 {
 351         my $self = shift;
 352         my $filter = $self->{filter};            # this is now a bless ref of course but so what
 353
 354         my ($action, $field, $fieldsort, $comp, $actiondata);
 355         my $ref;
 356
 357         # default action is 1
 358         $action = 1;
 359         $actiondata = "";
 360         return ($action, $actiondata) if !$filter;
 361
 362         for $ref (@{$filter}) {
 363                 ($action, $field, $fieldsort, $comp, $actiondata) = @{$ref};
 364                 if ($fieldsort eq 'n') {
 365                         my $val = $_[$field];
 366                         return ($action, $actiondata)  if grep $_ == $val, @{$comp};
 367                 } elsif ($fieldsort eq 'r') {
 368                         my $val = $_[$field];
 369                         my $i;
 370                         my @range = @{$comp};
 371                         for ($i = 0; $i < @range; $i += 2) {
 372                                 return ($action, $actiondata)  if $val >= $range[$i] && $val <= $range[$i+1];
 373                         }
 374                 } elsif ($fieldsort eq 'a') {
 375                         return ($action, $actiondata)  if $_[$field] =~ m{$comp};
 376                 } else {
 377                         return ($action, $actiondata);      # the default action
 378                 }
 379         }
 380 }
 381
 382
 383 1;
 384 __END__