]> gb7djk.dxcluster.net Git - spider.git/blob - perl/DXUser.pm
c273970bf542df3a8c0589124486239e537eee05
[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 Data::Dumper;
13 use Fcntl;
14 use IO::File;
15 use DXDebug;
16 use DXUtil;
17 use LRU;
18
19 use strict;
20
21 use vars qw(%u $dbm $dbh $filename %valid $lastoperinterval $lasttime $lru $lrusize $tooold $v3 $v4);
22
23 %u = ();
24 $dbm = undef;
25 $dbh = undef;
26 $filename = undef;
27 $lastoperinterval = 60*24*60*60;
28 $lasttime = 0;
29 $lrusize = 2000;
30 $tooold = 86400 * 365;          # this marks an old user who hasn't given enough info to be useful
31 $v3 = 0;
32
33 my $dbh_working;
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                   lastoper => '9,Last for/oper,cldatetime',
87                   nothere => '0,Not Here Text',
88                   registered => '9,Registered?,yesno',
89                   prompt => '0,Required Prompt',
90                   version => '1,Version',
91                   build => '1,Build',
92                   believe => '1,Believable nodes,parray',
93                   lastping => '1,Last Ping at,ptimelist',
94                   maxconnect => '1,Max Connections',
95                  );
96
97 #no strict;
98 sub AUTOLOAD
99 {
100         no strict;
101         my $name = $AUTOLOAD;
102   
103         return if $name =~ /::DESTROY$/;
104         $name =~ s/^.*:://o;
105   
106         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
107         # this clever line of code creates a subroutine which takes over from autoload
108         # from OO Perl - Conway
109         *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}};
110        goto &$AUTOLOAD;
111 }
112
113 #use strict;
114
115 #
116 # initialise the system
117 #
118 sub init
119 {
120         my ($pkg, $fn, $mode) = @_;
121   
122         confess "need a filename in User" if !$fn;
123
124         my $ufn;
125         my $convert;
126
127         eval {
128                 require DBI;
129                 require DBD::SQLite;
130                 require JSON;
131         };
132         
133         if ($@) {
134                 
135                 $ufn = "$fn.v3";
136                 $v3 = 1; $convert = 0;
137                 dbg("One of more of the modules DBI, DBD::SQLite and JSON appear to be missing!!");
138                 dbg("trying to continue in compatibility mode (this may fail)");
139                 dbg("please install DBI, DBD::SQLite and JSON from CPAN as soon as possible");
140
141                 eval {
142                         require DB_File;
143                         require Storable;
144                 };
145
146                 if ($@) {
147                         $ufn = "$fn.v2";
148                         $v3 = $convert = 0;
149                         dbg("One of the modules DB_File and Storable appears to be missing!!");
150                         dbg("trying to continue in compatibility mode (this may fail)");
151                         dbg("please install Storable from CPAN as soon as possible");
152                 } else {
153                         import DB_File;
154                         import Storable qw(nfreeze thaw);
155                         
156                         $ufn = "$fn.v3";
157                         $v3 = 1;
158                         $convert++ if -e "$fn.v2" && !-e $ufn;
159                 }
160         } else {
161                 import DBI;
162                 import DBD::SQLite;
163                 import JSON qw(-convert_blessed_universally);
164                 
165                 $ufn = "$fn.v4";
166                 $v4 = 1;
167                 $convert++ if -e "$fn.v3" && !-e $ufn;
168         }
169
170         $main::systime ||= time;        # becuase user_asc doesn't set it
171
172         # open "database" files
173         if ($v3) {
174                 if ($mode) {
175                         $dbm = tie (%u, 'DB_File', "$fn.v3", O_CREAT|O_RDWR, 0666, $DB::File::DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]";
176                 } else {
177                         $dbm = tie (%u, 'DB_File', "$fn.v3", O_RDONLY, 0666, $DB_File::DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]";
178                 }
179                 die "Cannot open $fn.v3 ($!)\n" unless $dbm;
180         }
181         if ($v4) {
182                 my $new = ! -e $ufn;
183                 $dbh = DBI->connect("dbi:SQLite:dbname=$ufn","","") or die "Cannot open $ufn ($!)\n";
184                 if ($new) {
185                         # create the table
186                         my $table = q{create table user(
187 call text not null unique,
188 lastseen int not null,
189 data text not null
190 )};
191                         $dbh->do($table) or die "cannot create user table in $ufn " . $dbh->errstr;
192                         
193                         # Add indexes
194                         $dbh->do(q(create index x1 on user(lastseen))) or die $dbh->errstr;
195                 }
196                 $dbh->do(q{PRAGMA cache_size = 8000});
197                 $dbh->do(q{PRAGMA synchronous = OFF});
198         }
199
200
201         # do a conversion if required
202         if ($dbm && $v3 && $convert) {
203                 my ($key, $val, $action, $count, $err) = ('','',0,0,0);
204
205                 require DB_File;
206                 require Storable;
207                 import DB_File;
208                 import Storable qw(nfreeze thaw);
209                 
210                 my %oldu;
211                 dbg("Converting the User File to V3 ");
212                 dbg("This will take a while, I suggest you go and have a cup of strong tea");
213                 my $odbm = tie (%oldu, 'DB_File', "$fn.v2", O_RDONLY, 0666, $DB_File::DB_BTREE) or confess "can't open user file: $fn.v2 ($!) [rebuild it from user_asc?]";
214         for ($action = DB_File::R_FIRST(); !$odbm->seq($key, $val, $action); $action = DB_File::R_NEXT()) {
215                         my $ref = asc_decode($val);
216                         if ($ref) {
217                                 $ref->put;
218                                 $count++;
219                         } else {
220                                 $err++
221                         }
222                 } 
223                 undef $odbm;
224                 untie %oldu;
225                 dbg("Conversion completed $count records $err errors");
226         }
227
228         if ($dbh && $v4 && $convert) {
229                 my ($key, $val, $action, $count, $err) = ('','',0,0,0);
230                 
231                 
232                 my %oldu;
233                 dbg("Converting the User File to V4 ");
234                 dbg("This will take a while, I suggest you go and have a cup of strong tea");
235                 require DB_File;
236                 require Storable;
237                 import DB_File;
238                 import Storable qw(nfreeze thaw);
239                 my $odbm = tie (%oldu, 'DB_File', "$fn.v3", O_RDONLY, 0666, $DB_File::DB_BTREE) or confess "can't open user file: $fn.v3 ($!) [rebuild it from user_asc?]";
240                 $dbh->begin_work;
241                 $dbh_working++;
242         for ($action = DB_File::R_FIRST(); !$odbm->seq($key, $val, $action); $action = DB_File::R_NEXT()) {
243                         my $ref = thaw($val);
244                         if ($ref) {
245                                 my $r = _insert($ref);
246                                 if ($r) {
247                                         $count++;
248                                 } else {
249                                         $err++;
250                                         dbg("error converting call $ref->{call} - " . $dbh->errstr);
251                                 }
252                         } else {
253                                 $err++
254                         }
255                 }
256                 sync();
257                 undef $odbm;
258                 untie %oldu;
259                 dbg("Conversion completed $count records $err errors");
260
261         }
262
263         $lru = LRU->newbase("DXUser", $lrusize);
264         
265         $filename = $ufn;
266 }
267
268 sub del_file
269 {
270         my ($pkg, $fn) = @_;
271   
272         confess "need a filename in User" if !$fn;
273         my $suffix;
274         $suffix = '.v4' if $v4;
275         $suffix ||= '.v3' if $v3;
276         $suffix ||= '.v2';
277         $fn .= $suffix;
278         unlink $fn;
279 }
280
281 #
282 # periodic processing
283 #
284 sub process
285 {
286         if ($main::systime > $lasttime + 5) {
287                 sync();
288                 $lasttime = $main::systime;
289         }
290 }
291
292 #
293 # close the system
294 #
295
296 sub finish
297 {
298         if ($dbm) {
299                 undef $dbm;
300                 untie %u;
301         }
302         $dbh->disconnect if $dbh; 
303 }
304
305 #
306 # new - create a new user
307 #
308
309 sub alloc
310 {
311         my $pkg = shift;
312         my $call = uc shift;
313         my $self = bless {call => $call, 'sort'=>'U'}, $pkg;
314         _insert($self) or confess($dbh->errstr) if $v4;
315         return $self;
316 }
317
318 sub _insert
319 {
320         my $self = shift;
321         my $json = JSON->new->allow_blessed->convert_blessed->encode($self);
322         $dbh->begin_work unless $dbh_working++;
323         my $r = $dbh->do(q{replace into user values(?,?,?)}, undef, $self->{call}, $main::systime, $json);
324         return $r;
325 }
326
327 sub _select
328 {
329         my $call = shift;
330         my $sth = $dbh->prepare(qq{select data from user where call = ?}) or confess($dbh->errstr);
331         my $rv = $sth->execute($call);
332         if ($rv) {
333                 my @row = $sth->fetchrow_array;
334                 return $row[0];
335         }
336         return undef;
337 }
338
339 sub _delete
340 {
341         my $call =shift;
342         my $r = $dbh->do(q{delete from user where call = ?}, undef, $call);
343         return $r;
344 }
345
346 sub new
347 {
348         my $pkg = shift;
349         my $call = shift;
350         #  $call =~ s/-\d+$//o;
351   
352 #       confess "can't create existing call $call in User\n!" if $u{$call};
353
354         my $self = $pkg->alloc($call);
355         $self->put unless $v4;
356         return $self;
357 }
358
359 #
360 # get - get an existing user - this seems to return a different reference everytime it is
361 #       called - see below
362 #
363
364 sub get
365 {
366         my $call = uc shift;
367         my $data;
368         
369         # is it in the LRU cache?
370         my $ref = $lru->get($call);
371         return $ref if $ref && ref $ref eq 'DXUser';
372         
373         # search for it
374         if ($v4) {
375                 if ($data = _select($call)) {
376                         $ref = bless decode_json($data), __PACKAGE__;
377                         $lru->put($call, $ref);
378                         return $ref;
379                 }
380         } else {
381             unless ($dbm->get($call, $data)) {
382                         $ref = decode($data);
383                         if ($ref) {
384                                 if (ref $ref ne 'DXUser') {
385                                         dbg("DXUser::get: got strange answer from decode ". ref $ref. " ignoring");
386                                         return undef;
387                                 }
388                         } else {
389                                 dbg("DXUser::get: no reference returned from decode $!");
390                                 return undef;
391                         }
392                         $lru->put($call, $ref);
393                         return $ref;
394                 }
395         }
396         
397         return undef;
398 }
399
400 #
401 # get an existing either from the channel (if there is one) or from the database
402 #
403 # It is important to note that if you have done a get (for the channel say) and you
404 # want access or modify that you must use this call (and you must NOT use get's all
405 # over the place willy nilly!)
406 #
407
408 sub get_current
409 {
410         my $call = uc shift;
411   
412         my $dxchan = DXChannel::get($call);
413         if ($dxchan) {
414                 my $ref = $dxchan->user;
415                 return $ref if ref $ref eq 'DXUser';
416
417                 dbg("DXUser::get_current: got invalid user ref from dxchan $dxchan->{call} ". ref $ref. " ignoring");
418         }
419         return get($call);
420 }
421
422 #
423 # get all callsigns in the database 
424 #
425
426 sub get_all_calls
427 {
428         if ($v4) {
429                 my $sth = $dbh->prepare(qq{select call from user}) or confess($dbh->errstr);
430                 my $rv = $sth->execute();
431                 if ($rv) {
432                         my @row;
433                         my @r;
434                         while (my @r = $sth->fetchrow_array) {
435                                 push @row, @r;
436                         }
437                         return @row;            # 'cos it's already sorted
438                 }
439         } else {
440                 return (sort keys %u);
441         }
442 }
443
444 #
445 # put - put a user
446 #
447
448 sub put
449 {
450         my $self = shift;
451         confess "Trying to put nothing!" unless $self && ref $self;
452         my $call = $self->{call};
453
454         delete $self->{annok} if $self->{annok};
455         delete $self->{dxok} if $self->{dxok};
456
457         $lru->put($call, $self);
458         if ($v4) {
459                 _insert($self);
460         } else {
461                 $dbm->del($call);
462                 my $ref = $self->encode;
463                 $dbm->put($call, $ref);
464         }
465 }
466
467 # freeze the user
468 sub encode
469 {
470         goto &asc_encode unless $v3;
471         my $self = shift;
472         return nfreeze($self);
473 }
474
475 # thaw the user
476 sub decode
477 {
478         goto &asc_decode unless $v3;
479         return thaw(shift);
480 }
481
482
483 # create a string from a user reference (in_ascii)
484 #
485 sub asc_encode
486 {
487         my $self = shift;
488         my $strip = shift;
489         my $p;
490
491         if ($strip) {
492                 my $ref = bless {}, ref $self;
493                 foreach my $k (qw(qth lat long qra sort call homenode node lastoper lastin)) {
494                         $ref->{$k} = $self->{$k} if exists $self->{$k};
495                 }
496                 $ref->{name} = $self->{name} if exists $self->{name} && $self->{name} !~ /selfspot/i;
497                 $p = dd($ref);
498         } else {
499                 $p = dd($self);
500         }
501         return $p;
502 }
503
504 #
505 # create a hash from a string (in ascii)
506 #
507 sub asc_decode
508 {
509         my $s = shift;
510         my $ref;
511         $s =~ s/\%([0-9A-F][0-9A-F])/chr(hex($1))/eg;
512         eval '$ref = ' . $s;
513         if ($@) {
514                 LogDbg('err', $@);
515                 $ref = undef;
516         }
517         return $ref;
518 }
519
520 #
521 # del - delete a user
522 #
523
524 sub del
525 {
526         my $self = shift;
527         if ($v4) {
528                 _delete($self)
529         } else {
530                 my $call = $self->{call};
531                 $lru->remove($call);
532                 $dbm->del($call);
533         }
534 }
535
536 #
537 # close - close down a user
538 #
539
540 sub close
541 {
542         my $self = shift;
543         $self->{lastin} = time;
544         $self->put;
545 }
546
547 #
548 # sync the database
549 #
550
551 sub sync
552 {
553         if ($v4) {
554                 $dbh->commit if $dbh_working;
555                 $dbh_working = 0;
556         } else {
557                 $dbm->sync;
558         }
559 }
560
561 #
562 # return a list of valid elements 
563
564
565 sub fields
566 {
567         return keys(%valid);
568 }
569
570
571 #
572 # export the database to an ascii file
573 #
574
575 sub export
576 {
577         my $fn = shift;
578         my $basic_info_only = shift;
579         
580         # save old ones
581         rename "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo";
582         rename "$fn.ooo", "$fn.oooo" if -e "$fn.ooo";
583         rename "$fn.oo", "$fn.ooo" if -e "$fn.oo";
584         rename "$fn.o", "$fn.oo" if -e "$fn.o";
585         rename "$fn", "$fn.o" if -e "$fn";
586
587         my $count = 0;
588         my $err = 0;
589         my $del = 0;
590         my $fh = new IO::File ">$fn" or return "cannot open $fn ($!)";
591         if ($fh) {
592                 my $t = scalar localtime;
593                 print $fh q{#!/usr/bin/perl
594 #
595 # The exported userfile for a DXSpider System
596 #
597 # Input file: $filename
598 #       Time: $t
599 #
600                         
601 package main;
602                         
603 # search local then perl directories
604 BEGIN {
605         umask 002;
606                                 
607         # root of directory tree for this system
608         $root = "/spider"; 
609         $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
610         
611         unshift @INC, "$root/perl";     # this IS the right way round!
612         unshift @INC, "$root/local";
613         
614         # try to detect a lockfile (this isn't atomic but 
615         # should do for now
616         $lockfn = "$root/local/cluster.lck";       # lock file name
617         if (-e $lockfn) {
618                 open(CLLOCK, "$lockfn") or die "Can't open Lockfile ($lockfn) $!";
619                 my $pid = <CLLOCK>;
620                 chomp $pid;
621                 die "Lockfile ($lockfn) and process $pid exists - cluster must be stopped first\n" if kill 0, $pid;
622                 close CLLOCK;
623         }
624 }
625
626 package DXUser;
627
628 use DXVars;
629 use DXUser;
630
631 if (@ARGV) {
632         $main::userfn = shift @ARGV;
633         print "user filename now $userfn\n";
634 }
635
636 DXUser->del_file($main::userfn);
637 DXUser->init($main::userfn, 1);
638 %u = ();
639 my $count = 0;
640 my $err = 0;
641 while (<DATA>) {
642         chomp;
643         my @f = split /\t/;
644         my $ref = asc_decode($f[1]);
645         if ($ref) {
646                 $ref->put();
647                 $count++;
648         } else {
649                 print "# Error: $f[0]\t$f[1]\n";
650                 $err++
651         }
652 }
653 DXUser->sync; DXUser->finish;
654 print "There are $count user records and $err errors\n";
655 };
656                 print $fh "__DATA__\n";
657
658                 if ($v4) {
659                         my $sth = $dbh->prepare(q{select call,data from user}) or confess($dbh->errstr);
660                         my $rv = $sth->execute;
661                         if ($rv) {
662                                 while (my @row = $sth->fetchrow_array) {
663                                         my $call = shift @row;
664                                         my $data = shift @row;
665                                         if (!is_callsign($call) || $call =~ /^0/) {
666                                                 LogDbg('DXCommand', "Export Error1: $call\t$data");
667                                                 _delete($call);
668                                                 ++$err;
669                                                 next;
670                                         }
671                                         my $ref = bless decode_json($data), __PACKAGE__;
672                                         my $t = $ref->{lastin} || 0;
673                                         if ($ref->{sort} eq 'U' && !$ref->{priv} && $main::systime > $t + $tooold) {
674                                                 unless ($ref->{lat} && $ref->{long} || $ref->{qth} || $ref->{qra}) {
675                                                         LogDbg('DXCommand', "$ref->{call} deleted, too old");
676                                                         _delete($call);
677                                                         $del++;
678                                                         next;
679                                                 }
680                                         }
681         
682                                         # only store users that are reasonably active or have useful information
683                                         print $fh "$call\t" . $ref->asc_encode($basic_info_only) . "\n";
684                                         ++$count;
685                                 }
686                         } else {
687                                 dbg(carp($dbh->errstr));
688                         }
689                 } else {
690                         my $key = 0;
691                         my $val = undef;
692                         my $action;
693                         for ($action = DB_File::R_FIRST(); !$dbm->seq($key, $val, $action); $action = DB_File::R_NEXT()) {
694                                 if (!is_callsign($key) || $key =~ /^0/) {
695                                         my $eval = $val;
696                                         my $ekey = $key;
697                                         $eval =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg; 
698                                         $ekey =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg; 
699                                         LogDbg('DXCommand', "Export Error1: $ekey\t$eval");
700                                         eval {$dbm->del($key)};
701                                         dbg(carp("Export Error1: $ekey\t$eval\n$@")) if $@;
702                                         ++$err;
703                                         next;
704                                 }
705                                 my $ref = decode($val);
706                                 if ($ref) {
707                                         my $t = $ref->{lastin} || 0;
708                                         if ($ref->{sort} eq 'U' && !$ref->{priv} && $main::systime > $t + $tooold) {
709                                                 unless ($ref->{lat} && $ref->{long} || $ref->{qth} || $ref->{qra}) {
710                                                         eval {$dbm->del($key)};
711                                                         dbg(carp("Export Error2: $key\t$val\n$@")) if $@;
712                                                         LogDbg('DXCommand', "$ref->{call} deleted, too old");
713                                                         $del++;
714                                                         next;
715                                                 }
716                                         }
717                                         # only store users that are reasonably active or have useful information
718                                         print $fh "$key\t" . $ref->asc_encode($basic_info_only) . "\n";
719                                         ++$count;
720                                 } else {
721                                         LogDbg('DXCommand', "Export Error3: $key\t$val");
722                                         eval {$dbm->del($key)};
723                                         dbg(carp("Export Error3: $key\t$val\n$@")) if $@;
724                                         ++$err;
725                                 }
726                         } 
727                 }
728         $fh->close;
729     } 
730         return "$count Users $del Deleted $err Errors ('sh/log Export' for details)";
731 }
732
733 #
734 # group handling
735 #
736
737 # add one or more groups
738 sub add_group
739 {
740         my $self = shift;
741         my $ref = $self->{group} || [ 'local' ];
742         $self->{group} = $ref if !$self->{group};
743         push @$ref, @_ if @_;
744 }
745
746 # remove one or more groups
747 sub del_group
748 {
749         my $self = shift;
750         my $ref = $self->{group} || [ 'local' ];
751         my @in = @_;
752         
753         $self->{group} = $ref if !$self->{group};
754         
755         @$ref = map { my $a = $_; return (grep { $_ eq $a } @in) ? () : $a } @$ref;
756 }
757
758 # does this thing contain all the groups listed?
759 sub union
760 {
761         my $self = shift;
762         my $ref = $self->{group};
763         my $n;
764         
765         return 0 if !$ref || @_ == 0;
766         return 1 if @$ref == 0 && @_ == 0;
767         for ($n = 0; $n < @_; ) {
768                 for (@$ref) {
769                         my $a = $_;
770                         $n++ if grep $_ eq $a, @_; 
771                 }
772         }
773         return $n >= @_;
774 }
775
776 # simplified group test just for one group
777 sub in_group
778 {
779         my $self = shift;
780         my $s = shift;
781         my $ref = $self->{group};
782         
783         return 0 if !$ref;
784         return grep $_ eq $s, $ref;
785 }
786
787 # set up a default group (only happens for them's that connect direct)
788 sub new_group
789 {
790         my $self = shift;
791         $self->{group} = [ 'local' ];
792 }
793
794 # set up empty buddies (only happens for them's that connect direct)
795 sub new_buddies
796 {
797         my $self = shift;
798         $self->{buddies} = [  ];
799 }
800
801 #
802 # return a prompt for a field
803 #
804
805 sub field_prompt
806
807         my ($self, $ele) = @_;
808         return $valid{$ele};
809 }
810
811 # some variable accessors
812 sub sort
813 {
814         my $self = shift;
815         @_ ? $self->{'sort'} = shift : $self->{'sort'} ;
816 }
817
818 # some accessors
819
820 # want is default = 1
821 sub _want
822 {
823         my $n = shift;
824         my $self = shift;
825         my $val = shift;
826         my $s = "want$n";
827         $self->{$s} = $val if defined $val;
828         return exists $self->{$s} ? $self->{$s} : 1;
829 }
830
831 # wantnot is default = 0
832 sub _wantnot
833 {
834         my $n = shift;
835         my $self = shift;
836         my $val = shift;
837         my $s = "want$n";
838         $self->{$s} = $val if defined $val;
839         return exists $self->{$s} ? $self->{$s} : 0;
840 }
841
842 sub wantbeep
843 {
844         return _want('beep', @_);
845 }
846
847 sub wantann
848 {
849         return _want('ann', @_);
850 }
851
852 sub wantwwv
853 {
854         return _want('wwv', @_);
855 }
856
857 sub wantwcy
858 {
859         return _want('wcy', @_);
860 }
861
862 sub wantecho
863 {
864         return _want('echo', @_);
865 }
866
867 sub wantwx
868 {
869         return _want('wx', @_);
870 }
871
872 sub wantdx
873 {
874         return _want('dx', @_);
875 }
876
877 sub wanttalk
878 {
879         return _want('talk', @_);
880 }
881
882 sub wantgrid
883 {
884         return _want('grid', @_);
885 }
886
887 sub wantemail
888 {
889         return _want('email', @_);
890 }
891
892 sub wantann_talk
893 {
894         return _want('ann_talk', @_);
895 }
896
897 sub wantpc16
898 {
899         return _want('pc16', @_);
900 }
901
902 sub wantsendpc16
903 {
904         return _want('sendpc16', @_);
905 }
906
907 sub wantroutepc16
908 {
909         return _want('routepc16', @_);
910 }
911
912 sub wantusstate
913 {
914         return _want('usstate', @_);
915 }
916
917 sub wantdxcq
918 {
919         return _want('dxcq', @_);
920 }
921
922 sub wantdxitu
923 {
924         return _want('dxitu', @_);
925 }
926
927 sub wantgtk
928 {
929         return _want('gtk', @_);
930 }
931
932 sub wantpc9x
933 {
934         return _want('pc9x', @_);
935 }
936
937 sub wantlogininfo
938 {
939         my $self = shift;
940         my $val = shift;
941         $self->{wantlogininfo} = $val if defined $val;
942         return $self->{wantlogininfo};
943 }
944
945 sub is_node
946 {
947         my $self = shift;
948         return $self->{sort} =~ /[ACRSX]/;
949 }
950
951 sub is_local_node
952 {
953         my $self = shift;
954         return grep $_ eq 'local_node', @{$self->{group}};
955 }
956
957 sub is_user
958 {
959         my $self = shift;
960         return $self->{sort} eq 'U';
961 }
962
963 sub is_bbs
964 {
965         my $self = shift;
966         return $self->{sort} eq 'B';
967 }
968
969 sub is_spider
970 {
971         my $self = shift;
972         return $self->{sort} eq 'S';
973 }
974
975 sub is_clx
976 {
977         my $self = shift;
978         return $self->{sort} eq 'C';
979 }
980
981 sub is_dxnet
982 {
983         my $self = shift;
984         return $self->{sort} eq 'X';
985 }
986
987 sub is_arcluster
988 {
989         my $self = shift;
990         return $self->{sort} eq 'R';
991 }
992
993 sub is_ak1a
994 {
995         my $self = shift;
996         return $self->{sort} eq 'A';
997 }
998
999 sub unset_passwd
1000 {
1001         my $self = shift;
1002         delete $self->{passwd};
1003 }
1004
1005 sub unset_passphrase
1006 {
1007         my $self = shift;
1008         delete $self->{passphrase};
1009 }
1010
1011 sub set_believe
1012 {
1013         my $self = shift;
1014         my $call = uc shift;
1015         $self->{believe} ||= [];
1016         push @{$self->{believe}}, $call unless grep $_ eq $call, @{$self->{believe}};
1017 }
1018
1019 sub unset_believe
1020 {
1021         my $self = shift;
1022         my $call = uc shift;
1023         if (exists $self->{believe}) {
1024                 $self->{believe} = [grep {$_ ne $call} @{$self->{believe}}];
1025                 delete $self->{believe} unless @{$self->{believe}};
1026         }
1027 }
1028
1029 sub believe
1030 {
1031         my $self = shift;
1032         return exists $self->{believe} ? @{$self->{believe}} : ();
1033 }
1034
1035 sub lastping
1036 {
1037         my $self = shift;
1038         my $call = shift;
1039         $self->{lastping} ||= {};
1040         $self->{lastping} = {} unless ref $self->{lastping};
1041         my $b = $self->{lastping};
1042         $b->{$call} = shift if @_;
1043         return $b->{$call};     
1044 }
1045 1;
1046 __END__
1047
1048
1049
1050
1051