]> gb7djk.dxcluster.net Git - spider.git/blob - perl/Thingy.pm
0921abd818414d2c2dac083fd5aab6033224cedc
[spider.git] / 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