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
  48 # this reads in a filter statement and returns it as a list
  49 #
  50 # The filter is stored in straight perl so that it can be parsed and read
  51 # in with a 'do' statement. The 'do' statement reads the filter into
  52 # @in which is a list of references
  53 #
  54 sub read_in
  55 {
  56         my ($sort, $call, $flag) = @_;
  57
  58     # first uppercase
  59         $flag = ($flag) ? "in_" : "";
  60         $call = uc $call;
  61         my $fn = "$filterbasefn/$sort/$flag$call.pl";
  62
  63         # otherwise lowercase
  64         unless (-e $fn) {
  65                 $call = lc $call;
  66                 $fn = "$filterbasefn/$sort/$flag$call.pl";
  67         }
  68
  69         # load it
  70         if (-e $fn) {
  71                 $in = undef;
  72                 my $s = readfilestr($fn);
  73                 my $newin = eval $s;
  74                 dbg('conn', "$@") if $@;
  75                 return bless [ @$in ], 'Filter::Old' if $in;
  76                 return $newin;
  77         }
  78         return undef;
  79 }
  80
  81 # this writes out the filter in a form suitable to be read in by 'read_in'
  82 # It expects a list of references to filter lines
  83 sub write
  84 {
  85         my $self = shift;
  86
  87         my $sort = shift;
  88         my $call = shift;
  89         my $fn = "$filterbasefn/$sort";
  90
  91
  92         # make the output directory
  93         mkdir $fn, 0777 unless -e $fn;
  94
  95         # write out the file
  96         $fn = "$fn/$call.pl";
  97         unless (open FILTER, ">$fn") {
  98                 warn "can't open $fn $!" ;
  99                 return;
 100         }
 101
 102         my $today = localtime;
 103         print FILTER "#!/usr/bin/perl
 104 #
 105 # Filter for $call stored $today
 106 #
 107 \$in = [
 108 ";
 109
 110         my $ref;
 111         for $ref (@_) {
 112                 my ($action, $field, $fieldsort, $comp, $actiondata) = @{$ref};
 113                 print FILTER "\t[ $action, $field, $fieldsort,";
 114                 if ($fieldsort eq 'n' || $fieldsort eq 'r') {
 115                         print FILTER "[ ", join (',', $comp), " ],";
 116                 } elsif ($fieldsort eq 'a') {
 117                         my $f = $comp;
 118                 print FILTER "'$f'";
 119                 }
 120                 print FILTER " ],\n";
 121         }
 122         print FILTER "];\n";
 123         close FILTER;
 124 }
 125
 126 package Filter::Old;
 127
 128 use strict;
 129 use vars qw(@ISA);
 130 @ISA = qw(Filter);
 131
 132 # the OLD instructions!
 133 #
 134 # Each filter file has the same structure:-
 135 #
 136 # <some comment>
 137 # @in = (
 138 #      [ action, fieldno, fieldsort, comparison, action data ],
 139 #      ...
 140 # );
 141 #
 142 # The action is usually 1 or 0 but could be any numeric value
 143 #
 144 # The fieldno is the field no in the list of fields that is presented
 145 # to 'Filter::it'
 146 #
 147 # The fieldsort is the type of field that we are dealing with which
 148 # currently can be 'a', 'n', 'r' or 'd'. 'a' is alphanumeric, 'n' is
 149 # numeric, 'r' is ranges of pairs of numeric values and 'd' is default.
 150 #
 151 # Filter::it basically goes thru the list of comparisons from top to
 152 # bottom and when one matches it will return the action and the action data as a list.
 153 # The fields
 154 # are the element nos of the list that is presented to Filter::it. Element
 155 # 0 is the first field of the list.
 156 #
 157
 158 #
 159 # takes the reference to the filter (the first argument) and applies
 160 # it to the subsequent arguments and returns the action specified.
 161 #
 162 sub it
 163 {
 164         my $filter = shift;            # this is now a bless ref of course but so what
 165
 166         my ($action, $field, $fieldsort, $comp, $actiondata);
 167         my $ref;
 168
 169         # default action is 1
 170         $action = 1;
 171         $actiondata = "";
 172         return ($action, $actiondata) if !$filter;
 173
 174         for $ref (@{$filter}) {
 175                 ($action, $field, $fieldsort, $comp, $actiondata) = @{$ref};
 176                 if ($fieldsort eq 'n') {
 177                         my $val = $_[$field];
 178                         return ($action, $actiondata)  if grep $_ == $val, @{$comp};
 179                 } elsif ($fieldsort eq 'r') {
 180                         my $val = $_[$field];
 181                         my $i;
 182                         my @range = @{$comp};
 183                         for ($i = 0; $i < @range; $i += 2) {
 184                                 return ($action, $actiondata)  if $val >= $range[$i] && $val <= $range[$i+1];
 185                         }
 186                 } elsif ($fieldsort eq 'a') {
 187                         return ($action, $actiondata)  if $_[$field] =~ m{$comp};
 188                 } else {
 189                         return ($action, $actiondata);      # the default action
 190                 }
 191         }
 192 }
 193
 194
 195 1;
 196 __END__