]> www.dxcluster.org Git - spider.git/blob - perl/DXUser.pm
Set $Spot::readback back to 1
[spider.git] / perl / DXUser.pm
1 #
2 # DX cluster user routines
3 #
4 # Copyright (c) 1998 - Dirk Koopman G1TLH
5 #
6 #
7 #
8
9 package DXUser;
10
11 use DXLog;
12 use DB_File;
13 use Data::Dumper;
14 use Fcntl;
15 use IO::File;
16 use DXDebug;
17 use DXUtil;
18 use LRU;
19 use File::Copy;
20
21 use strict;
22
23 use vars qw(%u $dbm $filename %valid $lastoperinterval $lasttime $lru $lrusize $tooold $v3);
24
25 %u = ();
26 $dbm = undef;
27 $filename = undef;
28 $lastoperinterval = 60*24*60*60;
29 $lasttime = 0;
30 $lrusize = 10000;
31 $tooold = 86400 * 365;          # this marks an old user who hasn't given enough info to be useful
32 $v3 = 0;
33 our $maxconnlist = 3;                   # remember this many connection time (duration) [start, end] pairs
34
35 # hash of valid elements and a simple prompt
36 %valid = (
37                   call => '0,Callsign',
38                   alias => '0,Real Callsign',
39                   name => '0,Name',
40                   qth => '0,Home QTH',
41                   lat => '0,Latitude,slat',
42                   long => '0,Longitude,slong',
43                   qra => '0,Locator',
44                   email => '0,E-mail Address,parray',
45                   priv => '9,Privilege Level',
46                   lastin => '0,Last Time in,cldatetime',
47                   lastseen => '0,Last Seen,cldatetime',
48                   passwd => '9,Password,yesno',
49                   passphrase => '9,Pass Phrase,yesno',
50                   addr => '0,Full Address',
51                   'sort' => '0,Type of User', # A - ak1a, U - User, S - spider cluster, B - BBS
52                   xpert => '0,Expert Status,yesno',
53                   bbs => '0,Home BBS',
54                   node => '0,Last Node',
55                   homenode => '0,Home Node',
56                   lockout => '9,Locked out?,yesno',     # won't let them in at all
57                   dxok => '9,Accept DX Spots?,yesno', # accept his dx spots?
58                   annok => '9,Accept Announces?,yesno', # accept his announces?
59                   lang => '0,Language',
60                   hmsgno => '0,Highest Msgno',
61                   group => '0,Group,parray',    # used to create a group of users/nodes for some purpose or other
62                   buddies => '0,Buddies,parray',
63                   isolate => '9,Isolate network,yesno',
64                   wantbeep => '0,Req Beep,yesno',
65                   wantann => '0,Req Announce,yesno',
66                   wantwwv => '0,Req WWV,yesno',
67                   wantwcy => '0,Req WCY,yesno',
68                   wantecho => '0,Req Echo,yesno',
69                   wanttalk => '0,Req Talk,yesno',
70                   wantwx => '0,Req WX,yesno',
71                   wantdx => '0,Req DX Spots,yesno',
72                   wantemail => '0,Req Msgs as Email,yesno',
73                   pagelth => '0,Current Pagelth',
74                   pingint => '9,Node Ping interval',
75                   nopings => '9,Ping Obs Count',
76                   wantlogininfo => '0,Login Info Req,yesno',
77           wantgrid => '0,Show DX Grid,yesno',
78                   wantann_talk => '0,Talklike Anns,yesno',
79                   wantpc16 => '9,Want Users from node,yesno',
80                   wantsendpc16 => '9,Send PC16,yesno',
81                   wantroutepc19 => '9,Route PC19,yesno',
82                   wantusstate => '0,Show US State,yesno',
83                   wantdxcq => '0,Show CQ Zone,yesno',
84                   wantdxitu => '0,Show ITU Zone,yesno',
85                   wantgtk => '0,Want GTK interface,yesno',
86                   wantpc9x => '0,Want PC9X interface,yesno',
87                   wantrbn => '0,Want RBN spots,yesno',
88                   wantft => '0,Want RBN FT4/8,yesno',
89                   wantcw => '0,Want RBN CW,yesno',
90                   wantrtty => '0,Want RBN RTTY,yesno',
91                   wantpsk => '0,Want RBN PSK,yesno',
92                   wantbeacon => '0,Want (RBN) Beacon,yesno',
93                   lastoper => '9,Last for/oper,cldatetime',
94                   nothere => '0,Not Here Text',
95                   registered => '9,Registered?,yesno',
96                   prompt => '0,Required Prompt',
97                   version => '1,Version',
98                   build => '1,Build',
99                   believe => '1,Believable nodes,parray',
100                   lastping => '1,Last Ping at,ptimelist',
101                   maxconnect => '1,Max Connections',
102                   startt => '0,Start Time,cldatetime',
103                   connlist => '1,Connections,parraydifft',
104                   width => '0,Preferred Width'
105                  );
106
107 #no strict;
108 sub AUTOLOAD
109 {
110         no strict;
111         my $name = $AUTOLOAD;
112   
113         return if $name =~ /::DESTROY$/;
114         $name =~ s/^.*:://o;
115   
116         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
117         # this clever line of code creates a subroutine which takes over from autoload
118         # from OO Perl - Conway
119         *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}};
120        goto &$AUTOLOAD;
121 }
122
123 #use strict;
124
125 #
126 # initialise the system
127 #
128 sub init
129 {
130         my $mode = shift;
131   
132         my $ufn;
133         my $convert;
134         
135         eval {
136                 require Storable;
137         };
138
139         my $fn = "users";
140         
141         if ($@) {
142                 $ufn = localdata("users.v2");
143                 $v3 = $convert = 0;
144                 dbg("the module Storable appears to be missing!!");
145                 dbg("trying to continue in compatibility mode (this may fail)");
146                 dbg("please install Storable from CPAN as soon as possible");
147         } else {
148                 import Storable qw(nfreeze thaw);
149
150                 $ufn = localdata("users.v3");
151                 $v3 = 1;
152                 $convert++ if -e localdata("users.v2") && !-e $ufn;
153         }
154         
155         if ($mode) {
156                 $dbm = tie (%u, 'DB_File', $ufn, O_CREAT|O_RDWR, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]";
157         } else {
158                 $dbm = tie (%u, 'DB_File', $ufn, O_RDONLY, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]";
159         }
160
161         die "Cannot open $ufn ($!)\n" unless $dbm;
162
163         $lru = LRU->newbase("DXUser", $lrusize);
164         
165         # do a conversion if required
166         if ($dbm && $convert) {
167                 my ($key, $val, $action, $count, $err) = ('','',0,0,0);
168                 
169                 my %oldu;
170                 dbg("Converting the User File to V3 ");
171                 dbg("This will take a while, I suggest you go and have cup of strong tea");
172                 my $odbm = tie (%oldu, 'DB_File', localdata("users.v2"), O_RDONLY, 0666, $DB_BTREE) or confess "can't open user file: $fn.v2 ($!) [rebuild it from user_asc?]";
173         for ($action = R_FIRST; !$odbm->seq($key, $val, $action); $action = R_NEXT) {
174                         my $ref;
175                         eval { $ref = asc_decode($val) };
176                         unless ($@) {
177                                 if ($ref) {
178                                         $ref->put;
179                                         $count++;
180                                 } else {
181                                         $err++
182                                 }
183                         } else {
184                                 Log('err', "DXUser: error decoding $@");
185                         }
186                 } 
187                 undef $odbm;
188                 untie %oldu;
189                 dbg("Conversion completed $count records $err errors");
190         }
191         $filename = $ufn;
192 }
193
194 sub del_file
195 {
196         # with extreme prejudice
197         unlink "$main::data/users.v3";
198         unlink "$main::local_data/users.v3";
199 }
200
201 #
202 # periodic processing
203 #
204 sub process
205 {
206         if ($main::systime > $lasttime + 15) {
207                 $dbm->sync if $dbm;
208                 $lasttime = $main::systime;
209         }
210 }
211
212 #
213 # close the system
214 #
215
216 sub finish
217 {
218         $dbm->sync;
219         undef $dbm;
220         untie %u;
221 }
222
223 #
224 # new - create a new user
225 #
226
227 sub alloc
228 {
229         my $pkg = shift;
230         my $call = uc shift;
231         my $self = bless {call => $call, 'sort'=>'U'}, $pkg;
232         return $self;
233 }
234
235 sub new
236 {
237         my $pkg = shift;
238         my $call = shift;
239         #  $call =~ s/-\d+$//o;
240   
241 #       confess "can't create existing call $call in User\n!" if $u{$call};
242
243         my $self = $pkg->alloc($call);
244         $self->{lastseen} = $main::systime;
245         $self->put;
246         return $self;
247 }
248
249 #
250 # get - get an existing user - this seems to return a different reference everytime it is
251 #       called - see below
252 #
253
254 sub get
255 {
256         my $call = uc shift;
257         my $data;
258         
259         # is it in the LRU cache?
260         my $ref = $lru->get($call);
261         if ($ref && ref $ref eq 'DXUser') {
262                 $ref->{lastseen} = $main::systime;
263                 return $ref;
264         }
265         
266         # search for it
267         unless ($dbm->get($call, $data)) {
268                 eval { $ref = decode($data); };
269                 
270                 if ($ref) {
271                         if (!UNIVERSAL::isa($ref, 'DXUser')) {
272                                 dbg("DXUser::get: got strange answer from decode of $call". ref $ref. " ignoring");
273                                 return undef;
274                         }
275                         # we have a reference and it *is* a DXUser
276                 } else {
277                         if ($@) {
278                                 LogDbg('err', "DXUser::get decode error on $call '$@'");
279                         } else {
280                                 dbg("DXUser::get: no reference returned from decode of $call $!");
281                         }
282                         return undef;
283                 }
284                 $ref->{lastseen} = $main::systime;
285                 $lru->put($call, $ref);
286                 return $ref;
287         }
288         return undef;
289 }
290
291 #
292 # get an existing either from the channel (if there is one) or from the database
293 #
294 # It is important to note that if you have done a get (for the channel say) and you
295 # want access or modify that you must use this call (and you must NOT use get's all
296 # over the place willy nilly!)
297 #
298
299 sub get_current
300 {
301         my $call = uc shift;
302   
303         my $dxchan = DXChannel::get($call);
304         if ($dxchan) {
305                 my $ref = $dxchan->user;
306                 return $ref if $ref && UNIVERSAL::isa($ref, 'DXUser');
307
308                 dbg("DXUser::get_current: got invalid user ref for $call from dxchan $dxchan->{call} ". ref $ref. " ignoring");
309         }
310         return get($call);
311 }
312
313 #
314 # get all callsigns in the database 
315 #
316
317 sub get_all_calls
318 {
319         return (sort keys %u);
320 }
321
322 #
323 # put - put a user
324 #
325
326 sub put
327 {
328         my $self = shift;
329         confess "Trying to put nothing!" unless $self && ref $self;
330         my $call = $self->{call};
331
332         $dbm->del($call);
333         delete $self->{annok} if $self->{annok};
334         delete $self->{dxok} if $self->{dxok};
335
336         $lru->put($call, $self);
337         my $ref = $self->encode;
338         $dbm->put($call, $ref);
339 }
340
341 # freeze the user
342 sub encode
343 {
344         goto &asc_encode unless $v3;
345         my $self = shift;
346         return nfreeze($self);
347 }
348
349 # thaw the user
350 sub decode
351 {
352         goto &asc_decode unless $v3;
353         my $ref;
354         $ref = thaw(shift);
355         return $ref;
356 }
357
358
359 # create a string from a user reference (in_ascii)
360 #
361 sub asc_encode
362 {
363         my $self = shift;
364         my $strip = shift;
365         my $p;
366
367         if ($strip) {
368                 my $ref = bless {}, ref $self;
369                 foreach my $k (qw(qth lat long qra sort call homenode node lastoper lastin)) {
370                         $ref->{$k} = $self->{$k} if exists $self->{$k};
371                 }
372                 $ref->{name} = $self->{name} if exists $self->{name} && $self->{name} !~ /selfspot/i;
373                 $p = dd($ref);
374         } else {
375                 $p = dd($self);
376         }
377         return $p;
378 }
379
380 #
381 # create a hash from a string (in ascii)
382 #
383 sub asc_decode
384 {
385         my $s = shift;
386         my $ref;
387         $s =~ s/\%([0-9A-F][0-9A-F])/chr(hex($1))/eg;
388         eval '$ref = ' . $s;
389         if ($@) {
390                 LogDbg('err', "DXUser::asc_decode: on '$s' $@");
391                 $ref = undef;
392         }
393         return $ref;
394 }
395
396 #
397 # del - delete a user
398 #
399
400 sub del
401 {
402         my $self = shift;
403         my $call = $self->{call};
404         $lru->remove($call);
405         $dbm->del($call);
406 }
407
408 #
409 # close - close down a user
410 #
411
412 sub close
413 {
414         my $self = shift;
415         my $startt = shift;
416         my $ip = shift;
417         $self->{lastseen} = $self->{lastin} = $main::systime;
418         # add a record to the connect list
419         my $ref = [$startt || $self->{startt}, $main::systime];
420         push @$ref, $ip if $ip;
421         push @{$self->{connlist}}, $ref;
422         shift @{$self->{connlist}} if @{$self->{connlist}} > $maxconnlist;
423         $self->put();
424 }
425
426 #
427 # sync the database
428 #
429
430 sub sync
431 {
432         $dbm->sync;
433 }
434
435 #
436 # return a list of valid elements 
437
438
439 sub fields
440 {
441         return keys(%valid);
442 }
443
444
445 #
446 # export the database to an ascii file
447 #
448
449 sub export
450 {
451         my $name = shift || 'user_asc';
452         my $basic_info_only = shift;
453
454         my $fn = $name ne 'user_asc' ? $name : "$main::local_data/$name";                       # force use of local
455         
456         # save old ones
457         move "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo";
458         move "$fn.ooo", "$fn.oooo" if -e "$fn.ooo";
459         move "$fn.oo", "$fn.ooo" if -e "$fn.oo";
460         move "$fn.o", "$fn.oo" if -e "$fn.o";
461         move "$fn", "$fn.o" if -e "$fn";
462
463         my $count = 0;
464         my $err = 0;
465         my $del = 0;
466         my $fh = new IO::File ">$fn" or return "cannot open $fn ($!)";
467         if ($fh) {
468                 my $key = 0;
469                 my $val = undef;
470                 my $action;
471                 my $t = scalar localtime;
472                 print $fh q{#!/usr/bin/perl
473 #
474 # The exported userfile for a DXSpider System
475 #
476 # Input file: $filename
477 #       Time: $t
478 #
479                         
480 package main;
481                         
482 # search local then perl directories
483 BEGIN {
484         umask 002;
485                                 
486         # root of directory tree for this system
487         $root = "/spider"; 
488         $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
489         
490         unshift @INC, "$root/perl";     # this IS the right way round!
491         unshift @INC, "$root/local";
492         
493         # try to detect a lockfile (this isn't atomic but 
494         # should do for now
495         $lockfn = "$root/local_data/cluster.lck";       # lock file name
496         if (-e $lockfn) {
497                 open(CLLOCK, "$lockfn") or die "Can't open Lockfile ($lockfn) $!";
498                 my $pid = <CLLOCK>;
499                 chomp $pid;
500                 die "Lockfile ($lockfn) and process $pid exists - cluster must be stopped first\n" if kill 0, $pid;
501                 close CLLOCK;
502         }
503 }
504
505 use SysVar;
506 use DXUser;
507
508 if (@ARGV) {
509         $main::userfn = shift @ARGV;
510         print "user filename now $userfn\n";
511 }
512
513 package DXUser;
514
515 del_file();
516 init(1);
517 %u = ();
518 my $count = 0;
519 my $err = 0;
520 while (<DATA>) {
521         chomp;
522         my @f = split /\t/;
523         my $ref = asc_decode($f[1]);
524         if ($ref) {
525                 $ref->put();
526                 $count++;
527         DXUser::sync() unless $count % 10000;
528         } else {
529                 print "# Error: $f[0]\t$f[1]\n";
530                 $err++
531         }
532 }
533 DXUser::sync(); DXUser::finish();
534 print "There are $count user records and $err errors\n";
535 };
536                 print $fh "__DATA__\n";
537
538         for ($action = R_FIRST; !$dbm->seq($key, $val, $action); $action = R_NEXT) {
539                         if (!is_callsign($key) || $key =~ /^0/) {
540                                 my $eval = $val;
541                                 my $ekey = $key;
542                                 $eval =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg; 
543                                 $ekey =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg;
544                                 LogDbg('DXCommand', "Export Error1: invalid call '$key' => '$val'");
545                                 eval {$dbm->del($key)};
546                             dbg(carp("Export Error1: delete $key => '$val' $@")) if $@;
547                                 ++$err;
548                                 next;
549                         }
550                         my $ref;
551                         eval {$ref = decode($val); };
552                         if ($ref) {
553                                 my $t = $ref->{lastin} || 0;
554                                 if ($ref->is_user && !$ref->{priv} && $main::systime > $t + $tooold) {
555                                         unless ($ref->{lat} && $ref->{long} || $ref->{qth} || $ref->{qra}) {
556                                                 eval {$dbm->del($key)};
557                                                 dbg(carp("Export Error2: delete '$key' => '$val' $@")) if $@;
558                                                 LogDbg('DXCommand', "$ref->{call} deleted, too old");
559                                                 $del++;
560                                                 next;
561                                         }
562                                 }
563                                 # only store users that are reasonably active or have useful information
564                                 print $fh "$key\t" . $ref->asc_encode($basic_info_only) . "\n";
565                                 ++$count;
566                         } else {
567                                 LogDbg('DXCommand', "Export Error3: '$key'\t" . carp($val) ."\n$@");
568                                 eval {$dbm->del($key)};
569                                 dbg(carp("Export Error3: delete '$key' => '$val' $@")) if $@;
570                                 ++$err;
571                         }
572                 } 
573         $fh->close;
574     }
575         my $s = qq{Exported users to $fn - $count Users $del Deleted $err Errors ('sh/log Export' for details)};
576         LogDbg('command', $s);
577         return $s;
578 }
579
580 #
581 # group handling
582 #
583
584 # add one or more groups
585 sub add_group
586 {
587         my $self = shift;
588         my $ref = $self->{group} || [ 'local' ];
589         $self->{group} = $ref if !$self->{group};
590         push @$ref, @_ if @_;
591 }
592
593 # remove one or more groups
594 sub del_group
595 {
596         my $self = shift;
597         my $ref = $self->{group} || [ 'local' ];
598         my @in = @_;
599         
600         $self->{group} = $ref if !$self->{group};
601         
602         @$ref = map { my $a = $_; return (grep { $_ eq $a } @in) ? () : $a } @$ref;
603 }
604
605 # does this thing contain all the groups listed?
606 sub union
607 {
608         my $self = shift;
609         my $ref = $self->{group};
610         my $n;
611         
612         return 0 if !$ref || @_ == 0;
613         return 1 if @$ref == 0 && @_ == 0;
614         for ($n = 0; $n < @_; ) {
615                 for (@$ref) {
616                         my $a = $_;
617                         $n++ if grep $_ eq $a, @_; 
618                 }
619         }
620         return $n >= @_;
621 }
622
623 # simplified group test just for one group
624 sub in_group
625 {
626         my $self = shift;
627         my $s = shift;
628         my $ref = $self->{group};
629         
630         return 0 if !$ref;
631         return grep $_ eq $s, $ref;
632 }
633
634 # set up a default group (only happens for them's that connect direct)
635 sub new_group
636 {
637         my $self = shift;
638         $self->{group} = [ 'local' ];
639 }
640
641 # set up empty buddies (only happens for them's that connect direct)
642 sub new_buddies
643 {
644         my $self = shift;
645         $self->{buddies} = [  ];
646 }
647
648 #
649 # return a prompt for a field
650 #
651
652 sub field_prompt
653
654         my ($self, $ele) = @_;
655         return $valid{$ele};
656 }
657
658 # some variable accessors
659 sub sort
660 {
661         my $self = shift;
662         @_ ? $self->{'sort'} = shift : $self->{'sort'} ;
663 }
664
665 # some accessors
666
667 # want is default = 1
668 sub _want
669 {
670         my $n = shift;
671         my $self = shift;
672         my $val = shift;
673         my $s = "want$n";
674         $self->{$s} = $val if defined $val;
675         return exists $self->{$s} ? $self->{$s} : 1;
676 }
677
678 # wantnot is default = 0
679 sub _wantnot
680 {
681         my $n = shift;
682         my $self = shift;
683         my $val = shift;
684         my $s = "want$n";
685         $self->{$s} = $val if defined $val;
686         return exists $self->{$s} ? $self->{$s} : 0;
687 }
688
689 sub wantbeep
690 {
691         return _want('beep', @_);
692 }
693
694 sub wantann
695 {
696         return _want('ann', @_);
697 }
698
699 sub wantwwv
700 {
701         return _want('wwv', @_);
702 }
703
704 sub wantwcy
705 {
706         return _want('wcy', @_);
707 }
708
709 sub wantecho
710 {
711         return _want('echo', @_);
712 }
713
714 sub wantwx
715 {
716         return _want('wx', @_);
717 }
718
719 sub wantdx
720 {
721         return _want('dx', @_);
722 }
723
724 sub wanttalk
725 {
726         return _want('talk', @_);
727 }
728
729 sub wantgrid
730 {
731         return _want('grid', @_);
732 }
733
734 sub wantemail
735 {
736         return _want('email', @_);
737 }
738
739 sub wantann_talk
740 {
741         return _want('ann_talk', @_);
742 }
743
744 sub wantpc16
745 {
746         return _want('pc16', @_);
747 }
748
749 sub wantsendpc16
750 {
751         return _want('sendpc16', @_);
752 }
753
754 sub wantroutepc16
755 {
756         return _want('routepc16', @_);
757 }
758
759 sub wantusstate
760 {
761         return _want('usstate', @_);
762 }
763
764 sub wantdxcq
765 {
766         return _want('dxcq', @_);
767 }
768
769 sub wantdxitu
770 {
771         return _want('dxitu', @_);
772 }
773
774 sub wantgtk
775 {
776         return _want('gtk', @_);
777 }
778
779 sub wantpc9x
780 {
781         return _want('pc9x', @_);
782 }
783
784 sub wantlogininfo
785 {
786         my $self = shift;
787         my $val = shift;
788         $self->{wantlogininfo} = $val if defined $val;
789         return $self->{wantlogininfo};
790 }
791
792 sub is_node
793 {
794         my $self = shift;
795         return $self->{sort} =~ /^[ACRSX]$/;
796 }
797
798 sub is_local_node
799 {
800         my $self = shift;
801         return grep $_ eq 'local_node', @{$self->{group}};
802 }
803
804 sub is_user
805 {
806         my $self = shift;
807         return $self->{sort} =~ /^[UW]$/;
808 }
809
810 sub is_web
811 {
812         my $self = shift;
813         return $self->{sort} eq 'W';
814 }
815
816 sub is_bbs
817 {
818         my $self = shift;
819         return $self->{sort} eq 'B';
820 }
821
822 sub is_spider
823 {
824         my $self = shift;
825         return $self->{sort} eq 'S';
826 }
827
828 sub is_clx
829 {
830         my $self = shift;
831         return $self->{sort} eq 'C';
832 }
833
834 sub is_dxnet
835 {
836         my $self = shift;
837         return $self->{sort} eq 'X';
838 }
839
840 sub is_arcluster
841 {
842         my $self = shift;
843         return $self->{sort} eq 'R';
844 }
845
846 sub is_ak1a
847 {
848         my $self = shift;
849         return $self->{sort} eq 'A';
850 }
851
852 sub is_rbn
853 {
854         my $self = shift;
855         return $self->{sort} eq 'N'
856 }
857
858 sub unset_passwd
859 {
860         my $self = shift;
861         delete $self->{passwd};
862 }
863
864 sub unset_passphrase
865 {
866         my $self = shift;
867         delete $self->{passphrase};
868 }
869
870 sub set_believe
871 {
872         my $self = shift;
873         my $call = uc shift;
874         $self->{believe} ||= [];
875         push @{$self->{believe}}, $call unless grep $_ eq $call, @{$self->{believe}};
876 }
877
878 sub unset_believe
879 {
880         my $self = shift;
881         my $call = uc shift;
882         if (exists $self->{believe}) {
883                 $self->{believe} = [grep {$_ ne $call} @{$self->{believe}}];
884                 delete $self->{believe} unless @{$self->{believe}};
885         }
886 }
887
888 sub believe
889 {
890         my $self = shift;
891         return exists $self->{believe} ? @{$self->{believe}} : ();
892 }
893
894 sub lastping
895 {
896         my $self = shift;
897         my $call = shift;
898         $self->{lastping} ||= {};
899         $self->{lastping} = {} unless ref $self->{lastping};
900         my $b = $self->{lastping};
901         $b->{$call} = shift if @_;
902         return $b->{$call};     
903 }
904 1;
905 __END__
906
907
908
909
910