perl/DXUser.pm

   1 #
   2 # DX cluster user routines
   3 #
   4 # Copyright (c) 1998-2020 - Dirk Koopman G1TLH
   5 #
   6 # The new internal structure of the users system looks like this:
   7 #
   8 # The users.v4 file formatted as a file of lines containing: <callsign>\t{json serialised version of user record}\n
   9 #
  10 # You can look at it with any text tools or your favourite editor :-)
  11 #
  12 # In terms of internal structure, the main user hash remains as %u, keyed on callsign as before.
  13 #
  14 # The value is a one or two element array [position] or [position, ref], depending on whether the record has been "get()ed"
  15 # [i.e. got from disk] or not. The 'position' is simply the start of each line in the file. The function "get()" simply returns
  16 # the stored reference in array[1], if present, or seeks to the  position from array[0], reads a line, json_decodes it,
  17 # stores that reference into array[1] and returns that. That reference will be used from that time onwards.
  18 #
  19 # The routine writeoutjson() will (very) lazily write out a copy of %u WITHOUT STORING ANY EXTRA CURRENTLY UNREFERENCED CALLSIGN
  20 # records to users.v4.n. It, in effect, does a sort of random accessed merge of the current user file and any "in memory"
  21 # versions of any user record. This can be done with a spawned command because it will just be reading %u and merging
  22 # loaded records, not altering the current users.v4 file in any way.
  23 #
  24 # %u -> $u{call} -> [position of json line in users.v4 (, reference -> {call=>'G1TLH', ...} if this record is in use)].
  25 #
  26 # On my machine, it takes about 250mS to read the entire users.v4 file of 190,000 records and to create a
  27 # $u{callsign}->[record position in users.v4] for every callsign in the users.v4 file. Loading ~19,000 records
  28 # (read from disk, decode json, store reference) takes about 110mS (or 580nS/record).
  29 #
  30 # A periodic dump of users.v4.n, with said ~19,000 records in memory takes about 750mS to write (this can be speeded up,
  31 # by at least a half, if it becomes a problem!). As this periodic dump will be spawned off, it will not interrupt the data
  32 # stream.
  33 #
  34 # This is the first rewrite of DXUsers since inception. In the mojo branch we will no longer use Storable but use JSON instead.
  35 # We will now be storing all the keys in memory and will use opportunistic loading of actual records in "get()". So out of
  36 # say 200,000 known users it is unlikely that we will have more than 10% (more likely less) of the user records in memory.
  37 # This will mean that there will be a increase in memory requirement, but it is modest. I estimate it's unlikely be more
  38 # than 30 or so MB.
  39 #
  40 # At the moment that means that the working users.v4 is "immutable".
  41 #
  42 # In normal operation, when first calling 'init()', the keys and positions will be read from the newer of users.v4.n and
  43 # users.v4. If there is no users.v4.n, then users.v4 will be used. As time wears on, %u will then accrete active user records.
  44 # Once an hour the current %u will be saved to users.v4.n.
  45 #
  46 # If it becomes too much of a problem then we are likely to chuck off "close()d" users onto the end of the current users.v4
  47 # leaving existing users intact, but updating the pointer to the (now cleared out) user ref to the new location. This will
  48 # be a sort of write behind log file. The users.v4 file is still immutable for the starting positions, but any chucked off
  49 # records (or even "updates") will be written to the end of that file. If this has to be reread at any time, then the last
  50 # entry for any callsign "wins". But this will only happen if I think the memory requirements over time become too much.
  51 #
  52 # As there is no functional difference between the users.v4 and export_user generated "user_json" file(s), other than the latter
  53 # will be in sorted order with the record elements in "canonical" order. There will now longer be any code to execute to
  54 # "restore the users file". Simply copy one of the "user_json" files to users.v4, remove users.v4.n and restart.
  55 #
  56 # Hopefully though, this will put to rest the need to do all that messing about ever again... Pigs may well be seen flying over
  57 # your node as well :-)
  58 #
  59
  60 package DXUser;
  61
  62 use DXLog;
  63 use DB_File;
  64 use Data::Dumper;
  65 use Fcntl;
  66 use IO::File;
  67 use DXUtil;
  68 use LRU;
  69 use File::Copy;
  70 use JSON;
  71 use DXDebug;
  72 use Data::Structure::Util qw(unbless);
  73 use Time::HiRes qw(gettimeofday tv_interval);
  74 use IO::File;
  75
  76 use strict;
  77
  78 use vars qw(%u  $filename %valid $lastoperinterval $lasttime $lru $lrusize $tooold $v3 $v4);
  79
  80 %u = ();
  81 $filename = undef;
  82 $lastoperinterval = 60*24*60*60;
  83 $lasttime = 0;
  84 $lrusize = 2000;
  85 $tooold = 86400 * 365 + 31;             # this marks an old user who hasn't given enough info to be useful
  86 $v3 = 0;
  87 $v4 = 0;
  88 my $json;
  89
  90 our $maxconnlist = 3;                   # remember this many connection time (duration) [start, end] pairs
  91
  92 our $newusers = 0;                                      # per execution stats
  93 our $modusers = 0;
  94 our $totusers = 0;
  95 our $delusers = 0;
  96 our $cachedusers = 0;
  97
  98 my $ifh;                                                # the input file, initialised by readinjson()
  99
 100
 101 # hash of valid elements and a simple prompt
 102 %valid = (
 103                   call => '0,Callsign',
 104                   alias => '0,Real Callsign',
 105                   name => '0,Name',
 106                   qth => '0,Home QTH',
 107                   lat => '0,Latitude,slat',
 108                   long => '0,Longitude,slong',
 109                   qra => '0,Locator',
 110                   email => '0,E-mail Address,parray',
 111                   priv => '9,Privilege Level',
 112                   lastin => '0,Last Time in,cldatetime',
 113                   passwd => '9,Password,yesno',
 114                   passphrase => '9,Pass Phrase,yesno',
 115                   addr => '0,Full Address',
 116                   'sort' => '0,Type of User', # A - ak1a, U - User, S - spider cluster, B - BBS
 117                   xpert => '0,Expert Status,yesno',
 118                   bbs => '0,Home BBS',
 119                   node => '0,Last Node',
 120                   homenode => '0,Home Node',
 121                   lockout => '9,Locked out?,yesno',     # won't let them in at all
 122                   dxok => '9,Accept DX Spots?,yesno', # accept his dx spots?
 123                   annok => '9,Accept Announces?,yesno', # accept his announces?
 124                   lang => '0,Language',
 125                   hmsgno => '0,Highest Msgno',
 126                   group => '0,Group,parray',    # used to create a group of users/nodes for some purpose or other
 127                   buddies => '0,Buddies,parray',
 128                   isolate => '9,Isolate network,yesno',
 129                   wantbeep => '0,Req Beep,yesno',
 130                   wantann => '0,Req Announce,yesno',
 131                   wantwwv => '0,Req WWV,yesno',
 132                   wantwcy => '0,Req WCY,yesno',
 133                   wantecho => '0,Req Echo,yesno',
 134                   wanttalk => '0,Req Talk,yesno',
 135                   wantwx => '0,Req WX,yesno',
 136                   wantdx => '0,Req DX Spots,yesno',
 137                   wantemail => '0,Req Msgs as Email,yesno',
 138                   pagelth => '0,Current Pagelth',
 139                   pingint => '9,Node Ping interval',
 140                   nopings => '9,Ping Obs Count',
 141                   wantlogininfo => '0,Login Info Req,yesno',
 142           wantgrid => '0,Show DX Grid,yesno',
 143                   wantann_talk => '0,Talklike Anns,yesno',
 144                   wantpc16 => '9,Want Users from node,yesno',
 145                   wantsendpc16 => '9,Send PC16,yesno',
 146                   wantroutepc19 => '9,Route PC19,yesno',
 147                   wantusstate => '0,Show US State,yesno',
 148                   wantdxcq => '0,Show CQ Zone,yesno',
 149                   wantdxitu => '0,Show ITU Zone,yesno',
 150                   wantgtk => '0,Want GTK interface,yesno',
 151                   wantpc9x => '0,Want PC9X interface,yesno',
 152                   lastoper => '9,Last for/oper,cldatetime',
 153                   nothere => '0,Not Here Text',
 154                   registered => '9,Registered?,yesno',
 155                   prompt => '0,Required Prompt',
 156                   version => '1,Version',
 157                   build => '1,Build',
 158                   believe => '1,Believable nodes,parray',
 159                   lastping => '1,Last Ping at,ptimelist',
 160                   maxconnect => '1,Max Connections',
 161                   startt => '0,Start Time,cldatetime',
 162                   connlist => '1,Connections,parraydifft',
 163                  );
 164
 165 #no strict;
 166 sub AUTOLOAD
 167 {
 168         no strict;
 169         my $name = $AUTOLOAD;
 170
 171         return if $name =~ /::DESTROY$/;
 172         $name =~ s/^.*:://o;
 173
 174         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
 175         # this clever line of code creates a subroutine which takes over from autoload
 176         # from OO Perl - Conway
 177         *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}};
 178        goto &$AUTOLOAD;
 179 }
 180
 181 #use strict;
 182
 183 #
 184 # initialise the system
 185 #
 186 sub init
 187 {
 188         my $mode = shift;
 189
 190         my $convert = "$main::root/perl/convert-users-v3-to-v4.pl";
 191         my $export;
 192
 193         $json = JSON->new()->canonical(1);
 194         $filename = localdata("users.v4");
 195
 196         if (-e $filename || -e "$filename.n" || -e "$filename.o") {
 197                 $v4 = 1;
 198         } else {
 199                 if (-e localdata('users.v3')) {
 200                         LogDbg('DXUser', "Converting " . localdata('users.v3') . " to new json version of users file, please wait");
 201                         if (-x $convert) {
 202                                 system($convert);
 203                                 ++$export;
 204                         }
 205                 }
 206
 207                 die "User file $filename missing, please run $convert or copy a user_json backup from somewhere\n" unless -e "$filename.n" || -s $filename;
 208         }
 209         readinjson();
 210         copy $filename, "$filename.n" unless -e "$filename.n";
 211         export() if $export;
 212 }
 213
 214 sub del_file
 215 {
 216         # with extreme prejudice
 217         unlink "$main::data/users.v4";
 218         unlink "$main::local_data/users.v4";
 219 }
 220
 221 #
 222 # periodic processing
 223 #
 224 sub process
 225 {
 226 #       if ($main::systime > $lasttime + 15) {
 227 #               #$dbm->sync if $dbm;
 228 #               $lasttime = $main::systime;
 229 #       }
 230 }
 231
 232 #
 233 # close the system
 234 #
 235
 236 sub finish
 237 {
 238
 239         writeoutjson();
 240 }
 241
 242 #
 243 # new - create a new user
 244 #
 245
 246 sub alloc
 247 {
 248         my $pkg = shift;
 249         my $call = uc shift;
 250         my $self = bless {call => $call, 'sort'=>'U'}, $pkg;
 251         return $self;
 252 }
 253
 254 sub new
 255 {
 256         my $pkg = shift;
 257         my $call = shift;
 258         #  $call =~ s/-\d+$//o;
 259
 260         confess "can't create existing call $call in User\n!" if $u{$call};
 261
 262         my $self = $pkg->alloc($call);
 263         $u{$call} = [0, $self];
 264         $self->put;
 265         ++$newusers;
 266         ++$totusers;
 267         return $self;
 268 }
 269
 270 #
 271 # get - get an existing user - this seems to return a different reference everytime it is
 272 #       called - see below
 273 #
 274
 275 sub get
 276 {
 277         my $call = uc shift;
 278         my $nodecode = shift;
 279         my $ref = $u{$call};
 280         return undef unless $ref;
 281
 282         unless ($ref->[1]) {
 283                 $ifh->seek($ref->[0], 0);
 284                 my $l = $ifh->getline;
 285                 if ($l) {
 286                         my ($k,$s) = split /\t/, $l;
 287                         return $s if $nodecode;
 288                         my $j = json_decode($s);
 289                         if ($j) {
 290                                 $ref->[1] = $j;
 291                                 ++$cachedusers;
 292                         }
 293                 }
 294         } elsif ($nodecode) {
 295                 return json_encode($ref->[1]);
 296         }
 297         return $ref->[1];
 298 }
 299
 300 #
 301 # get an "ephemeral" reference - i.e. this will give you new temporary copy of
 302 # the call's user record, but without storing it (if it isn't already there)
 303 #
 304 # This is not as quick as get()! But it will allow safe querying of the
 305 # user file. Probably in conjunction with get_some_calls feeding it.
 306 #
 307 # NOTE: for cached records this, in effect, is a faster version of Storable's
 308 # dclone - only about 3.5 times as fast!
 309 #
 310
 311 sub get_tmp
 312 {
 313         my $call = uc shift;
 314         my $ref = $u{$call};
 315         if ($ref) {
 316                 if ($ref->[1]) {
 317                         return json_decode(json_encode($ref->[1]));
 318                 }
 319                 $ifh->seek($ref->[0], 0);
 320                 my $l = $ifh->getline;
 321                 if ($l) {
 322                         my ($k,$s) = split /\t/, $l;
 323                         my $j = json_decode($s);
 324                         return $j;
 325                 }
 326         }
 327         return undef;
 328 }
 329
 330 #
 331 # Master branch:
 332 # get an existing record either from the channel (if there is one) or from the database
 333 #
 334 # It is important to note that if you have done a get (for the channel say) and you
 335 # want access or modify that you must use this call (and you must NOT use get's all
 336 # over the place willy nilly!)
 337 #
 338 # NOTE: mojo branch with newusers system:
 339 # There is no longer any function difference between get_current()
 340 # and get() as they will always reference the same record as held in %u. This is because
 341 # there is no more (repeated) thawing of stored records from the underlying "database".
 342 #
 343 # BUT: notice the difference between this and the get_tmp() function. A get() will online an
 344 # othewise unused record, so for poking around looking for that locked out user:
 345 # MAKE SURE you use get_tmp(). It will likely still be quicker than DB_File and Storable!
 346 #
 347
 348 sub get_current
 349 {
 350         goto &get;
 351
 352 #       my $call = uc shift;
 353 #
 354 #       my $dxchan = DXChannel::get($call);
 355 #       if ($dxchan) {
 356 #               my $ref = $dxchan->user;
 357 #               return $ref if $ref && UNIVERSAL::isa($ref, 'DXUser');
 358 #
 359 #               dbg("DXUser::get_current: got invalid user ref for $call from dxchan $dxchan->{call} ". ref $ref. " ignoring");
 360 #       }
 361 #       return get($call);
 362 }
 363
 364 #
 365 # get all callsigns in the database
 366 #
 367
 368 sub get_all_calls
 369 {
 370         return (sort keys %u);
 371 }
 372
 373 #
 374 # get some calls - provide a qr// style selector string as a partial key
 375 #
 376
 377 sub get_some_calls
 378 {
 379         my $pattern = shift || qr/.*/;
 380         return sort grep {$pattern} keys %u;
 381 }
 382
 383 #
 384 # if I understand the term correctly, this is a sort of monad.
 385 #
 386 # Scan through the whole user file and select records that you want
 387 # to process further. This routine returns lines of json, yu
 388 #
 389 # the CODE ref should look like:
 390 # sub {
 391 #   my $key = shift;
 392 #       my $line = shift;
 393 #   # maybe do a rough check to see if this is a likely candidate
 394 #   return unless $line =~ /something/;
 395 #   my $r = json_decode($l);
 396 #       return (condition ? wanted thing : ());
 397 # }
 398 #
 399
 400 sub scan
 401 {
 402         my $c = shift;
 403         my @out;
 404
 405         if (ref($c) eq 'CODE') {
 406                 foreach my $k (get_all_calls()) {
 407                         my $l = get($k, 1);     # get the offline json line or the jsoned online version
 408                         push @out, $c->($k, $l) if $l;
 409                 }
 410         } else {
 411                 dbg("DXUser::scan supplied argument is not a code ref");
 412         }
 413         return @out;
 414 }
 415
 416 #
 417 # put - put a user
 418 #
 419
 420 sub put
 421 {
 422         my $self = shift;
 423         confess "Trying to put nothing!" unless $self && ref $self;
 424         $self->{lastin} = $main::systime;
 425         ++$modusers;                            # new or existing, it's still been modified
 426 }
 427
 428 # freeze the user
 429 sub encode
 430 {
 431         goto &json_encode;
 432 }
 433
 434 # thaw the user
 435 sub decode
 436 {
 437         goto &json_decode;
 438 }
 439
 440 sub json_decode
 441 {
 442         my $s = shift;
 443     my $ref;
 444         eval { $ref = $json->decode($s) };
 445         if ($ref && !$@) {
 446         return bless $ref, 'DXUser';
 447         } else {
 448                 LogDbg('DXUser', "DXUser::json_decode: on '$s' $@");
 449         }
 450         return undef;
 451 }
 452
 453 sub json_encode
 454 {
 455         my $ref = shift;
 456         unbless($ref);
 457     my $s = $json->encode($ref);
 458         bless $ref, 'DXUser';
 459         return $s;
 460 }
 461
 462 #
 463 # del - delete a user
 464 #
 465
 466 sub del
 467 {
 468         my $self = shift;
 469         my $call = $self->{call};
 470         ++$delusers;
 471         --$totusers;
 472         --$cachedusers if $u{$call}->[1];
 473         delete $u{$call};
 474 }
 475
 476 #
 477 # close - close down a user
 478 #
 479
 480 sub close
 481 {
 482         my $self = shift;
 483         my $startt = shift;
 484         my $ip = shift;
 485         $self->{lastin} = $main::systime;
 486         # add a record to the connect list
 487         my $ref = [$startt || $self->{startt}, $main::systime];
 488         push @$ref, $ip if $ip;
 489         push @{$self->{connlist}}, $ref;
 490         shift @{$self->{connlist}} if @{$self->{connlist}} > $maxconnlist;
 491 }
 492
 493 #
 494 # sync the database
 495 #
 496
 497 sub sync
 498 {
 499 #       $dbm->sync;
 500 }
 501
 502 #
 503 # return a list of valid elements
 504 #
 505
 506 sub fields
 507 {
 508         return keys(%valid);
 509 }
 510
 511
 512 #
 513 # export the database to an ascii file
 514 #
 515
 516 sub export
 517 {
 518         my $name = shift;
 519
 520         my $fn = $name || localdata("user_json"); # force use of local_data
 521         my $ta = [gettimeofday];
 522
 523         # save old ones
 524         move "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo";
 525         move "$fn.ooo", "$fn.oooo" if -e "$fn.ooo";
 526         move "$fn.oo", "$fn.ooo" if -e "$fn.oo";
 527         move "$fn.o", "$fn.oo" if -e "$fn.o";
 528         move "$fn", "$fn.o" if -e "$fn";
 529
 530         my $json = JSON->new;
 531         $json->canonical(1);;
 532
 533         my $count = 0;
 534         my $err = 0;
 535         my $del = 0;
 536         my $fh = new IO::File ">$fn" or return "cannot open $fn ($!)";
 537         if ($fh) {
 538                 my $key = 0;
 539                 my $val = undef;
 540                 foreach my $k (sort keys %u) {
 541                         my $r = get($k);
 542                         if ($r->{sort} eq 'U' && !$r->{priv} && $main::systime > $r->{lastin}+$tooold ) {
 543                                 unless ($r->{lat} || $r->{long} || $r->{qra} || $r->{qth} || $r->{name}) {
 544                                         LogDbg('export', "DXUser::export deleting $k - too old, last in " . cldatetime($r->lastin) . " " . difft([$r->lastin, $main::systime]));
 545                                         delete $u{$k};
 546                                         ++$del;
 547                                         next;
 548                                 }
 549                         }
 550                         eval {$val = json_encode($r);};
 551                         if ($@) {
 552                                 LogDbg('export', "DXUser::export error encoding call: $k $@");
 553                                 ++$err;
 554                                 next;
 555                         }
 556                         $fh->print("$k\t$val\n");
 557                         ++$count;
 558                 }
 559         $fh->close;
 560     }
 561         my $t = _diffms($ta);
 562         my $s = qq{Exported users to $fn - $count Users $del Deleted $err Errors in $t mS ('sh/log Export' for details)};
 563         LogDbg('DXUser', $s);
 564         return $s;
 565 }
 566
 567 #
 568 # group handling
 569 #
 570
 571 # add one or more groups
 572 sub add_group
 573 {
 574         my $self = shift;
 575         my $ref = $self->{group} || [ 'local' ];
 576         $self->{group} = $ref if !$self->{group};
 577         push @$ref, @_ if @_;
 578 }
 579
 580 # remove one or more groups
 581 sub del_group
 582 {
 583         my $self = shift;
 584         my $ref = $self->{group} || [ 'local' ];
 585         my @in = @_;
 586
 587         $self->{group} = $ref if !$self->{group};
 588
 589         @$ref = map { my $a = $_; return (grep { $_ eq $a } @in) ? () : $a } @$ref;
 590 }
 591
 592 # does this thing contain all the groups listed?
 593 sub union
 594 {
 595         my $self = shift;
 596         my $ref = $self->{group};
 597         my $n;
 598
 599         return 0 if !$ref || @_ == 0;
 600         return 1 if @$ref == 0 && @_ == 0;
 601         for ($n = 0; $n < @_; ) {
 602                 for (@$ref) {
 603                         my $a = $_;
 604                         $n++ if grep $_ eq $a, @_;
 605                 }
 606         }
 607         return $n >= @_;
 608 }
 609
 610 # simplified group test just for one group
 611 sub in_group
 612 {
 613         my $self = shift;
 614         my $s = shift;
 615         my $ref = $self->{group};
 616
 617         return 0 if !$ref;
 618         return grep $_ eq $s, $ref;
 619 }
 620
 621 # set up a default group (only happens for them's that connect direct)
 622 sub new_group
 623 {
 624         my $self = shift;
 625         $self->{group} = [ 'local' ];
 626 }
 627
 628 # set up empty buddies (only happens for them's that connect direct)
 629 sub new_buddies
 630 {
 631         my $self = shift;
 632         $self->{buddies} = [  ];
 633 }
 634
 635 #
 636 # return a prompt for a field
 637 #
 638
 639 sub field_prompt
 640 {
 641         my ($self, $ele) = @_;
 642         return $valid{$ele};
 643 }
 644
 645 # some variable accessors
 646 sub sort
 647 {
 648         my $self = shift;
 649         @_ ? $self->{'sort'} = shift : $self->{'sort'} ;
 650 }
 651
 652 # some accessors
 653
 654 # want is default = 1
 655 sub _want
 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} : 1;
 663 }
 664
 665 # wantnot is default = 0
 666 sub _wantnot
 667 {
 668         my $n = shift;
 669         my $self = shift;
 670         my $val = shift;
 671         my $s = "want$n";
 672         $self->{$s} = $val if defined $val;
 673         return exists $self->{$s} ? $self->{$s} : 0;
 674 }
 675
 676 sub wantbeep
 677 {
 678         return _want('beep', @_);
 679 }
 680
 681 sub wantann
 682 {
 683         return _want('ann', @_);
 684 }
 685
 686 sub wantwwv
 687 {
 688         return _want('wwv', @_);
 689 }
 690
 691 sub wantwcy
 692 {
 693         return _want('wcy', @_);
 694 }
 695
 696 sub wantecho
 697 {
 698         return _want('echo', @_);
 699 }
 700
 701 sub wantwx
 702 {
 703         return _want('wx', @_);
 704 }
 705
 706 sub wantdx
 707 {
 708         return _want('dx', @_);
 709 }
 710
 711 sub wanttalk
 712 {
 713         return _want('talk', @_);
 714 }
 715
 716 sub wantgrid
 717 {
 718         return _want('grid', @_);
 719 }
 720
 721 sub wantemail
 722 {
 723         return _want('email', @_);
 724 }
 725
 726 sub wantann_talk
 727 {
 728         return _want('ann_talk', @_);
 729 }
 730
 731 sub wantpc16
 732 {
 733         return _want('pc16', @_);
 734 }
 735
 736 sub wantsendpc16
 737 {
 738         return _want('sendpc16', @_);
 739 }
 740
 741 sub wantroutepc16
 742 {
 743         return _want('routepc16', @_);
 744 }
 745
 746 sub wantusstate
 747 {
 748         return _want('usstate', @_);
 749 }
 750
 751 sub wantdxcq
 752 {
 753         return _want('dxcq', @_);
 754 }
 755
 756 sub wantdxitu
 757 {
 758         return _want('dxitu', @_);
 759 }
 760
 761 sub wantgtk
 762 {
 763         return _want('gtk', @_);
 764 }
 765
 766 sub wantpc9x
 767 {
 768         return _want('pc9x', @_);
 769 }
 770
 771 sub wantlogininfo
 772 {
 773         my $self = shift;
 774         my $val = shift;
 775         $self->{wantlogininfo} = $val if defined $val;
 776         return $self->{wantlogininfo};
 777 }
 778
 779 sub is_node
 780 {
 781         my $self = shift;
 782         return $self->{sort} =~ /^[ACRSX]$/;
 783 }
 784
 785 sub is_local_node
 786 {
 787         my $self = shift;
 788         return grep $_ eq 'local_node', @{$self->{group}};
 789 }
 790
 791 sub is_user
 792 {
 793         my $self = shift;
 794         return $self->{sort} =~ /^[UW]$/;
 795 }
 796
 797 sub is_web
 798 {
 799         my $self = shift;
 800         return $self->{sort} eq 'W';
 801 }
 802
 803 sub is_bbs
 804 {
 805         my $self = shift;
 806         return $self->{sort} eq 'B';
 807 }
 808
 809 sub is_spider
 810 {
 811         my $self = shift;
 812         return $self->{sort} eq 'S';
 813 }
 814
 815 sub is_clx
 816 {
 817         my $self = shift;
 818         return $self->{sort} eq 'C';
 819 }
 820
 821 sub is_dxnet
 822 {
 823         my $self = shift;
 824         return $self->{sort} eq 'X';
 825 }
 826
 827 sub is_arcluster
 828 {
 829         my $self = shift;
 830         return $self->{sort} eq 'R';
 831 }
 832
 833 sub is_ak1a
 834 {
 835         my $self = shift;
 836         return $self->{sort} eq 'A';
 837 }
 838
 839 sub unset_passwd
 840 {
 841         my $self = shift;
 842         delete $self->{passwd};
 843         $self->put;
 844 }
 845
 846 sub unset_passphrase
 847 {
 848         my $self = shift;
 849         delete $self->{passphrase};
 850         $self->put;
 851 }
 852
 853 sub set_believe
 854 {
 855         my $self = shift;
 856         my $call = uc shift;
 857         $self->{believe} ||= [];
 858         unless (grep $_ eq $call, @{$self->{believe}}) {
 859                 push @{$self->{believe}}, $call;
 860                 $self->put;
 861         };
 862 }
 863
 864 sub unset_believe
 865 {
 866         my $self = shift;
 867         my $call = uc shift;
 868         if (exists $self->{believe}) {
 869                 $self->{believe} = [grep {$_ ne $call} @{$self->{believe}}];
 870                 delete $self->{believe} unless @{$self->{believe}};
 871                 $self->put;
 872         }
 873 }
 874
 875 sub believe
 876 {
 877         my $self = shift;
 878         return exists $self->{believe} ? @{$self->{believe}} : ();
 879 }
 880
 881 sub lastping
 882 {
 883         my $self = shift;
 884         my $call = shift;
 885         $self->{lastping} ||= {};
 886         $self->{lastping} = {} unless ref $self->{lastping};
 887         my $b = $self->{lastping};
 888         $b->{$call} = shift if @_;
 889         return $b->{$call};
 890 }
 891
 892 #
 893 # read in the latest version of the user file. As this file is immutable, the file one really wants is
 894 # a later (generated) copy. But, if the plain users.v4 file is all we have, we'll use that.
 895 #
 896
 897 sub readinjson
 898 {
 899         my $fn = $filename;
 900         my $nfn = "$fn.n";
 901         my $ofn = "$fn.o";
 902
 903         my $ta = [gettimeofday];
 904         my $count = 0;
 905         my $s;
 906         my $err = 0;
 907
 908         if (-e $nfn && -e $fn && (stat($nfn))[9] > (stat($fn))[9]) {
 909                 # move the old file to .o
 910                 unlink $ofn;
 911                 move($fn, $ofn);
 912                 move($nfn, $fn);
 913         };
 914
 915         # if we don't have a users.v4 at this point, look for a backup users.v4.json, users.v4.n then users.v4.o
 916         unless (-e $fn) {
 917                 move($nfn, $fn) unless -e $fn;  # the users.v4 isn't there (maybe convert-users-v3-to-v4.pl
 918                 move("$fn.json", $fn);                  # from a run of convert-users-v3-to-v4.pl
 919                 move($ofn, $fn) unless -e $fn;  # desperate now...
 920         }
 921
 922         if ($ifh) {
 923                 $ifh->seek(0, 0);
 924         } else {
 925                 LogDbg("DXUser","DXUser::readinjson: opening $fn as users file");
 926                 $ifh = IO::File->new("+<$fn") or die "Cannot open $fn ($!)";
 927         }
 928         my $pos = $ifh->tell;
 929         while (<$ifh>) {
 930                 chomp;
 931                 my @f = split /\t/;
 932                 $u{$f[0]} = [$pos];
 933                 $count++;
 934                 $pos = $ifh->tell;
 935         }
 936         $ifh->seek(0, 0);
 937
 938         # $ifh is "global" and should not be closed
 939
 940         dbg("DXUser::readinjson $count record headers read from $fn in ". _diffms($ta) . " mS");
 941         return $totusers = $count;
 942 }
 943
 944 #
 945 # Write a newer copy of the users.v4 file to users.v4.n, which is what will be read in.
 946 # This means that the existing users.v4 is not touched during a run of dxspider, or at least
 947 # not yet.
 948
 949 sub writeoutjson
 950 {
 951         my $ofn = shift || "$filename.n";
 952         my $ta = [gettimeofday];
 953
 954         my $ofh = IO::File->new(">$ofn") or die "$ofn write error $!";
 955         my $count = 0;
 956         $ifh->seek(0, 0);
 957         for my $k (sort keys %u) {
 958                 my $l = get($k, 1);
 959                 if ($l) {
 960                         chomp $l;
 961                         print $ofh "$k\t$l\n";
 962                         ++$count;
 963                 } else {
 964                         LogDbg('DXUser', "DXUser::writeoutjson callsign $k not found")
 965                 }
 966         }
 967
 968         $ofh->close;
 969         dbg("DXUser::writeoutjson $count records written to $ofn in ". _diffms($ta) . " mS");
 970         return $count;
 971 }
 972 1;
 973 __END__
 974
 975
 976
 977
 978