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_zone => '4,5',
 112 #                       },
 113 #               reject => {
 114 #                       by_zone => [11, 'n', 4, 5],
 115 #               },
 116 #                       user_acc => {
 117 #                               freq => 'hf',
 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_zone 4,5
 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 user_* fields are there so that the structure can be listed easily
 146 # in human readable form when required. They are not used in the filtering
 147 # process itself.
 148 #
 149 # This defines an HF filter and a VHF filter (as it happens)
 150 #
 151
 152 sub it
 153 {
 154         my $self = shift;
 155
 156         my $hops = undef;
 157         my $filter;
 158         my $r;
 159
 160         my ($key, $ref, $field, $fieldsort, $comp);
 161         L1: foreach $key (grep {/^filter/ } keys %$self) {
 162                         my $filter = $self->{$key};
 163                         $r = 0;
 164                         if ($filter->{reject}) {
 165                                 foreach $ref (values %{$filter->{reject}}) {
 166                                         ($field, $fieldsort) = @$ref[0,1];
 167                                         my $val = $_[$field];
 168                                         if ($fieldsort eq 'n') {
 169                                                 next L1 if grep {$_ == $val} @{$ref}[2..$#$ref];
 170                                         } elsif ($fieldsort eq 'r') {
 171                                                 my $i;
 172                                                 for ($i = 2; $i < @$ref; $i += 2) {
 173                                                         next L1 if $val >= $ref->[$i] && $val <= $ref->[$i+1];
 174                                                 }
 175                                         } elsif ($fieldsort eq 'a') {
 176                                                 next L1  if grep { $val =~ m{$_}} @$ref[2..$#$ref];
 177                                         }
 178                                 }
 179                         }
 180                         if ($filter->{accept}) {
 181                                 foreach $ref (values %{$filter->{accept}}) {
 182                                         ($field, $fieldsort) = @$ref[0,1];
 183                                         my $val = $_[$field];
 184                                         if ($fieldsort eq 'n') {
 185                                                 next L1 unless grep {$_ == $val} @{$ref}[2..$#$ref];
 186                                         } elsif ($fieldsort eq 'r') {
 187                                                 my $i;
 188                                                 for ($i = 2; $i < @$ref; $i += 2) {
 189                                                         next L1 unless $val >= $ref->[$i] && $val <= $ref->[$i+1];
 190                                                 }
 191                                         } elsif ($fieldsort eq 'a') {
 192                                                 next L1 unless grep { $val =~ m{$_}} @{$ref}[2..$#$ref];
 193                                         }
 194                                 }
 195                         }
 196                         $r = 1;
 197                         last;
 198         }
 199
 200         # hops are done differently
 201         if ($self->{hops}) {
 202                 my $h;
 203                 while (($comp, $ref) = each %{$self->{hops}}) {
 204                         ($field, $h) = @$ref;
 205                         if ($_[$field] =~ m{$comp}) {
 206                                 $hops = $h;
 207                                 last;
 208                         }
 209                 }
 210         }
 211         return ($r, $hops);
 212 }
 213
 214 # this writes out the filter in a form suitable to be read in by 'read_in'
 215 # It expects a list of references to filter lines
 216 sub write
 217 {
 218         my $self = shift;
 219         my $sort = $self->{sort};
 220         my $fn = $self->{name};
 221         my $dir = "$filterbasefn/$sort";
 222         mkdir $dir, 0775 unless -e $dir;
 223         my $fh = new IO::File ">$dir/$fn" or return "$dir/$fn $!";
 224         if ($fh) {
 225                 my $dd = new Data::Dumper([ $self ]);
 226                 $dd->Indent(1);
 227                 $dd->Terse(1);
 228                 $dd->Quotekeys($] < 5.005 ? 1 : 0);
 229                 $fh->print($dd->Dumpxs);
 230                 $fh->close;
 231         }
 232         return undef;
 233 }
 234
 235 sub print
 236 {
 237         my $self = shift;
 238         return $self->{name};
 239 }
 240
 241 package Filter::Old;
 242
 243 use strict;
 244 use vars qw(@ISA);
 245 @ISA = qw(Filter);
 246
 247 # the OLD instructions!
 248 #
 249 # Each filter file has the same structure:-
 250 #
 251 # <some comment>
 252 # @in = (
 253 #      [ action, fieldno, fieldsort, comparison, action data ],
 254 #      ...
 255 # );
 256 #
 257 # The action is usually 1 or 0 but could be any numeric value
 258 #
 259 # The fieldno is the field no in the list of fields that is presented
 260 # to 'Filter::it'
 261 #
 262 # The fieldsort is the type of field that we are dealing with which
 263 # currently can be 'a', 'n', 'r' or 'd'. 'a' is alphanumeric, 'n' is
 264 # numeric, 'r' is ranges of pairs of numeric values and 'd' is default.
 265 #
 266 # Filter::it basically goes thru the list of comparisons from top to
 267 # bottom and when one matches it will return the action and the action data as a list.
 268 # The fields
 269 # are the element nos of the list that is presented to Filter::it. Element
 270 # 0 is the first field of the list.
 271 #
 272
 273 #
 274 # takes the reference to the filter (the first argument) and applies
 275 # it to the subsequent arguments and returns the action specified.
 276 #
 277 sub it
 278 {
 279         my $self = shift;
 280         my $filter = $self->{filter};            # this is now a bless ref of course but so what
 281
 282         my ($action, $field, $fieldsort, $comp, $actiondata);
 283         my $ref;
 284
 285         # default action is 1
 286         $action = 1;
 287         $actiondata = "";
 288         return ($action, $actiondata) if !$filter;
 289
 290         for $ref (@{$filter}) {
 291                 ($action, $field, $fieldsort, $comp, $actiondata) = @{$ref};
 292                 if ($fieldsort eq 'n') {
 293                         my $val = $_[$field];
 294                         return ($action, $actiondata)  if grep $_ == $val, @{$comp};
 295                 } elsif ($fieldsort eq 'r') {
 296                         my $val = $_[$field];
 297                         my $i;
 298                         my @range = @{$comp};
 299                         for ($i = 0; $i < @range; $i += 2) {
 300                                 return ($action, $actiondata)  if $val >= $range[$i] && $val <= $range[$i+1];
 301                         }
 302                 } elsif ($fieldsort eq 'a') {
 303                         return ($action, $actiondata)  if $_[$field] =~ m{$comp};
 304                 } else {
 305                         return ($action, $actiondata);      # the default action
 306                 }
 307         }
 308 }
 309
 310
 311 1;
 312 __END__