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