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         bless $thing, $class;
  47         return $thing;
  48 }
  49
  50 # send it out in the format asked for, if available
  51 sub send
  52 {
  53         my $thing = shift;
  54         my $dxchan = shift;
  55         my $class;
  56         if (@_) {
  57                 $class = shift;
  58         } elsif ($dxchan->isa('DXChannel')) {
  59                 $class = ref $dxchan;
  60         }
  61
  62         # do output filtering
  63         if ($thing->can('out_filter')) {
  64                 return unless $thing->out_filter($dxchan);
  65         }
  66
  67         # generate the line which may (or not) be cached
  68         my $ref;
  69         unless ($ref = $thing->{class}) {
  70                 no strict 'refs';
  71                 my $sub = "gen_$class";
  72                 $ref = $thing->$sub($dxchan) if $thing->can($sub);
  73         }
  74         $dxchan->send(ref $ref ? @$ref : $ref) if $ref;
  75 }
  76
  77 # broadcast to all except @_
  78 sub broadcast
  79 {
  80         my $thing = shift;
  81         dbg("Thingy::broadcast: " . $thing->ascii) if isdbg('thing');
  82
  83         foreach my $dxchan (DXChannel::get_all()) {
  84                 next if $dxchan == $main::me;
  85                 next if grep $dxchan == $_, @_;
  86                 $thing->send($dxchan);
  87         }
  88 }
  89
  90 # queue this thing for processing
  91 sub queue
  92 {
  93         my $thing = shift;
  94         my $dxchan = shift;
  95         $thing->{dxchan} = $dxchan->call;
  96         push @queue, $thing;
  97 }
  98
  99 #
 100 # this is the main commutator loop. In due course it will
 101 # become the *only* commutator loop, This can be called in one
 102 # of two ways: either with 2 args or with none.
 103 #
 104 # The two arg form is an immediate "queue and handle" and does
 105 # a full cycle, immediately
 106 #
 107 sub process
 108 {
 109         my $thing;
 110         if (@_ == 2) {
 111                 $thing = shift;
 112                 $thing->queue(shift);
 113         }
 114         while (@queue) {
 115                 $thing = shift @queue;
 116                 my $dxchan = DXChannel->get($thing->{dxchan});
 117                 if ($dxchan) {
 118                         if ($thing->can('in_filter')) {
 119                                 next unless $thing->in_filter($dxchan);
 120                         }
 121
 122                         # remember any useful routes
 123                         RouteDB::update($thing->{origin}, $dxchan->{call}, $thing->{hopsaway});
 124                         RouteDB::update($thing->{user}, $dxchan->{call}, $thing->{hopsaway}) if exists $thing->{user};
 125
 126                         $thing->handle($dxchan);
 127                 }
 128         }
 129
 130         # per second and per minute processing
 131         if ($main::systime != $lastsec) {
 132                 if ($main::systime >= $lastmin+60) {
 133                         foreach my $r (@permin) {
 134                                 &{$r->[0]}();
 135                         }
 136                         $lastmin = $main::systime;
 137                 }
 138                 foreach my $r (@persec) {
 139                         &{$r->[0]}();
 140                 }
 141                 $lastsec = $main::systime;
 142         }
 143 }
 144
 145 sub add_minute_process
 146 {
 147         my $pkg = shift;
 148         my $addr = shift;
 149         my $name = shift;
 150         dbg('Adding $name to Thingy per minute queue');
 151         push @permin, [$addr, $name];
 152 }
 153
 154 sub add_second_process
 155 {
 156         my $pkg = shift;
 157         my $addr = shift;
 158         my $name = shift;
 159         dbg('Adding $name to Thingy per second queue');
 160         push @persec, [$addr, $name];
 161 }
 162
 163
 164 sub ascii
 165 {
 166         my $thing = shift;
 167         my $dd = new Data::Dumper([$thing]);
 168         $dd->Indent(0);
 169         $dd->Terse(1);
 170         $dd->Sortkeys(1);
 171     $dd->Quotekeys($] < 5.005 ? 1 : 0);
 172         return $dd->Dumpxs;
 173 }
 174 1;
 175