]> dxcluster.org Git - spider.git/blob - perl/DXUser.pm
increase interval between auto for/opers and add up to 9 days of randomi-
[spider.git] / perl / DXUser.pm
1 #
2 # DX cluster user routines
3 #
4 # Copyright (c) 1998 - Dirk Koopman G1TLH
5 #
6 # $Id$
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
18 use strict;
19
20 use vars qw($VERSION $BRANCH);
21 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
22 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ ) || 0;
23 $main::build += $VERSION;
24 $main::branch += $BRANCH;
25
26 use vars qw(%u $dbm $filename %valid $lastoperinterval $lasttime);
27
28 %u = ();
29 $dbm = undef;
30 $filename = undef;
31 $lastoperinterval = 60*24*60*60;
32 $lasttime = 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                   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,Access Group,parray',     # used to create a group of users/nodes for some purpose or other
59                   isolate => '9,Isolate network,yesno',
60                   wantbeep => '0,Rec Beep,yesno',
61                   wantann => '0,Rec Announce,yesno',
62                   wantwwv => '0,Rec WWV,yesno',
63                   wantwcy => '0,Rec WCY,yesno',
64                   wantecho => '0,Rec Echo,yesno',
65                   wanttalk => '0,Rec Talk,yesno',
66                   wantwx => '0,Rec WX,yesno',
67                   wantdx => '0,Rec DX Spots,yesno',
68                   wantemail => '0,Rec Msgs as Email,yesno',
69                   pagelth => '0,Current Pagelth',
70                   pingint => '9,Node Ping interval',
71                   nopings => '9,Ping Obs Count',
72                   wantlogininfo => '9,Login info req,yesno',
73           wantgrid => '0,DX Grid Info,yesno',
74                   wantann_talk => '0,Talklike Anns,yesno',
75                   lastoper => '9,Last for/oper,cldatetime',
76                   nothere => '0,Not Here Text',
77                   registered => '9,Registered?,yesno',
78                   prompt => '0,Required Prompt',
79                  );
80
81 no strict;
82 sub AUTOLOAD
83 {
84         my $self = shift;
85         my $name = $AUTOLOAD;
86   
87         return if $name =~ /::DESTROY$/;
88         $name =~ s/.*:://o;
89   
90         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
91         # this clever line of code creates a subroutine which takes over from autoload
92         # from OO Perl - Conway
93         *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
94         if (@_) {
95                 $self->{$name} = shift;
96         }
97         return $self->{$name};
98 }
99
100 use strict;
101
102 #
103 # initialise the system
104 #
105 sub init
106 {
107         my ($pkg, $fn, $mode) = @_;
108   
109         confess "need a filename in User" if !$fn;
110         $fn .= ".v2";
111         if ($mode) {
112                 $dbm = tie (%u, 'DB_File', $fn, O_CREAT|O_RDWR, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!)";
113         } else {
114                 $dbm = tie (%u, 'DB_File', $fn, O_RDONLY, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!)";
115         }
116         
117         $filename = $fn;
118 }
119
120 sub del_file
121 {
122         my ($pkg, $fn) = @_;
123   
124         confess "need a filename in User" if !$fn;
125         $fn .= ".v2";
126         unlink $fn;
127 }
128
129 #
130 # periodic processing
131 #
132 sub process
133 {
134         if ($main::systime > $lasttime + 15) {
135                 $dbm->sync;
136                 $lasttime = $main::systime;
137         }
138 }
139
140 #
141 # close the system
142 #
143
144 sub finish
145 {
146         undef $dbm;
147         untie %u;
148 }
149
150 #
151 # new - create a new user
152 #
153
154 sub new
155 {
156         my $pkg = shift;
157         my $call = uc shift;
158         #  $call =~ s/-\d+$//o;
159   
160 #       confess "can't create existing call $call in User\n!" if $u{$call};
161
162         my $self = bless {}, $pkg;
163         $self->{call} = $call;
164         $self->{'sort'} = 'U';
165         $self->put;
166         return $self;
167 }
168
169 #
170 # get - get an existing user - this seems to return a different reference everytime it is
171 #       called - see below
172 #
173
174 sub get
175 {
176         my $pkg = shift;
177         my $call = uc shift;
178         my $data;
179         unless ($dbm->get($call, $data)) {
180                 return decode($data);
181         }
182         return undef;
183 }
184
185 #
186 # get an existing either from the channel (if there is one) or from the database
187 #
188 # It is important to note that if you have done a get (for the channel say) and you
189 # want access or modify that you must use this call (and you must NOT use get's all
190 # over the place willy nilly!)
191 #
192
193 sub get_current
194 {
195         my $pkg = shift;
196         my $call = uc shift;
197   
198         my $dxchan = DXChannel->get($call);
199         return $dxchan->user if $dxchan;
200         my $data;
201         unless ($dbm->get($call, $data)) {
202                 return decode($data);
203         }
204         return undef;
205 }
206
207 #
208 # get all callsigns in the database 
209 #
210
211 sub get_all_calls
212 {
213         return (sort keys %u);
214 }
215
216 #
217 # put - put a user
218 #
219
220 sub put
221 {
222         my $self = shift;
223         confess "Trying to put nothing!" unless $self && ref $self;
224         my $call = $self->{call};
225         # delete all instances of this 
226 #       for ($dbm->get_dup($call)) {
227 #               $dbm->del_dup($call, $_);
228 #       }
229         $dbm->del($call);
230         delete $self->{annok} if $self->{annok};
231         delete $self->{dxok} if $self->{dxok};
232         $dbm->put($call, $self->encode);
233 }
234
235
236 # create a string from a user reference
237 #
238 sub encode
239 {
240         my $self = shift;
241         my $dd = new Data::Dumper([$self]);
242         $dd->Indent(0);
243         $dd->Terse(1);
244     $dd->Quotekeys($] < 5.005 ? 1 : 0);
245         return $dd->Dumpxs;
246 }
247
248 #
249 # create a hash from a string
250 #
251 sub decode
252 {
253         my $s = shift;
254         my $ref;
255         eval '$ref = ' . $s;
256         if ($@) {
257                 dbg($@);
258                 Log('err', $@);
259                 $ref = undef;
260         }
261         return $ref;
262 }
263
264 #
265 # del - delete a user
266 #
267
268 sub del
269 {
270         my $self = shift;
271         my $call = $self->{call};
272         # delete all instances of this 
273 #       for ($dbm->get_dup($call)) {
274 #               $dbm->del_dup($call, $_);
275 #       }
276         $dbm->del($call);
277 }
278
279 #
280 # close - close down a user
281 #
282
283 sub close
284 {
285         my $self = shift;
286         $self->{lastin} = time;
287         $self->put();
288 }
289
290 #
291 # sync the database
292 #
293
294 sub sync
295 {
296         $dbm->sync;
297 }
298
299 #
300 # return a list of valid elements 
301
302
303 sub fields
304 {
305         return keys(%valid);
306 }
307
308
309 #
310 # export the database to an ascii file
311 #
312
313 sub export
314 {
315         my $fn = shift;
316         
317         # save old ones
318         rename "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo";
319         rename "$fn.ooo", "$fn.oooo" if -e "$fn.ooo";
320         rename "$fn.oo", "$fn.ooo" if -e "$fn.oo";
321         rename "$fn.o", "$fn.oo" if -e "$fn.o";
322         rename "$fn", "$fn.o" if -e "$fn";
323
324         my $count = 0;
325         my $fh = new IO::File ">$fn" or return "cannot open $fn ($!)";
326         if ($fh) {
327                 my $ref = 0;
328                 my $key = 0;
329                 my $action;
330                 my $t = scalar localtime;
331                 print $fh q{#!/usr/bin/perl
332 #
333 # The exported userfile for a DXSpider System
334 #
335 # Input file: $filename
336 #       Time: $t
337 #
338                         
339 package main;
340                         
341 # search local then perl directories
342 BEGIN {
343         umask 002;
344                                 
345         # root of directory tree for this system
346         $root = "/spider"; 
347         $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
348         
349         unshift @INC, "$root/perl";     # this IS the right way round!
350         unshift @INC, "$root/local";
351         
352         # try to detect a lockfile (this isn't atomic but 
353         # should do for now
354         $lockfn = "$root/perl/cluster.lck";       # lock file name
355         if (-e $lockfn) {
356                 open(CLLOCK, "$lockfn") or die "Can't open Lockfile ($lockfn) $!";
357                 my $pid = <CLLOCK>;
358                 chomp $pid;
359                 die "Lockfile ($lockfn) and process $pid exists - cluster must be stopped first\n" if kill 0, $pid;
360                 close CLLOCK;
361         }
362 }
363
364 package DXUser;
365
366 use DXVars;
367 use DXUser;
368
369 if (@ARGV) {
370         $main::userfn = shift @ARGV;
371         print "user filename now $userfn\n";
372 }
373
374 DXUser->del_file($main::userfn);
375 DXUser->init($main::userfn, 1);
376
377 %u = (
378   };
379
380         for ($action = R_FIRST; !$dbm->seq($key, $ref, $action); $action = R_NEXT) {
381                         print $fh "'$key' => q{$ref},\n";
382                         ++$count;
383                 } 
384         print $fh ");\n#\nprint \"there were $count records\\n\";\n#\n";
385         print $fh "DXUser->sync; DXUser->finish;\n#\n";
386         $fh->close;
387     } 
388         return $count;
389 }
390
391 #
392 # group handling
393 #
394
395 # add one or more groups
396 sub add_group
397 {
398         my $self = shift;
399         my $ref = $self->{group} || [ 'local' ];
400         $self->{group} = $ref if !$self->{group};
401         push @$ref, @_ if @_;
402 }
403
404 # remove one or more groups
405 sub del_group
406 {
407         my $self = shift;
408         my $ref = $self->{group} || [ 'local' ];
409         my @in = @_;
410         
411         $self->{group} = $ref if !$self->{group};
412         
413         @$ref = map { my $a = $_; return (grep { $_ eq $a } @in) ? () : $a } @$ref;
414 }
415
416 # does this thing contain all the groups listed?
417 sub union
418 {
419         my $self = shift;
420         my $ref = $self->{group};
421         my $n;
422         
423         return 0 if !$ref || @_ == 0;
424         return 1 if @$ref == 0 && @_ == 0;
425         for ($n = 0; $n < @_; ) {
426                 for (@$ref) {
427                         my $a = $_;
428                         $n++ if grep $_ eq $a, @_; 
429                 }
430         }
431         return $n >= @_;
432 }
433
434 # simplified group test just for one group
435 sub in_group
436 {
437         my $self = shift;
438         my $s = shift;
439         my $ref = $self->{group};
440         
441         return 0 if !$ref;
442         return grep $_ eq $s, $ref;
443 }
444
445 # set up a default group (only happens for them's that connect direct)
446 sub new_group
447 {
448         my $self = shift;
449         $self->{group} = [ 'local' ];
450 }
451
452 #
453 # return a prompt for a field
454 #
455
456 sub field_prompt
457
458         my ($self, $ele) = @_;
459         return $valid{$ele};
460 }
461
462 # some variable accessors
463 sub sort
464 {
465         my $self = shift;
466         @_ ? $self->{'sort'} = shift : $self->{'sort'} ;
467 }
468
469 # some accessors
470 sub _want
471 {
472         my $n = shift;
473         my $self = shift;
474         my $val = shift;
475         my $s = "want$n";
476         $self->{$s} = $val if defined $val;
477         return exists $self->{$s} ? $self->{$s} : 1;
478 }
479
480 sub wantbeep
481 {
482         return _want('beep', @_);
483 }
484
485 sub wantann
486 {
487         return _want('ann', @_);
488 }
489
490 sub wantwwv
491 {
492         return _want('wwv', @_);
493 }
494
495 sub wantwcy
496 {
497         return _want('wcy', @_);
498 }
499
500 sub wantecho
501 {
502         return _want('echo', @_);
503 }
504
505 sub wantwx
506 {
507         return _want('wx', @_);
508 }
509
510 sub wantdx
511 {
512         return _want('dx', @_);
513 }
514
515 sub wanttalk
516 {
517         return _want('talk', @_);
518 }
519
520 sub wantgrid
521 {
522         return _want('grid', @_);
523 }
524
525 sub wantemail
526 {
527         return _want('email', @_);
528 }
529
530 sub wantann_talk
531 {
532         return _want('ann_talk', @_);
533 }
534
535 sub wantlogininfo
536 {
537         my $self = shift;
538         my $val = shift;
539         $self->{wantlogininfo} = $val if defined $val;
540         return $self->{wantlogininfo};
541 }
542
543 sub is_node
544 {
545         my $self = shift;
546         return $self->{sort} =~ /[ACRSX]/;
547 }
548
549 sub is_user
550 {
551         my $self = shift;
552         return $self->{sort} eq 'U';
553 }
554
555 sub is_bbs
556 {
557         my $self = shift;
558         return $self->{sort} eq 'B';
559 }
560
561 sub is_spider
562 {
563         my $self = shift;
564         return $self->{sort} eq 'S';
565 }
566
567 sub is_clx
568 {
569         my $self = shift;
570         return $self->{sort} eq 'C';
571 }
572
573 sub is_dxnet
574 {
575         my $self = shift;
576         return $self->{sort} eq 'X';
577 }
578
579 sub is_arcluster
580 {
581         my $self = shift;
582         return $self->{sort} eq 'R';
583 }
584
585 sub is_ak1a
586 {
587         my $self = shift;
588         return $self->{sort} eq 'A';
589 }
590
591 sub unset_passwd
592 {
593         my $self = shift;
594         delete $self->{passwd};
595 }
596 1;
597 __END__
598
599
600
601
602