]> dxcluster.net Git - spider.git/blob - perl/Thingy.pm
2361561af527edc43c0f474adfc1bc29236ec1a9
[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         $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         if (@_ == 2) {
136                 $thing = shift;
137                 $thing->queue(shift);
138         }
139         while (@queue) {
140                 $thing = shift @queue;
141                 my $dxchan = DXChannel::get($thing->{dxchan});
142                 if ($dxchan) {
143                         if ($thing->can('in_filter')) {
144                                 next unless $thing->in_filter($dxchan);
145                         }
146
147                         # remember any useful routes
148                         RouteDB::update($thing->{origin}, $dxchan->{call}, $thing->{hopsaway});
149                         RouteDB::update($thing->{user}, $dxchan->{call}, $thing->{hopsaway}) if exists $thing->{user};
150                 
151                         $thing->handle($dxchan);
152                 }
153         }
154
155         # per second and per minute processing
156         if ($main::systime != $lastsec) {
157                 if ($main::systime >= $lastmin+60) {
158                         foreach my $r (@permin) {
159                                 &{$r->[0]}();
160                         }
161                         $lastmin = $main::systime;
162                 }
163                 foreach my $r (@persec) {
164                         &{$r->[0]}();
165                 }
166                 $lastsec = $main::systime;
167         }
168 }
169
170 sub add_minute_process
171 {
172         my $pkg = shift;
173         my $addr = shift;
174         my $name = shift;
175         dbg('Adding $name to Thingy per minute queue');
176         push @permin, [$addr, $name];
177 }
178
179 sub add_second_process
180 {
181         my $pkg = shift;
182         my $addr = shift;
183         my $name = shift;
184         dbg('Adding $name to Thingy per second queue');
185         push @persec, [$addr, $name];
186 }
187
188
189 sub ascii
190 {
191         my $thing = shift;
192         my $dd = new Data::Dumper([$thing]);
193         $dd->Indent(0);
194         $dd->Terse(1);
195         $dd->Sortkeys(1);
196     $dd->Quotekeys($] < 5.005 ? 1 : 0);
197         return $dd->Dumpxs;
198 }
199
200 sub add_auth
201 {
202         my $thing = shift;
203         my $s = $thing->{'s'} = sprintf "%X", int(rand() * 100000000);
204         my $auth = Verify->new("DXSp,$main::mycall,$s,$thing->{v},$thing->{b}");
205         $thing->{auth} = $auth->challenge($main::me->user->passphrase);
206 }
207
208 1;
209