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