perl/Thingy.pm

   1 #
   2 # Thingy handling
   3 #
   4 # This is the new fundamental protocol engine handler
   5 #
   6 # This is where all the new things (and eventually all the old things
   7 # as well) happen.
   8 #
   9 # $Id$
  10 #
  11 # Copyright (c) 2004 Dirk Koopman G1TLH
  12 #
  13
  14 use strict;
  15
  16 package Thingy;
  17
  18 use vars qw($VERSION $BRANCH @queue @permin @persec);
  19
  20 main::mkver($VERSION = q$Revision$);
  21
  22 @queue = ();                                    # the input / processing queue
  23
  24 #
  25 # these are set up using the Thingy->add_second_process($addr, $name)
  26 # and Thingy->add_minute_process($addr, $name)
  27 #
  28 # They replace the old cycle in cluster.pl
  29 #
  30
  31 @persec = ();                                   # this replaces the cycle in cluster.pl
  32 @permin = ();                                   # this is an extra per minute cycle
  33
  34 my $lastsec = time;
  35 my $lastmin = time;
  36
  37 use DXChannel;
  38 use DXDebug;
  39
  40 # we expect all thingies to be subclassed
  41 sub new
  42 {
  43         my $class = shift;
  44         my $thing = {@_};
  45
  46         $thing->{origin} ||= $main::mycall;
  47
  48         bless $thing, $class;
  49         return $thing;
  50 }
  51
  52 # send it out in the format asked for, if available
  53 sub send
  54 {
  55         my $thing = shift;
  56         my $dxchan = shift;
  57         my $class;
  58         my $sub;
  59
  60         if (@_) {
  61                 $class = shift;
  62         } elsif ($dxchan->isa('DXChannel')) {
  63                 $class = ref $dxchan;
  64         }
  65
  66         # BEWARE!!!!!
  67         no strict 'refs';
  68
  69         # do output filtering
  70         if ($thing->can('out_filter')) {
  71                 return unless $thing->out_filter($dxchan);
  72         }
  73
  74         # before send (and line generation) things
  75         # function must return true to make the send happen
  76         $sub = "before_send_$class";
  77         if ($thing->can($sub)) {
  78                 return $thing->$sub($dxchan);
  79         }
  80
  81         # generate the protocol line which may (or not) be cached
  82         my $ref;
  83         unless ($ref = $thing->{class}) {
  84                 $sub = "gen_$class";
  85                 $ref = $thing->$sub($dxchan) if $thing->can($sub);
  86         }
  87         $dxchan->send(ref $ref ? @$ref : $ref) if $ref;
  88
  89         # after send
  90         if ($thing->can('after_send_all')) {
  91                 $thing->after_send_all($dxchan);
  92         } else {
  93                 $sub = "after_send_$class";
  94                 $thing->$sub($dxchan) if $thing->can($sub);
  95         }
  96 }
  97
  98 # broadcast to all except @_
  99 sub broadcast
 100 {
 101         my $thing = shift;
 102         dbg("Thingy::broadcast: " . $thing->ascii) if isdbg('thing');
 103
 104         foreach my $dxchan (DXChannel::get_all()) {
 105                 next if $dxchan == $main::me;
 106                 next if grep $dxchan == $_, @_;
 107                 next if $dxchan->{call} eq $thing->{origin};
 108                 next if $thing->{user} && !$dxchan->is_user && $dxchan->{call} eq $thing->{user};
 109
 110                 dbg("Thingy::broadcast: sending to $dxchan->{call}") if isdbg('thing');
 111                 $thing->send($dxchan);
 112         }
 113 }
 114
 115 # queue this thing for processing
 116 sub queue
 117 {
 118         my $thing = shift;
 119         my $dxchan = shift;
 120         $thing->{dxchan} = $dxchan->call;
 121         push @queue, $thing;
 122 }
 123
 124 #
 125 # this is the main commutator loop. In due course it will
 126 # become the *only* commutator loop, This can be called in one
 127 # of two ways: either with 2 args or with none.
 128 #
 129 # The two arg form is an immediate "queue and handle" and does
 130 # a full cycle, immediately
 131 #
 132 sub process
 133 {
 134         my $thing;
 135
 136         if (@_ == 2) {
 137                 $thing = shift;
 138                 $thing->queue(shift);
 139         }
 140
 141         while (@queue) {
 142                 $thing = shift @queue;
 143                 my $dxchan = DXChannel::get($thing->{dxchan});
 144                 if ($dxchan) {
 145                         if ($thing->can('in_filter')) {
 146                                 next unless $thing->in_filter($dxchan);
 147                         }
 148
 149                         # remember any useful routes
 150                         RouteDB::update($thing->{origin}, $dxchan->{call}, $thing->{hopsaway});
 151                         RouteDB::update($thing->{user}, $dxchan->{call}, $thing->{hopsaway}) if exists $thing->{user};
 152
 153                         $thing->handle($dxchan);
 154                 }
 155         }
 156
 157         # per second and per minute processing
 158         if ($main::systime != $lastsec) {
 159                 if ($main::systime >= $lastmin+60) {
 160                         foreach my $r (@permin) {
 161                                 &{$r->[0]}();
 162                         }
 163                         $lastmin = $main::systime;
 164                 }
 165                 foreach my $r (@persec) {
 166                         &{$r->[0]}();
 167                 }
 168                 $lastsec = $main::systime;
 169         }
 170 }
 171
 172 sub add_minute_process
 173 {
 174         my $pkg = shift;
 175         my $addr = shift;
 176         my $name = shift;
 177         dbg('Adding $name to Thingy per minute queue');
 178         push @permin, [$addr, $name];
 179 }
 180
 181 sub add_second_process
 182 {
 183         my $pkg = shift;
 184         my $addr = shift;
 185         my $name = shift;
 186         dbg('Adding $name to Thingy per second queue');
 187         push @persec, [$addr, $name];
 188 }
 189
 190
 191 sub ascii
 192 {
 193         my $thing = shift;
 194         my $dd = new Data::Dumper([$thing]);
 195         $dd->Indent(0);
 196         $dd->Terse(1);
 197         $dd->Sortkeys(1);
 198     $dd->Quotekeys($] < 5.005 ? 1 : 0);
 199         return $dd->Dumpxs;
 200 }
 201
 202 sub add_auth
 203 {
 204         my $thing = shift;
 205         my $s = $thing->{'s'} = sprintf "%X", int(rand() * 100000000);
 206         my $auth = Verify->new("DXSp,$main::mycall,$s,$thing->{v},$thing->{b}");
 207         $thing->{auth} = $auth->challenge($main::me->user->passphrase);
 208 }
 209
 210 #
 211 # create a generalised reply to a passed thing, if it isn't replyable
 212 # to then undef is returned
 213 #
 214 sub new_reply
 215 {
 216         my $thing = shift;
 217         my $out;
 218
 219         if ($thing->{group} eq $main::mycall) {
 220                 $out = $thing->new;
 221                 $out->{touser} = $thing->{user} if $thing->{user};
 222         } elsif (DXChannel::get($thing->{group})) {
 223                 $out = $thing->new(user => $thing->{group});
 224                 $out->{touser} = $thing->{user} if $thing->{user};
 225         } elsif ($thing->{touser} && DXChannel->{$thing->{touser}}) {
 226                 $out = $thing->new(user => $thing->{touser});
 227                 $out->{group} = $thing->{group};
 228         }
 229         return $out;
 230 }
 231 1;
 232