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 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
  20 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
  21 $main::build += $VERSION;
  22 $main::branch += $BRANCH;
  23
  24 @queue = ();                                    # the input / processing queue
  25
  26 #
  27 # these are set up using the Thingy->add_second_process($addr, $name)
  28 # and Thingy->add_minute_process($addr, $name)
  29 #
  30 # They replace the old cycle in cluster.pl
  31 #
  32
  33 @persec = ();                                   # this replaces the cycle in cluster.pl
  34 @permin = ();                                   # this is an extra per minute cycle
  35
  36 my $lastsec = time;
  37 my $lastmin = time;
  38
  39 use DXChannel;
  40 use DXDebug;
  41
  42 # we expect all thingies to be subclassed
  43 sub new
  44 {
  45         my $class = shift;
  46         my $thing = {@_};
  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         if (@_) {
  59                 $class = shift;
  60         } elsif ($dxchan->isa('DXChannel')) {
  61                 $class = ref $dxchan;
  62         }
  63
  64         # do output filtering
  65         if ($thing->can('out_filter')) {
  66                 return unless $thing->out_filter;
  67         }
  68
  69         # generate the line which may (or not) be cached
  70         my @out;
  71         if (my $ref = $thing->{class}) {
  72                 push @out, ref $ref ? @$ref : $ref;
  73         } else {
  74                 no strict 'refs';
  75                 my $sub = "gen_$class";
  76                 push @out, $thing->$sub($dxchan) if $thing->can($sub);
  77         }
  78         $dxchan->send(@out) if @out;
  79 }
  80
  81 # broadcast to all except @_
  82 sub broadcast
  83 {
  84         my $thing = shift;
  85         dbg("Thingy::broadcast: " . $thing->ascii) if isdbg('thing');
  86
  87         foreach my $dxchan (DXChannel::get_all()) {
  88                 next if $dxchan == $main::me;
  89                 next if grep $dxchan == $_, @_;
  90                 $thing->send($dxchan);
  91         }
  92 }
  93
  94 # queue this thing for processing
  95 sub queue
  96 {
  97         my $thing = shift;
  98         my $dxchan = shift;
  99         $thing->{dxchan} = $dxchan->call;
 100         push @queue, $thing;
 101 }
 102
 103 # this is the main commutator loop. In due course it will
 104 # become the *only* commutator loop
 105 sub process
 106 {
 107         my $thing;
 108         while (@queue) {
 109                 $thing = shift @queue;
 110                 my $dxchan = DXChannel->get($thing->{dxchan});
 111                 if ($dxchan) {
 112                         if ($thing->can('in_filter')) {
 113                                 next unless $thing->in_filter($dxchan);
 114                         }
 115                         $thing->handle($dxchan);
 116                 }
 117         }
 118
 119         # per second and per minute processing
 120         if ($main::systime != $lastsec) {
 121                 if ($main::systime >= $lastmin+60) {
 122                         foreach my $r (@permin) {
 123                                 &{$r->[0]}();
 124                         }
 125                         $lastmin = $main::systime;
 126                 }
 127                 foreach my $r (@persec) {
 128                         &{$r->[0]}();
 129                 }
 130                 $lastsec = $main::systime;
 131         }
 132 }
 133
 134 sub add_minute_process
 135 {
 136         my $pkg = shift;
 137         my $addr = shift;
 138         my $name = shift;
 139         dbg('Adding $name to Thingy per minute queue');
 140         push @permin, [$addr, $name];
 141 }
 142
 143 sub add_second_process
 144 {
 145         my $pkg = shift;
 146         my $addr = shift;
 147         my $name = shift;
 148         dbg('Adding $name to Thingy per second queue');
 149         push @persec, [$addr, $name];
 150 }
 151
 152
 153 sub ascii
 154 {
 155         my $thing = shift;
 156         my $dd = new Data::Dumper([$thing]);
 157         $dd->Indent(0);
 158         $dd->Terse(1);
 159         $dd->Sortkeys(1);
 160     $dd->Quotekeys($] < 5.005 ? 1 : 0);
 161         return $dd->Dumpxs;
 162 }
 163 1;
 164