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                   wantrbn => '0,Want RBN spots,yesno',
 153                   wantft => '0,Want FT4/8 spots,yesno',
 154                   wantcw => '0,Want (RBN) CW spots,yesno',
 155                   lastoper => '9,Last for/oper,cldatetime',
 156                   nothere => '0,Not Here Text',
 157                   registered => '9,Registered?,yesno',
 158                   prompt => '0,Required Prompt',
 159                   version => '1,Version',
 160                   build => '1,Build',
 161                   believe => '1,Believable nodes,parray',
 162                   lastping => '1,Last Ping at,ptimelist',
 163                   maxconnect => '1,Max Connections',
 164                   startt => '0,Start Time,cldatetime',
 165                   connlist => '1,Connections,parraydifft',
 166                  );
 167
 168 #no strict;
 169 sub AUTOLOAD
 170 {
 171         no strict;
 172         my $name = $AUTOLOAD;
 173
 174         return if $name =~ /::DESTROY$/;
 175         $name =~ s/^.*:://o;
 176
 177         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
 178         # this clever line of code creates a subroutine which takes over from autoload
 179         # from OO Perl - Conway
 180         *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}};
 181        goto &$AUTOLOAD;
 182 }
 183
 184 #use strict;
 185
 186 #
 187 # initialise the system
 188 #
 189 sub init
 190 {
 191         my $mode = shift;
 192
 193         my $convert = "$main::root/perl/convert-users-v3-to-v4.pl";
 194         my $export;
 195
 196         $json = JSON->new()->canonical(1);
 197         $filename = localdata("users.v4");
 198
 199         if (-e $filename || -e "$filename.n" || -e "$filename.o") {
 200                 $v4 = 1;
 201         } else {
 202 #               if (-e localdata('users.v3')) {
 203 #                       LogDbg('DXUser', "Converting " . localdata('users.v3') . " to new json version of users file, please wait");
 204 #                       if (-x $convert) {
 205 #                               system($convert);
 206 #                               ++$export;
 207 #                       }
 208 #               }
 209
 210                 die "User file $filename missing, please run $convert or copy a user_json backup from somewhere\n" unless -e "$filename.n" || -s $filename;
 211         }
 212         readinjson();
 213         copy $filename, "$filename.n" unless -e "$filename.n";
 214         export() if $export;
 215 }
 216
 217 sub del_file
 218 {
 219         # with extreme prejudice
 220         unlink "$main::data/users.v4";
 221         unlink "$main::local_data/users.v4";
 222 }
 223
 224 #
 225 # periodic processing
 226 #
 227 sub process
 228 {
 229 #       if ($main::systime > $lasttime + 15) {
 230 #               #$dbm->sync if $dbm;
 231 #               $lasttime = $main::systime;
 232 #       }
 233 }
 234
 235 #
 236 # close the system
 237 #
 238
 239 sub finish
 240 {
 241
 242         writeoutjson();
 243 }
 244
 245 #
 246 # new - create a new user
 247 #
 248
 249 sub alloc
 250 {
 251         my $pkg = shift;
 252         my $call = uc shift;
 253         my $self = bless {call => $call, 'sort'=>'U'}, $pkg;
 254         return $self;
 255 }
 256
 257 sub new
 258 {
 259         my $pkg = shift;
 260         my $call = shift;
 261         #  $call =~ s/-\d+$//o;
 262
 263         confess "can't create existing call $call in User\n!" if $u{$call};
 264
 265         my $self = $pkg->alloc($call);
 266         $u{$call} = [0, $self];
 267         $self->put;
 268         ++$newusers;
 269         ++$totusers;
 270         return $self;
 271 }
 272
 273 #
 274 # get - get an existing user - this seems to return a different reference everytime it is
 275 #       called - see below
 276 #
 277
 278 sub get
 279 {
 280         my $call = uc shift;
 281         my $nodecode = shift;
 282         my $ref = $u{$call};
 283         return undef unless $ref;
 284
 285         unless ($ref->[1]) {
 286                 $ifh->seek($ref->[0], 0);
 287                 my $l = $ifh->getline;
 288                 if ($l) {
 289                         my ($k,$s) = split /\t/, $l;
 290                         return $s if $nodecode;
 291                         my $j = json_decode($s);
 292                         if ($j) {
 293                                 $ref->[1] = $j;
 294                                 ++$cachedusers;
 295                         }
 296                 }
 297         } elsif ($nodecode) {
 298                 return json_encode($ref->[1]);
 299         }
 300         return $ref->[1];
 301 }
 302
 303 #
 304 # get an "ephemeral" reference - i.e. this will give you new temporary copy of
 305 # the call's user record, but without storing it (if it isn't already there)
 306 #
 307 # This is not as quick as get()! But it will allow safe querying of the
 308 # user file. Probably in conjunction with get_some_calls feeding it.
 309 #
 310 # NOTE: for cached records this, in effect, is a faster version of Storable's
 311 # dclone - only about 3.5 times as fast!
 312 #
 313
 314 sub get_tmp
 315 {
 316         my $call = uc shift;
 317         my $ref = $u{$call};
 318         if ($ref) {
 319                 if ($ref->[1]) {
 320                         return json_decode(json_encode($ref->[1]));
 321                 }
 322                 $ifh->seek($ref->[0], 0);
 323                 my $l = $ifh->getline;
 324                 if ($l) {
 325                         my ($k,$s) = split /\t/, $l;
 326                         my $j = json_decode($s);
 327                         return $j;
 328                 }
 329         }
 330         return undef;
 331 }
 332
 333 #
 334 # Master branch:
 335 # get an existing record either from the channel (if there is one) or from the database
 336 #
 337 # It is important to note that if you have done a get (for the channel say) and you
 338 # want access or modify that you must use this call (and you must NOT use get's all
 339 # over the place willy nilly!)
 340 #
 341 # NOTE: mojo branch with newusers system:
 342 # There is no longer any function difference between get_current()
 343 # and get() as they will always reference the same record as held in %u. This is because
 344 # there is no more (repeated) thawing of stored records from the underlying "database".
 345 #
 346 # BUT: notice the difference between this and the get_tmp() function. A get() will online an
 347 # othewise unused record, so for poking around looking for that locked out user:
 348 # MAKE SURE you use get_tmp(). It will likely still be quicker than DB_File and Storable!
 349 #
 350
 351 sub get_current
 352 {
 353         goto &get;
 354
 355 #       my $call = uc shift;
 356 #
 357 #       my $dxchan = DXChannel::get($call);
 358 #       if ($dxchan) {
 359 #               my $ref = $dxchan->user;
 360 #               return $ref if $ref && UNIVERSAL::isa($ref, 'DXUser');
 361 #
 362 #               dbg("DXUser::get_current: got invalid user ref for $call from dxchan $dxchan->{call} ". ref $ref. " ignoring");
 363 #       }
 364 #       return get($call);
 365 }
 366
 367 #
 368 # get all callsigns in the database
 369 #
 370
 371 sub get_all_calls
 372 {
 373         return (sort keys %u);
 374 }
 375
 376 #
 377 # get some calls - provide a qr// style selector string as a partial key
 378 #
 379
 380 sub get_some_calls
 381 {
 382         my $pattern = shift || qr/.*/;
 383         return sort grep {$pattern} keys %u;
 384 }
 385
 386 #
 387 # if I understand the term correctly, this is a sort of monad.
 388 #
 389 # Scan through the whole user file and select records that you want
 390 # to process further. This routine returns lines of json, yu
 391 #
 392 # the CODE ref should look like:
 393 # sub {
 394 #   my $key = shift;
 395 #       my $line = shift;
 396 #   # maybe do a rough check to see if this is a likely candidate
 397 #   return unless $line =~ /something/;
 398 #   my $r = json_decode($l);
 399 #       return (condition ? wanted thing : ());
 400 # }
 401 #
 402
 403 sub scan
 404 {
 405         my $c = shift;
 406         my @out;
 407
 408         if (ref($c) eq 'CODE') {
 409                 foreach my $k (get_all_calls()) {
 410                         my $l = get($k, 1);     # get the offline json line or the jsoned online version
 411                         push @out, $c->($k, $l) if $l;
 412                 }
 413         } else {
 414                 dbg("DXUser::scan supplied argument is not a code ref");
 415         }
 416         return @out;
 417 }
 418
 419 #
 420 # put - put a user
 421 #
 422
 423 sub put
 424 {
 425         my $self = shift;
 426         confess "Trying to put nothing!" unless $self && ref $self;
 427         $self->{lastin} = $main::systime;
 428         ++$modusers;                            # new or existing, it's still been modified
 429 }
 430
 431 # freeze the user
 432 sub encode
 433 {
 434         goto &json_encode;
 435 }
 436
 437 # thaw the user
 438 sub decode
 439 {
 440         goto &json_decode;
 441 }
 442
 443 sub json_decode
 444 {
 445         my $s = shift;
 446     my $ref;
 447         eval { $ref = $json->decode($s) };
 448         if ($ref && !$@) {
 449         return bless $ref, 'DXUser';
 450         } else {
 451                 LogDbg('DXUser', "DXUser::json_decode: on '$s' $@");
 452         }
 453         return undef;
 454 }
 455
 456 sub json_encode
 457 {
 458         my $ref = shift;
 459         unbless($ref);
 460     my $s = $json->encode($ref);
 461         bless $ref, 'DXUser';
 462         return $s;
 463 }
 464
 465 #
 466 # del - delete a user
 467 #
 468
 469 sub del
 470 {
 471         my $self = shift;
 472         my $call = $self->{call};
 473         ++$delusers;
 474         --$totusers;
 475         --$cachedusers if $u{$call}->[1];
 476         delete $u{$call};
 477 }
 478
 479 #
 480 # close - close down a user
 481 #
 482
 483 sub close
 484 {
 485         my $self = shift;
 486         my $startt = shift;
 487         my $ip = shift;
 488         $self->{lastin} = $main::systime;
 489         # add a record to the connect list
 490         my $ref = [$startt || $self->{startt}, $main::systime];
 491         push @$ref, $ip if $ip;
 492         push @{$self->{connlist}}, $ref;
 493         shift @{$self->{connlist}} if @{$self->{connlist}} > $maxconnlist;
 494 }
 495
 496 #
 497 # sync the database
 498 #
 499
 500 sub sync
 501 {
 502 #       $dbm->sync;
 503 }
 504
 505 #
 506 # return a list of valid elements
 507 #
 508
 509 sub fields
 510 {
 511         return keys(%valid);
 512 }
 513
 514
 515 #
 516 # export the database to an ascii file
 517 #
 518
 519 sub export
 520 {
 521         my $name = shift;
 522
 523         my $fn = $name || localdata("user_json"); # force use of local_data
 524         my $ta = [gettimeofday];
 525
 526         # save old ones
 527         move "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo";
 528         move "$fn.ooo", "$fn.oooo" if -e "$fn.ooo";
 529         move "$fn.oo", "$fn.ooo" if -e "$fn.oo";
 530         move "$fn.o", "$fn.oo" if -e "$fn.o";
 531         move "$fn", "$fn.o" if -e "$fn";
 532
 533         my $json = JSON->new;
 534         $json->canonical(1);;
 535
 536         my $count = 0;
 537         my $err = 0;
 538         my $del = 0;
 539         my $fh = new IO::File ">$fn" or return "cannot open $fn ($!)";
 540         if ($fh) {
 541                 my $key = 0;
 542                 my $val = undef;
 543                 foreach my $k (sort keys %u) {
 544                         my $r = get($k);
 545                         if ($r->{sort} eq 'U' && !$r->{priv} && $main::systime > $r->{lastin}+$tooold ) {
 546                                 unless ($r->{lat} || $r->{long} || $r->{qra} || $r->{qth} || $r->{name}) {
 547                                         LogDbg('export', "DXUser::export deleting $k - too old, last in " . cldatetime($r->lastin) . " " . difft([$r->lastin, $main::systime]));
 548                                         delete $u{$k};
 549                                         ++$del;
 550                                         next;
 551                                 }
 552                         }
 553                         eval {$val = json_encode($r);};
 554                         if ($@) {
 555                                 LogDbg('export', "DXUser::export error encoding call: $k $@");
 556                                 ++$err;
 557                                 next;
 558                         }
 559                         $fh->print("$k\t$val\n");
 560                         ++$count;
 561                 }
 562         $fh->close;
 563     }
 564         my $t = _diffms($ta);
 565         my $s = qq{Exported users to $fn - $count Users $del Deleted $err Errors in $t mS ('sh/log Export' for details)};
 566         LogDbg('DXUser', $s);
 567         return $s;
 568 }
 569
 570 #
 571 # group handling
 572 #
 573
 574 # add one or more groups
 575 sub add_group
 576 {
 577         my $self = shift;
 578         my $ref = $self->{group} || [ 'local' ];
 579         $self->{group} = $ref if !$self->{group};
 580         push @$ref, @_ if @_;
 581 }
 582
 583 # remove one or more groups
 584 sub del_group
 585 {
 586         my $self = shift;
 587         my $ref = $self->{group} || [ 'local' ];
 588         my @in = @_;
 589
 590         $self->{group} = $ref if !$self->{group};
 591
 592         @$ref = map { my $a = $_; return (grep { $_ eq $a } @in) ? () : $a } @$ref;
 593 }
 594
 595 # does this thing contain all the groups listed?
 596 sub union
 597 {
 598         my $self = shift;
 599         my $ref = $self->{group};
 600         my $n;
 601
 602         return 0 if !$ref || @_ == 0;
 603         return 1 if @$ref == 0 && @_ == 0;
 604         for ($n = 0; $n < @_; ) {
 605                 for (@$ref) {
 606                         my $a = $_;
 607                         $n++ if grep $_ eq $a, @_;
 608                 }
 609         }
 610         return $n >= @_;
 611 }
 612
 613 # simplified group test just for one group
 614 sub in_group
 615 {
 616         my $self = shift;
 617         my $s = shift;
 618         my $ref = $self->{group};
 619
 620         return 0 if !$ref;
 621         return grep $_ eq $s, $ref;
 622 }
 623
 624 # set up a default group (only happens for them's that connect direct)
 625 sub new_group
 626 {
 627         my $self = shift;
 628         $self->{group} = [ 'local' ];
 629 }
 630
 631 # set up empty buddies (only happens for them's that connect direct)
 632 sub new_buddies
 633 {
 634         my $self = shift;
 635         $self->{buddies} = [  ];
 636 }
 637
 638 #
 639 # return a prompt for a field
 640 #
 641
 642 sub field_prompt
 643 {
 644         my ($self, $ele) = @_;
 645         return $valid{$ele};
 646 }
 647
 648 # some variable accessors
 649 sub sort
 650 {
 651         my $self = shift;
 652         @_ ? $self->{'sort'} = shift : $self->{'sort'} ;
 653 }
 654
 655 # some accessors
 656
 657 # want is default = 1
 658 sub _want
 659 {
 660         my $n = shift;
 661         my $self = shift;
 662         my $val = shift;
 663         my $s = "want$n";
 664         $self->{$s} = $val if defined $val;
 665         return exists $self->{$s} ? $self->{$s} : 1;
 666 }
 667
 668 # wantnot is default = 0
 669 sub _wantnot
 670 {
 671         my $n = shift;
 672         my $self = shift;
 673         my $val = shift;
 674         my $s = "want$n";
 675         $self->{$s} = $val if defined $val;
 676         return exists $self->{$s} ? $self->{$s} : 0;
 677 }
 678
 679 sub wantbeep
 680 {
 681         return _want('beep', @_);
 682 }
 683
 684 sub wantann
 685 {
 686         return _want('ann', @_);
 687 }
 688
 689 sub wantwwv
 690 {
 691         return _want('wwv', @_);
 692 }
 693
 694 sub wantwcy
 695 {
 696         return _want('wcy', @_);
 697 }
 698
 699 sub wantecho
 700 {
 701         return _want('echo', @_);
 702 }
 703
 704 sub wantwx
 705 {
 706         return _want('wx', @_);
 707 }
 708
 709 sub wantdx
 710 {
 711         return _want('dx', @_);
 712 }
 713
 714 sub wanttalk
 715 {
 716         return _want('talk', @_);
 717 }
 718
 719 sub wantgrid
 720 {
 721         return _want('grid', @_);
 722 }
 723
 724 sub wantemail
 725 {
 726         return _want('email', @_);
 727 }
 728
 729 sub wantann_talk
 730 {
 731         return _want('ann_talk', @_);
 732 }
 733
 734 sub wantpc16
 735 {
 736         return _want('pc16', @_);
 737 }
 738
 739 sub wantsendpc16
 740 {
 741         return _want('sendpc16', @_);
 742 }
 743
 744 sub wantroutepc16
 745 {
 746         return _want('routepc16', @_);
 747 }
 748
 749 sub wantusstate
 750 {
 751         return _want('usstate', @_);
 752 }
 753
 754 sub wantdxcq
 755 {
 756         return _want('dxcq', @_);
 757 }
 758
 759 sub wantdxitu
 760 {
 761         return _want('dxitu', @_);
 762 }
 763
 764 sub wantgtk
 765 {
 766         return _want('gtk', @_);
 767 }
 768
 769 sub wantpc9x
 770 {
 771         return _want('pc9x', @_);
 772 }
 773
 774 sub wantlogininfo
 775 {
 776         my $self = shift;
 777         my $val = shift;
 778         $self->{wantlogininfo} = $val if defined $val;
 779         return $self->{wantlogininfo};
 780 }
 781
 782 sub is_node
 783 {
 784         my $self = shift;
 785         return $self->{sort} =~ /^[ACRSX]$/;
 786 }
 787
 788 sub is_local_node
 789 {
 790         my $self = shift;
 791         return grep $_ eq 'local_node', @{$self->{group}};
 792 }
 793
 794 sub is_user
 795 {
 796         my $self = shift;
 797         return $self->{sort} =~ /^[UW]$/;
 798 }
 799
 800 sub is_web
 801 {
 802         my $self = shift;
 803         return $self->{sort} eq 'W';
 804 }
 805
 806 sub is_bbs
 807 {
 808         my $self = shift;
 809         return $self->{sort} eq 'B';
 810 }
 811
 812 sub is_spider
 813 {
 814         my $self = shift;
 815         return $self->{sort} eq 'S';
 816 }
 817
 818 sub is_clx
 819 {
 820         my $self = shift;
 821         return $self->{sort} eq 'C';
 822 }
 823
 824 sub is_dxnet
 825 {
 826         my $self = shift;
 827         return $self->{sort} eq 'X';
 828 }
 829
 830 sub is_arcluster
 831 {
 832         my $self = shift;
 833         return $self->{sort} eq 'R';
 834 }
 835
 836 sub is_ak1a
 837 {
 838         my $self = shift;
 839         return $self->{sort} eq 'A';
 840 }
 841
 842 sub is_rbn
 843 {
 844         my $self = shift;
 845         return $self->{sort} eq 'N'
 846 }
 847
 848 sub unset_passwd
 849 {
 850         my $self = shift;
 851         delete $self->{passwd};
 852         $self->put;
 853 }
 854
 855 sub unset_passphrase
 856 {
 857         my $self = shift;
 858         delete $self->{passphrase};
 859         $self->put;
 860 }
 861
 862 sub set_believe
 863 {
 864         my $self = shift;
 865         my $call = uc shift;
 866         $self->{believe} ||= [];
 867         unless (grep $_ eq $call, @{$self->{believe}}) {
 868                 push @{$self->{believe}}, $call;
 869                 $self->put;
 870         };
 871 }
 872
 873 sub unset_believe
 874 {
 875         my $self = shift;
 876         my $call = uc shift;
 877         if (exists $self->{believe}) {
 878                 $self->{believe} = [grep {$_ ne $call} @{$self->{believe}}];
 879                 delete $self->{believe} unless @{$self->{believe}};
 880                 $self->put;
 881         }
 882 }
 883
 884 sub believe
 885 {
 886         my $self = shift;
 887         return exists $self->{believe} ? @{$self->{believe}} : ();
 888 }
 889
 890 sub lastping
 891 {
 892         my $self = shift;
 893         my $call = shift;
 894         $self->{lastping} ||= {};
 895         $self->{lastping} = {} unless ref $self->{lastping};
 896         my $b = $self->{lastping};
 897         $b->{$call} = shift if @_;
 898         return $b->{$call};
 899 }
 900
 901 #
 902 # read in the latest version of the user file. As this file is immutable, the file one really wants is
 903 # a later (generated) copy. But, if the plain users.v4 file is all we have, we'll use that.
 904 #
 905
 906 sub readinjson
 907 {
 908         my $fn = $filename;
 909         my $nfn = "$fn.n";
 910         my $ofn = "$fn.o";
 911
 912         my $ta = [gettimeofday];
 913         my $count = 0;
 914         my $s;
 915         my $err = 0;
 916
 917         if (-e $nfn && -e $fn && (stat($nfn))[9] > (stat($fn))[9]) {
 918                 # move the old file to .o
 919                 unlink $ofn;
 920                 move($fn, $ofn);
 921                 move($nfn, $fn);
 922         };
 923
 924         # 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
 925         unless (-e $fn) {
 926                 move($nfn, $fn) unless -e $fn;  # the users.v4 isn't there (maybe convert-users-v3-to-v4.pl
 927                 move("$fn.json", $fn);                  # from a run of convert-users-v3-to-v4.pl
 928                 move($ofn, $fn) unless -e $fn;  # desperate now...
 929         }
 930
 931         if ($ifh) {
 932                 $ifh->seek(0, 0);
 933         } else {
 934                 LogDbg("DXUser","DXUser::readinjson: opening $fn as users file");
 935                 $ifh = IO::File->new("+<$fn") or die "Cannot open $fn ($!)";
 936         }
 937         my $pos = $ifh->tell;
 938         while (<$ifh>) {
 939                 chomp;
 940                 my @f = split /\t/;
 941                 $u{$f[0]} = [$pos];
 942                 $count++;
 943                 $pos = $ifh->tell;
 944         }
 945         $ifh->seek(0, 0);
 946
 947         # $ifh is "global" and should not be closed
 948
 949         LogDbg('DXUser',"DXUser::readinjson $count record headers read from $fn in ". _diffms($ta) . " mS");
 950         return $totusers = $count;
 951 }
 952
 953 #
 954 # Write a newer copy of the users.v4 file to users.v4.n, which is what will be read in.
 955 # This means that the existing users.v4 is not touched during a run of dxspider, or at least
 956 # not yet.
 957
 958 sub writeoutjson
 959 {
 960         my $ofn = shift || "$filename.n";
 961         my $ta = [gettimeofday];
 962
 963         my $ofh = IO::File->new(">$ofn") or die "$ofn write error $!";
 964         my $count = 0;
 965         $ifh->seek(0, 0);
 966         for my $k (sort keys %u) {
 967                 my $l = get($k, 1);
 968                 if ($l) {
 969                         chomp $l;
 970                         print $ofh "$k\t$l\n";
 971                         ++$count;
 972                 } else {
 973                         LogDbg('DXUser', "DXUser::writeoutjson callsign $k not found")
 974                 }
 975         }
 976
 977         $ofh->close;
 978         LogDbg('DXUser',"DXUser::writeoutjson $count records written to $ofn in ". _diffms($ta) . " mS");
 979         return $count;
 980 }
 981 1;
 982 __END__
 983
 984
 985
 986
 987