]> dxcluster.net Git - spider.git/blob - perl/Thingy.pm
add some Hello and Bye
[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
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