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