]> scm.dxcluster.org Git - spider.git/blob - perl/DXChannel.pm
changed help for filters freq->on
[spider.git] / perl / DXChannel.pm
1 #
2 # module to manage channel lists & data
3 #
4 # This is the base class for all channel operations, which is everything to do 
5 # with input and output really.
6 #
7 # The instance variable in the outside world will be generally be called $dxchann
8 #
9 # This class is 'inherited' (if that is the goobledegook for what I am doing)
10 # by various other modules. The point to understand is that the 'instance variable'
11 # is in fact what normal people would call the state vector and all useful info
12 # about a connection goes in there.
13 #
14 # Another point to note is that a vector may contain a list of other vectors. 
15 # I have simply added another variable to the vector for 'simplicity' (or laziness
16 # as it is more commonly called)
17 #
18 # PLEASE NOTE - I am a C programmer using this as a method of learning perl
19 # firstly and OO about ninthly (if you don't like the design and you can't 
20 # improve it with better OO and thus make it smaller and more efficient, then tough). 
21 #
22 # Copyright (c) 1998-2000 - Dirk Koopman G1TLH
23 #
24 # $Id$
25 #
26 package DXChannel;
27
28 use Msg;
29 use DXM;
30 use DXUtil;
31 use DXVars;
32 use DXDebug;
33 use Filter;
34
35 use strict;
36 use vars qw(%channels %valid);
37
38 %channels = ();
39
40 %valid = (
41                   call => '0,Callsign',
42                   conn => '9,Msg Conn ref',
43                   user => '9,DXUser ref',
44                   startt => '0,Start Time,atime',
45                   t => '9,Time,atime',
46                   pc50_t => '5,Last PC50 Time,atime',
47                   priv => '9,Privilege',
48                   state => '0,Current State',
49                   oldstate => '5,Last State',
50                   list => '9,Dep Chan List',
51                   name => '0,User Name',
52                   consort => '5,Connection Type',
53                   'sort' => '5,Type of Channel',
54                   wwv => '0,Want WWV,yesno',
55                   wcy => '0,Want WCY,yesno',
56                   wx => '0,Want WX,yesno',
57                   talk => '0,Want Talk,yesno',
58                   ann => '0,Want Announce,yesno',
59                   here => '0,Here?,yesno',
60                   confmode => '0,In Conference?,yesno',
61                   dx => '0,DX Spots,yesno',
62                   redirect => '0,Redirect messages to',
63                   lang => '0,Language',
64                   func => '5,Function',
65                   loc => '9,Local Vars', # used by func to store local variables in
66                   beep => '0,Want Beeps,yesno',
67                   lastread => '5,Last Msg Read',
68                   outbound => '5,outbound?,yesno',
69                   remotecmd => '9,doing rcmd,yesno',
70                   pagelth => '0,Page Length',
71                   pagedata => '9,Page Data Store',
72                   group => '0,Access Group,parray',     # used to create a group of users/nodes for some purpose or other
73                   isolate => '5,Isolate network,yesno',
74                   delayed => '5,Delayed messages,parray',
75                   annfilter => '5,Announce Filter',
76                   wwvfilter => '5,WWV Filter',
77                   wcyfilter => '5,WCY Filter',
78                   spotsfilter => '5,Spot Filter',
79                   inannfilter => '5,Input Ann Filter',
80                   inwwvfilter => '5,Input WWV Filter',
81                   inwcyfilter => '5,Input WCY Filter',
82                   inspotsfilter => '5,Input Spot Filter',
83                   passwd => '9,Passwd List,parray',
84                   pingint => '5,Ping Interval ',
85                   nopings => '5,Ping Obs Count',
86                   lastping => '5,Ping last sent,atime',
87                   pingtime => '5,Ping totaltime,parray',
88                   pingave => '0,Ping ave time',
89                   logininfo => '9,Login info req,yesno',
90                   talklist => '0,Talk List,parray',
91                   cluster => '5,Cluster data',
92                  );
93
94 # object destruction
95 sub DESTROY
96 {
97         my $self = shift;
98         undef $self->{user};
99         undef $self->{conn};
100         undef $self->{loc};
101         undef $self->{pagedata};
102         undef $self->{group};
103         undef $self->{delayed};
104         undef $self->{annfilter};
105         undef $self->{wwvfilter};
106         undef $self->{spotsfilter};
107         undef $self->{inannfilter};
108         undef $self->{inwwvfilter};
109         undef $self->{inspotsfilter};
110         undef $self->{passwd};
111         undef $self->{node};
112 }
113
114 # create a new channel object [$obj = DXChannel->new($call, $msg_conn_obj, $user_obj)]
115 sub alloc
116 {
117         my ($pkg, $call, $conn, $user) = @_;
118         my $self = {};
119   
120         die "trying to create a duplicate channel for $call" if $channels{$call};
121         $self->{call} = $call;
122         $self->{priv} = 0;
123         $self->{conn} = $conn if defined $conn; # if this isn't defined then it must be a list
124         if (defined $user) {
125                 $self->{user} = $user;
126                 $self->{lang} = $user->lang;
127                 $user->new_group() if !$user->group;
128                 $self->{group} = $user->group;
129                 $self->{sort} = $user->sort;
130         }
131         $self->{startt} = $self->{t} = time;
132         $self->{state} = 0;
133         $self->{oldstate} = 0;
134         $self->{lang} = $main::lang if !$self->{lang};
135         $self->{func} = "";
136
137         bless $self, $pkg; 
138         return $channels{$call} = $self;
139 }
140
141 # obtain a channel object by callsign [$obj = DXChannel->get($call)]
142 sub get
143 {
144         my ($pkg, $call) = @_;
145         return $channels{$call};
146 }
147
148 # obtain all the channel objects
149 sub get_all
150 {
151         my ($pkg) = @_;
152         return values(%channels);
153 }
154
155 #
156 # gimme all the ak1a nodes
157 #
158 sub get_all_nodes
159 {
160         my $ref;
161         my @out;
162         foreach $ref (values %channels) {
163                 push @out, $ref if $ref->is_node;
164         }
165         return @out;
166 }
167
168 # return a list of all users
169 sub get_all_users
170 {
171         my $ref;
172         my @out;
173         foreach $ref (values %channels) {
174                 push @out, $ref if $ref->is_user;
175         }
176         return @out;
177 }
178
179 # return a list of all user callsigns
180 sub get_all_user_calls
181 {
182         my $ref;
183         my @out;
184         foreach $ref (values %channels) {
185                 push @out, $ref->{call} if $ref->is_user;
186         }
187         return @out;
188 }
189
190 # obtain a channel object by searching for its connection reference
191 sub get_by_cnum
192 {
193         my ($pkg, $conn) = @_;
194         my $self;
195   
196         foreach $self (values(%channels)) {
197                 return $self if ($self->{conn} == $conn);
198         }
199         return undef;
200 }
201
202 # get rid of a channel object [$obj->del()]
203 sub del
204 {
205         my $self = shift;
206
207         $self->{group} = undef;         # belt and braces
208         delete $channels{$self->{call}};
209 }
210
211 # is it a bbs
212 sub is_bbs
213 {
214         my $self = shift;
215         return $self->{'sort'} eq 'B';
216 }
217
218 sub is_node
219 {
220         my $self = shift;
221         return $self->{'sort'} =~ /[ACRSX]/;
222 }
223 # is it an ak1a node ?
224 sub is_ak1a
225 {
226         my $self = shift;
227         return $self->{'sort'} eq 'A';
228 }
229
230 # is it a user?
231 sub is_user
232 {
233         my $self = shift;
234         return $self->{'sort'} eq 'U';
235 }
236
237 # is it a clx node
238 sub is_clx
239 {
240         my $self = shift;
241         return $self->{'sort'} eq 'C';
242 }
243
244 # is it a spider node
245 sub is_spider
246 {
247         my $self = shift;
248         return $self->{'sort'} eq 'S';
249 }
250
251 # is it a DXNet node
252 sub is_dxnet
253 {
254         my $self = shift;
255         return $self->{'sort'} eq 'X';
256 }
257
258 # is it a ar-cluster node
259 sub is_arcluster
260 {
261         my $self = shift;
262         return $self->{'sort'} eq 'R';
263 }
264
265 # for perl 5.004's benefit
266 sub sort
267 {
268         my $self = shift;
269         return @_ ? $self->{'sort'} = shift : $self->{'sort'} ;
270 }
271
272 # handle out going messages, immediately without waiting for the select to drop
273 # this could, in theory, block
274 sub send_now
275 {
276         my $self = shift;
277         my $conn = $self->{conn};
278         return unless $conn;
279         my $sort = shift;
280         my $call = $self->{call};
281         
282         for (@_) {
283 #               chomp;
284         my @lines = split /\n/;
285                 for (@lines) {
286                         $conn->send_now("$sort$call|$_");
287                         dbg('chan', "-> $sort $call $_");
288                 }
289         }
290         $self->{t} = time;
291 }
292
293 #
294 # the normal output routine
295 #
296 sub send                                                # this is always later and always data
297 {
298         my $self = shift;
299         my $conn = $self->{conn};
300         return unless $conn;
301         my $call = $self->{call};
302
303         for (@_) {
304 #               chomp;
305         my @lines = split /\n/;
306                 for (@lines) {
307                         $conn->send_later("D$call|$_");
308                         dbg('chan', "-> D $call $_");
309                 }
310         }
311         $self->{t} = time;
312 }
313
314 # send a file (always later)
315 sub send_file
316 {
317         my ($self, $fn) = @_;
318         my $call = $self->{call};
319         my $conn = $self->{conn};
320         my @buf;
321   
322         open(F, $fn) or die "can't open $fn for sending file ($!)";
323         @buf = <F>;
324         close(F);
325         $self->send(@buf);
326 }
327
328 # this will implement language independence (in time)
329 sub msg
330 {
331         my $self = shift;
332         return DXM::msg($self->{lang}, @_);
333 }
334
335 # stick a broadcast on the delayed queue (but only up to 20 items)
336 sub delay
337 {
338         my $self = shift;
339         my $s = shift;
340         
341         $self->{delayed} = [] unless $self->{delayed};
342         push @{$self->{delayed}}, $s;
343         if (@{$self->{delayed}} >= 20) {
344                 shift @{$self->{delayed}};   # lose oldest one
345         }
346 }
347
348 # change the state of the channel - lots of scope for debugging here :-)
349 sub state
350 {
351         my $self = shift;
352         if (@_) {
353                 $self->{oldstate} = $self->{state};
354                 $self->{state} = shift;
355                 $self->{func} = '' unless defined $self->{func};
356                 dbg('state', "$self->{call} channel func $self->{func} state $self->{oldstate} -> $self->{state}\n");
357
358                 # if there is any queued up broadcasts then splurge them out here
359                 if ($self->{delayed} && ($self->{state} eq 'prompt' || $self->{state} eq 'talk')) {
360                         $self->send (@{$self->{delayed}});
361                         delete $self->{delayed};
362                 }
363         }
364         return $self->{state};
365 }
366
367 # disconnect this channel
368 sub disconnect
369 {
370         my $self = shift;
371         my $user = $self->{user};
372         my $conn = $self->{conn};
373         my $call = $self->{call};
374         
375         $self->finish($conn);
376         $user->close() if defined $user;
377         $conn->disconnect() if $conn;
378         $self->del();
379 }
380
381 #
382 # just close all the socket connections down without any fiddling about, cleaning, being
383 # nice to other processes and otherwise telling them what is going on.
384 #
385 # This is for the benefit of forked processes to prepare for starting new programs, they
386 # don't want or need all this baggage.
387 #
388
389 sub closeall
390 {
391         my $ref;
392         foreach $ref (values %channels) {
393                 $ref->{conn}->disconnect() if $ref->{conn};
394         }
395 }
396
397 #
398 # Tell all the users that we have come in or out (if they want to know)
399 #
400 sub tell_login
401 {
402         my ($self, $m) = @_;
403         
404         # send info to all logged in thingies
405         my @dxchan = get_all_users();
406         my $dxchan;
407         foreach $dxchan (@dxchan) {
408                 next if $dxchan == $self;
409                 $dxchan->send($dxchan->msg($m, $self->{call})) if $dxchan->{logininfo};
410         }
411 }
412
413 # various access routines
414
415 #
416 # return a list of valid elements 
417
418
419 sub fields
420 {
421         return keys(%valid);
422 }
423
424 #
425 # return a prompt for a field
426 #
427
428 sub field_prompt
429
430         my ($self, $ele) = @_;
431         return $valid{$ele};
432 }
433
434 # take a standard input message and decode it into its standard parts
435 sub decode_input
436 {
437         my $dxchan = shift;
438         my $data = shift;
439         my ($sort, $call, $line) = $data =~ /^([A-Z])([A-Z0-9\-]{3,9})\|(.*)$/;
440
441         my $chcall = (ref $dxchan) ? $dxchan->call : "UN.KNOWN";
442         
443         # the above regexp must work
444         unless (defined $sort && defined $call && defined $line) {
445                 $data =~ s/([\x00-\x1f\x7f-\xff])/uc sprintf("%%%02x",ord($1))/eg;
446                 dbg('err', "DUFF Line on $chcall: $data");
447                 return ();
448         }
449
450         if(ref($dxchan) && $call ne $chcall) {
451                 dbg('err', "DUFF Line come in for $call on wrong channel $chcall" );
452                 return();
453         }
454         
455         return ($sort, $call, $line);
456 }
457
458 no strict;
459 sub AUTOLOAD
460 {
461         my $self = shift;
462         my $name = $AUTOLOAD;
463         return if $name =~ /::DESTROY$/;
464         $name =~ s/.*:://o;
465   
466         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
467
468         # this clever line of code creates a subroutine which takes over from autoload
469         # from OO Perl - Conway
470         *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
471     @_ ? $self->{$name} = shift : $self->{$name} ;
472 }
473
474
475 1;
476 __END__;