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