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 #       $self->put();
 478 }
 479
 480 #
 481 # sync the database
 482 #
 483
 484 sub sync
 485 {
 486 #       $dbm->sync;
 487 }
 488
 489 #
 490 # return a list of valid elements
 491 #
 492
 493 sub fields
 494 {
 495         return keys(%valid);
 496 }
 497
 498
 499 #
 500 # export the database to an ascii file
 501 #
 502
 503 sub export
 504 {
 505         my $name = shift;
 506
 507         my $fn = $name || localdata("user_json"); # force use of local_data
 508
 509         # save old ones
 510         move "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo";
 511         move "$fn.ooo", "$fn.oooo" if -e "$fn.ooo";
 512         move "$fn.oo", "$fn.ooo" if -e "$fn.oo";
 513         move "$fn.o", "$fn.oo" if -e "$fn.o";
 514         move "$fn", "$fn.o" if -e "$fn";
 515
 516         my $json = JSON->new;
 517         $json->canonical(1);
 518
 519         my $count = 0;
 520         my $err = 0;
 521         my $del = 0;
 522         my $fh = new IO::File ">$fn" or return "cannot open $fn ($!)";
 523         if ($fh) {
 524                 my $key = 0;
 525                 my $val = undef;
 526                 foreach my $k (sort keys %u) {
 527                         my $r = $u{$k};
 528                         if ($r->{sort} eq 'U' && !$r->{priv} && $main::systime > $r->{lastin}+$tooold ) {
 529                                 unless ($r->{lat} || $r->{long} || $r->{qra} || $r->{qth} || $r->{name}) {
 530                                         LogDbg('DXUser', "DXUser::export deleting $k - too old, last in " . cldatetime($r->lastin) . " " . difft([$r->lastin, $main::systime]));
 531                                         delete $u{$k};
 532                                         ++$del;
 533                                         next;
 534                                 }
 535                         }
 536                         eval {$val = json_encode($r);};
 537                         if ($@) {
 538                                 LogDbg('DXUser', "DXUser::export error encoding call: $k $@");
 539                                 ++$err;
 540                                 next;
 541                         }
 542                         $fh->print("$k\t$val\n");
 543                         ++$count;
 544                 }
 545         $fh->close;
 546     }
 547         my $s = qq{Exported users to $fn - $count Users $del Deleted $err Errors ('sh/log Export' for details)};
 548         LogDbg('DXUser', $s);
 549         return $s;
 550 }
 551
 552 #
 553 # group handling
 554 #
 555
 556 # add one or more groups
 557 sub add_group
 558 {
 559         my $self = shift;
 560         my $ref = $self->{group} || [ 'local' ];
 561         $self->{group} = $ref if !$self->{group};
 562         push @$ref, @_ if @_;
 563 }
 564
 565 # remove one or more groups
 566 sub del_group
 567 {
 568         my $self = shift;
 569         my $ref = $self->{group} || [ 'local' ];
 570         my @in = @_;
 571
 572         $self->{group} = $ref if !$self->{group};
 573
 574         @$ref = map { my $a = $_; return (grep { $_ eq $a } @in) ? () : $a } @$ref;
 575 }
 576
 577 # does this thing contain all the groups listed?
 578 sub union
 579 {
 580         my $self = shift;
 581         my $ref = $self->{group};
 582         my $n;
 583
 584         return 0 if !$ref || @_ == 0;
 585         return 1 if @$ref == 0 && @_ == 0;
 586         for ($n = 0; $n < @_; ) {
 587                 for (@$ref) {
 588                         my $a = $_;
 589                         $n++ if grep $_ eq $a, @_;
 590                 }
 591         }
 592         return $n >= @_;
 593 }
 594
 595 # simplified group test just for one group
 596 sub in_group
 597 {
 598         my $self = shift;
 599         my $s = shift;
 600         my $ref = $self->{group};
 601
 602         return 0 if !$ref;
 603         return grep $_ eq $s, $ref;
 604 }
 605
 606 # set up a default group (only happens for them's that connect direct)
 607 sub new_group
 608 {
 609         my $self = shift;
 610         $self->{group} = [ 'local' ];
 611 }
 612
 613 # set up empty buddies (only happens for them's that connect direct)
 614 sub new_buddies
 615 {
 616         my $self = shift;
 617         $self->{buddies} = [  ];
 618 }
 619
 620 #
 621 # return a prompt for a field
 622 #
 623
 624 sub field_prompt
 625 {
 626         my ($self, $ele) = @_;
 627         return $valid{$ele};
 628 }
 629
 630 # some variable accessors
 631 sub sort
 632 {
 633         my $self = shift;
 634         @_ ? $self->{'sort'} = shift : $self->{'sort'} ;
 635 }
 636
 637 # some accessors
 638
 639 # want is default = 1
 640 sub _want
 641 {
 642         my $n = shift;
 643         my $self = shift;
 644         my $val = shift;
 645         my $s = "want$n";
 646         $self->{$s} = $val if defined $val;
 647         return exists $self->{$s} ? $self->{$s} : 1;
 648 }
 649
 650 # wantnot is default = 0
 651 sub _wantnot
 652 {
 653         my $n = shift;
 654         my $self = shift;
 655         my $val = shift;
 656         my $s = "want$n";
 657         $self->{$s} = $val if defined $val;
 658         return exists $self->{$s} ? $self->{$s} : 0;
 659 }
 660
 661 sub wantbeep
 662 {
 663         return _want('beep', @_);
 664 }
 665
 666 sub wantann
 667 {
 668         return _want('ann', @_);
 669 }
 670
 671 sub wantwwv
 672 {
 673         return _want('wwv', @_);
 674 }
 675
 676 sub wantwcy
 677 {
 678         return _want('wcy', @_);
 679 }
 680
 681 sub wantecho
 682 {
 683         return _want('echo', @_);
 684 }
 685
 686 sub wantwx
 687 {
 688         return _want('wx', @_);
 689 }
 690
 691 sub wantdx
 692 {
 693         return _want('dx', @_);
 694 }
 695
 696 sub wanttalk
 697 {
 698         return _want('talk', @_);
 699 }
 700
 701 sub wantgrid
 702 {
 703         return _want('grid', @_);
 704 }
 705
 706 sub wantemail
 707 {
 708         return _want('email', @_);
 709 }
 710
 711 sub wantann_talk
 712 {
 713         return _want('ann_talk', @_);
 714 }
 715
 716 sub wantpc16
 717 {
 718         return _want('pc16', @_);
 719 }
 720
 721 sub wantsendpc16
 722 {
 723         return _want('sendpc16', @_);
 724 }
 725
 726 sub wantroutepc16
 727 {
 728         return _want('routepc16', @_);
 729 }
 730
 731 sub wantusstate
 732 {
 733         return _want('usstate', @_);
 734 }
 735
 736 sub wantdxcq
 737 {
 738         return _want('dxcq', @_);
 739 }
 740
 741 sub wantdxitu
 742 {
 743         return _want('dxitu', @_);
 744 }
 745
 746 sub wantgtk
 747 {
 748         return _want('gtk', @_);
 749 }
 750
 751 sub wantpc9x
 752 {
 753         return _want('pc9x', @_);
 754 }
 755
 756 sub wantlogininfo
 757 {
 758         my $self = shift;
 759         my $val = shift;
 760         $self->{wantlogininfo} = $val if defined $val;
 761         return $self->{wantlogininfo};
 762 }
 763
 764 sub is_node
 765 {
 766         my $self = shift;
 767         return $self->{sort} =~ /^[ACRSX]$/;
 768 }
 769
 770 sub is_local_node
 771 {
 772         my $self = shift;
 773         return grep $_ eq 'local_node', @{$self->{group}};
 774 }
 775
 776 sub is_user
 777 {
 778         my $self = shift;
 779         return $self->{sort} =~ /^[UW]$/;
 780 }
 781
 782 sub is_web
 783 {
 784         my $self = shift;
 785         return $self->{sort} eq 'W';
 786 }
 787
 788 sub is_bbs
 789 {
 790         my $self = shift;
 791         return $self->{sort} eq 'B';
 792 }
 793
 794 sub is_spider
 795 {
 796         my $self = shift;
 797         return $self->{sort} eq 'S';
 798 }
 799
 800 sub is_clx
 801 {
 802         my $self = shift;
 803         return $self->{sort} eq 'C';
 804 }
 805
 806 sub is_dxnet
 807 {
 808         my $self = shift;
 809         return $self->{sort} eq 'X';
 810 }
 811
 812 sub is_arcluster
 813 {
 814         my $self = shift;
 815         return $self->{sort} eq 'R';
 816 }
 817
 818 sub is_ak1a
 819 {
 820         my $self = shift;
 821         return $self->{sort} eq 'A';
 822 }
 823
 824 sub unset_passwd
 825 {
 826         my $self = shift;
 827         delete $self->{passwd};
 828         $self->put;
 829 }
 830
 831 sub unset_passphrase
 832 {
 833         my $self = shift;
 834         delete $self->{passphrase};
 835         $self->put;
 836 }
 837
 838 sub set_believe
 839 {
 840         my $self = shift;
 841         my $call = uc shift;
 842         $self->{believe} ||= [];
 843         unless (grep $_ eq $call, @{$self->{believe}}) {
 844                 push @{$self->{believe}}, $call;
 845                 $self->put;
 846         };
 847 }
 848
 849 sub unset_believe
 850 {
 851         my $self = shift;
 852         my $call = uc shift;
 853         if (exists $self->{believe}) {
 854                 $self->{believe} = [grep {$_ ne $call} @{$self->{believe}}];
 855                 delete $self->{believe} unless @{$self->{believe}};
 856                 $self->put;
 857         }
 858 }
 859
 860 sub believe
 861 {
 862         my $self = shift;
 863         return exists $self->{believe} ? @{$self->{believe}} : ();
 864 }
 865
 866 sub lastping
 867 {
 868         my $self = shift;
 869         my $call = shift;
 870         $self->{lastping} ||= {};
 871         $self->{lastping} = {} unless ref $self->{lastping};
 872         my $b = $self->{lastping};
 873         $b->{$call} = shift if @_;
 874         return $b->{$call};
 875 }
 876
 877 #
 878 # read in the latest version of the user file. As this file is immutable, the file one really wants is
 879 # a later (generated) copy. But, if the plain users.v4 file is all we have, we'll use that.
 880 #
 881
 882 sub readinjson
 883 {
 884         my $fn = $filename;
 885         my $nfn = "$fn.n";
 886         my $ofn = "$fn.o";
 887
 888         my $ta = [gettimeofday];
 889         my $count = 0;
 890         my $s;
 891         my $err = 0;
 892
 893         if (-e $nfn && -e $fn && (stat($nfn))[9] > (stat($fn))[9]) {
 894                 # move the old file to .o
 895                 unlink $ofn;
 896                 move($fn, $ofn);
 897                 move($nfn, $fn);
 898         };
 899
 900         # 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
 901         unless (-e $fn) {
 902                 move($nfn, $fn) unless -e $fn;  # the users.v4 isn't there (maybe convert-users-v3-to-v4.pl
 903                 move("$fn.json", $fn);                  # from a run of convert-users-v3-to-v4.pl
 904                 move($ofn, $fn) unless -e $fn;  # desperate now...
 905         }
 906
 907         if ($ifh) {
 908                 $ifh->seek(0, 0);
 909         } else {
 910                 LogDbg("DXUser","DXUser::readinjson: opening $fn as users file");
 911                 $ifh = IO::File->new("+<$fn") or die "Cannot open $fn ($!)";
 912         }
 913         my $pos = $ifh->tell;
 914         while (<$ifh>) {
 915                 chomp;
 916                 my @f = split /\t/;
 917                 $u{$f[0]} = [$pos];
 918                 $count++;
 919                 $pos = $ifh->tell;
 920         }
 921         $ifh->seek(0, 0);
 922
 923         # $ifh is "global" and should not be closed
 924
 925         dbg("DXUser::readinjson $count record headers read from $fn in ". _diffms($ta) . " mS");
 926         return $totusers = $count;
 927 }
 928
 929 #
 930 # Write a newer copy of the users.v4 file to users.v4.n, which is what will be read in.
 931 # This means that the existing users.v4 is not touched during a run of dxspider, or at least
 932 # not yet.
 933
 934 sub writeoutjson
 935 {
 936         my $ofn = shift || "$filename.n";
 937         my $ta = [gettimeofday];
 938
 939         my $ofh = IO::File->new(">$ofn") or die "$ofn write error $!";
 940         my $count = 0;
 941         $ifh->seek(0, 0);
 942         for my $k (sort keys %u) {
 943                 my $l = get($k, 1);
 944                 if ($l) {
 945                         chomp $l;
 946                         print $ofh "$k\t$l\n";
 947                         ++$count;
 948                 } else {
 949                         LogDbg('DXUser', "DXUser::writeoutjson callsign $k not found")
 950                 }
 951         }
 952
 953         $ofh->close;
 954         dbg("DXUser::writeoutjson $count records written to $ofn in ". _diffms($ta) . " mS");
 955         return $count;
 956 }
 957 1;
 958 __END__
 959
 960
 961
 962
 963