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