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