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