perl/DXUser.pm

   1 #
   2 # DX cluster user routines
   3 #
   4 # Copyright (c) 1998 - Dirk Koopman G1TLH
   5 #
   6 #
   7 #
   8
   9 package DXUser;
  10
  11 use DXLog;
  12 use DB_File;
  13 use Data::Dumper;
  14 use Fcntl;
  15 use IO::File;
  16 use DXDebug;
  17 use DXUtil;
  18 use LRU;
  19 use File::Copy;
  20 use Data::Structure::Util qw(unbless);
  21 use Time::HiRes qw(gettimeofday tv_interval);
  22 use IO::File;
  23 use DXChannel;
  24 use DXJSON;
  25
  26 use strict;
  27
  28 use vars qw(%u $dbm $filename %valid $lastoperinterval $lasttime $lru $lrusize $tooold $veryold $v3);
  29
  30 %u = ();
  31 $dbm = undef;
  32 $filename = undef;
  33 $lastoperinterval = 60*24*60*60;
  34 $lasttime = 0;
  35 $lrusize = 5000;
  36 $tooold = 86400 * 365 * 2;              # this marks an old user who hasn't given enough info to be useful
  37 $veryold = $tooold * 6;         # Ancient default 12 years
  38 $v3 = 0;
  39 our $maxconnlist = 3;                   # remember this many connection time (duration) [start, end] pairs
  40
  41 my $json;
  42
  43 # hash of valid elements and a simple prompt
  44 %valid = (
  45                   'sort' => '0,Type of User', # A - ak1a, U - User, S - spider cluster, B - BBS
  46                   addr => '0,Full Address',
  47                   alias => '0,Real Callsign',
  48                   annok => '9,Accept Announces?,yesno', # accept his announces?
  49                   bbs => '0,Home BBS',
  50                   believe => '1,Believable nodes,parray',
  51                   buddies => '0,Buddies,parray',
  52                   build => '1,Build',
  53                   call => '0,Callsign',
  54                   clientoutput => '0,User OUT Format',
  55                   clientinput => '0,User IN Format',
  56                   connlist => '1,Connections,parraydifft',
  57                   dxok => '9,Accept DX Spots?,yesno', # accept his dx spots?
  58                   email => '0,E-mail Address,parray',
  59                   group => '0,Group,parray',    # used to create a group of users/nodes for some purpose or other
  60                   hmsgno => '0,Highest Msgno',
  61                   homenode => '0,Home Node',
  62                   isolate => '9,Isolate network,yesno',
  63                   K => '9,Seen on PC92 K,yesno',
  64                   lang => '0,Language',
  65                   lastin => '0,Last Time in,cldatetime',
  66                   lastoper => '9,Last for/oper,cldatetime',
  67                   lastping => '1,Last Ping at,ptimelist',
  68                   lastseen => '0,Last Seen,cldatetime',
  69                   lat => '0,Latitude,slat',
  70                   lockout => '9,Locked out?,yesno',     # won't let them in at all
  71                   long => '0,Longitude,slong',
  72                   maxconnect => '1,Max Connections',
  73                   name => '0,Name',
  74                   node => '0,Last Node',
  75                   nopings => '9,Ping Obs Count',
  76                   nothere => '0,Not Here Text',
  77                   pagelth => '0,Current Pagelth',
  78                   passphrase => '9,Pass Phrase,yesno',
  79                   passwd => '9,Password,yesno',
  80                   pingint => '9,Node Ping interval',
  81                   priv => '9,Privilege Level',
  82                   prompt => '0,Required Prompt',
  83                   qra => '0,Locator',
  84                   qth => '0,Home QTH',
  85                   rbnseeme => '0,RBN See Me,yesno',
  86                   registered => '9,Registered?,yesno',
  87                   startt => '0,Start Time,cldatetime',
  88                   version => '1,Version',
  89                   wantann => '0,Req Announce,yesno',
  90                   wantann_talk => '0,Talklike Anns,yesno',
  91                   wantbeacon => '0,Want RBN Beacon,yesno',
  92                   wantbeep => '0,Req Beep,yesno',
  93                   wantcw => '0,Want RBN CW,yesno',
  94                   wantdx => '0,Req DX Spots,yesno',
  95                   wantdxcq => '0,Show CQ Zone,yesno',
  96                   wantdxitu => '0,Show ITU Zone,yesno',
  97                   wantecho => '0,Req Echo,yesno',
  98                   wantemail => '0,Req Msgs as Email,yesno',
  99                   wantft => '0,Want RBN FT4/8,yesno',
 100                   wantgtk => '0,Want GTK interface,yesno',
 101                   wantlogininfo => '0,Login Info Req,yesno',
 102                   wantpc16 => '9,Want Users from node,yesno',
 103                   wantpc9x => '0,Want PC9X interface,yesno',
 104                   wantpsk => '0,Want RBN PSK,yesno',
 105                   wantrbn => '0,Want RBN spots,yesno',
 106                   wantroutepc19 => '9,Route PC19,yesno',
 107                   wantrtty => '0,Want RBN RTTY,yesno',
 108                   wantsendpc16 => '9,Send PC16,yesno',
 109                   wanttalk => '0,Req Talk,yesno',
 110                   wantusstate => '0,Show US State,yesno',
 111                   wantwcy => '0,Req WCY,yesno',
 112                   wantwwv => '0,Req WWV,yesno',
 113                   wantwx => '0,Req WX,yesno',
 114                   width => '0,Preferred Width',
 115                   xpert => '0,Expert Status,yesno',
 116           wantgrid => '0,Show DX Grid,yesno',
 117                  );
 118
 119 #no strict;
 120 sub AUTOLOAD
 121 {
 122         no strict;
 123         my $name = $AUTOLOAD;
 124
 125         return if $name =~ /::DESTROY$/;
 126         $name =~ s/^.*:://o;
 127
 128         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
 129         # this clever line of code creates a subroutine which takes over from autoload
 130         # from OO Perl - Conway
 131         *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}};
 132        goto &$AUTOLOAD;
 133 }
 134
 135 #use strict;
 136
 137 #
 138 # initialise the system
 139 #
 140 sub init
 141 {
 142         my $mode = shift;
 143
 144         $json = DXJSON->new->canonical(1);
 145         my $fn = "users";
 146         $filename = localdata("$fn.v3j");
 147         unless (-e $filename || $mode == 2 ) {
 148                 if (-e localdata("$fn.v3") || -e localdata("$fn.v2")) {
 149                         LogDbg('DXUser', "New User File version $filename does not exist, running conversion from users.v3 or v2, please wait");
 150                         system('/spider/perl/convert-users-v3-to-v3j.pl');
 151                         init(1);
 152                         export();
 153                         return;
 154                 }
 155         }
 156         if (-e $filename || $mode) {
 157                 $lru = LRU->newbase("DXUser", $lrusize);
 158                 if ($mode) {
 159                         $dbm = tie (%u, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_json?]";
 160                 } else {
 161                         $dbm = tie (%u, 'DB_File', $filename, O_RDONLY, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_json?]";
 162                 }
 163         }
 164         die "Cannot open $filename ($!)\n" unless $dbm || $mode == 2;
 165         return;
 166 }
 167
 168 # delete files with extreme prejudice
 169 sub del_file
 170 {
 171         # with extreme prejudice
 172         unlink "$main::data/users.v3j";
 173         unlink "$main::local_data/users.v3j";
 174 }
 175
 176 #
 177 # periodic processing
 178 #
 179 sub process
 180 {
 181         if ($main::systime > $lasttime + 15) {
 182                 $dbm->sync if $dbm;
 183                 $lasttime = $main::systime;
 184         }
 185 }
 186
 187 #
 188 # close the system
 189 #
 190
 191 sub finish
 192 {
 193         dbg('DXUser finished');
 194         $dbm->sync;
 195         undef $dbm;
 196         untie %u;
 197 }
 198
 199 #
 200 # new - create a new user
 201 #
 202
 203 sub alloc
 204 {
 205         my $pkg = shift;
 206         my $call = uc shift;
 207         my $self = bless {call => $call, 'sort'=>'U'}, $pkg;
 208         return $self;
 209 }
 210
 211 sub new
 212 {
 213         my $pkg = shift;
 214         my $call = shift;
 215         #  $call =~ s/-\d+$//o;
 216
 217 #       confess "can't create existing call $call in User\n!" if $u{$call};
 218
 219         my $self = $pkg->alloc($call);
 220         $self->put;
 221         return $self;
 222 }
 223
 224 #
 225 # get - get an existing user - this seems to return a different reference everytime it is
 226 #       called - see below
 227 #
 228
 229 sub get
 230 {
 231         my $call = uc shift;
 232         my $data;
 233
 234         # is it in the LRU cache?
 235         my $ref = $lru->get($call);
 236         if ($ref && ref $ref eq 'DXUser') {
 237                 return $ref;
 238         }
 239
 240         # search for it
 241         unless ($dbm->get($call, $data)) {
 242                 eval { $ref = decode($data); };
 243                 if ($ref) {
 244                         if (!UNIVERSAL::isa($ref, 'DXUser')) {
 245                                 dbg("DXUser::get: got strange answer from decode of $call". ref $ref. " ignoring");
 246                                 return undef;
 247                         }
 248                         # we have a reference and it *is* a DXUser
 249                 } else {
 250                         if ($@) {
 251                                 LogDbg('err', "DXUser::get decode error on $call '$@'");
 252                         } else {
 253                                 dbg("DXUser::get: no reference returned from decode of $call $!");
 254                         }
 255                         return undef;
 256                 }
 257                 $lru->put($call, $ref);
 258                 return $ref;
 259         }
 260         return undef;
 261 }
 262
 263 #
 264 # get an existing either from the channel (if there is one) or from the database
 265 #
 266 # It is important to note that if you have done a get (for the channel say) and you
 267 # want access or modify that you must use this call (and you must NOT use get's all
 268 # over the place willy nilly!)
 269 #
 270
 271 sub get_current
 272 {
 273         my $call = uc shift;
 274
 275         my $dxchan = DXChannel::get($call);
 276         if ($dxchan) {
 277                 my $ref = $dxchan->user;
 278                 return $ref if $ref && UNIVERSAL::isa($ref, 'DXUser');
 279
 280                 dbg("DXUser::get_current: got invalid user ref for $call from dxchan $dxchan->{call} ". ref $ref. " ignoring");
 281         }
 282         return get($call);
 283 }
 284
 285 #
 286 # get all callsigns in the database
 287 #
 288
 289 sub get_all_calls
 290 {
 291         return (sort keys %u);
 292 }
 293
 294 #
 295 # put - put a user
 296 #
 297
 298 sub put
 299 {
 300         my $self = shift;
 301         confess "Trying to put nothing!" unless $self && ref $self;
 302         my $call = $self->{call};
 303
 304         $dbm->del($call);
 305         delete $self->{annok};
 306         delete $self->{dxok};
 307         $self->{lastseen} = $main::systime;
 308         $lru->put($call, $self);
 309         my $ref = $self->encode;
 310         $dbm->put($call, $ref);
 311         DXChannel::refresh_user($call, $ref);
 312         return $ref;
 313 }
 314
 315
 316 # thaw the user
 317 sub decode
 318 {
 319         return $json->decode(shift, __PACKAGE__);
 320 }
 321
 322 # freeze the user
 323 sub encode
 324 {
 325         return $json->encode(shift);
 326 }
 327
 328
 329 #
 330 # del - delete a user
 331 #
 332
 333 sub del
 334 {
 335         my $self = shift;
 336         my $call = $self->{call};
 337         $lru->remove($call);
 338         $dbm->del($call);
 339 }
 340
 341 #
 342 # close - close down a user
 343 #
 344
 345 sub close
 346 {
 347         my $self = shift;
 348         my $startt = shift;
 349         my $ip = shift;
 350         # add a record to the connect list
 351         $self->{lastin} = $main::systime;
 352         my $ref = [$startt || $self->{startt}, $main::systime];
 353         push @$ref, $ip if $ip;
 354         push @{$self->{connlist}}, $ref;
 355         shift @{$self->{connlist}} if @{$self->{connlist}} > $maxconnlist;
 356         $self->put();
 357 }
 358
 359 #
 360 # sync the database
 361 #
 362
 363 sub sync
 364 {
 365         $dbm->sync;
 366 }
 367
 368 #
 369 # return a list of valid elements
 370 #
 371
 372 sub fields
 373 {
 374         return keys(%valid);
 375 }
 376
 377
 378 #
 379 # group handling
 380 #
 381
 382 # add one or more groups
 383 sub add_group
 384 {
 385         my $self = shift;
 386         my $ref = $self->{group} || [ 'local' ];
 387         $self->{group} = $ref if !$self->{group};
 388         push @$ref, @_ if @_;
 389 }
 390
 391 # remove one or more groups
 392 sub del_group
 393 {
 394         my $self = shift;
 395         my $ref = $self->{group} || [ 'local' ];
 396         my @in = @_;
 397
 398         $self->{group} = $ref if !$self->{group};
 399
 400         @$ref = map { my $a = $_; return (grep { $_ eq $a } @in) ? () : $a } @$ref;
 401 }
 402
 403 # does this thing contain all the groups listed?
 404 sub union
 405 {
 406         my $self = shift;
 407         my $ref = $self->{group};
 408         my $n;
 409
 410         return 0 if !$ref || @_ == 0;
 411         return 1 if @$ref == 0 && @_ == 0;
 412         for ($n = 0; $n < @_; ) {
 413                 for (@$ref) {
 414                         my $a = $_;
 415                         $n++ if grep $_ eq $a, @_;
 416                 }
 417         }
 418         return $n >= @_;
 419 }
 420
 421 # simplified group test just for one group
 422 sub in_group
 423 {
 424         my $self = shift;
 425         my $s = shift;
 426         my $ref = $self->{group};
 427
 428         return 0 if !$ref;
 429         return grep $_ eq $s, $ref;
 430 }
 431
 432 # set up a default group (only happens for them's that connect direct)
 433 sub new_group
 434 {
 435         my $self = shift;
 436         $self->{group} = [ 'local' ];
 437 }
 438
 439 # set up empty buddies (only happens for them's that connect direct)
 440 sub new_buddies
 441 {
 442         my $self = shift;
 443         $self->{buddies} = [  ];
 444 }
 445
 446 #
 447 # return a prompt for a field
 448 #
 449
 450 sub field_prompt
 451 {
 452         my ($self, $ele) = @_;
 453         return $valid{$ele};
 454 }
 455
 456 # some variable accessors
 457 sub sort
 458 {
 459         my $self = shift;
 460         @_ ? $self->{'sort'} = shift : $self->{'sort'} ;
 461 }
 462
 463 # some accessors
 464
 465 # want is default = 1
 466 sub _want
 467 {
 468         my $n = shift;
 469         my $self = shift;
 470         my $val = shift;
 471         my $s = "want$n";
 472         $self->{$s} = $val if defined $val;
 473         return exists $self->{$s} ? $self->{$s} : 1;
 474 }
 475
 476 # wantnot is default = 0
 477 sub _wantnot
 478 {
 479         my $n = shift;
 480         my $self = shift;
 481         my $val = shift;
 482         my $s = "want$n";
 483         $self->{$s} = $val if defined $val;
 484         return exists $self->{$s} ? $self->{$s} : 0;
 485 }
 486
 487 sub wantbeep
 488 {
 489         return _want('beep', @_);
 490 }
 491
 492 sub wantann
 493 {
 494         return _want('ann', @_);
 495 }
 496
 497 sub wantwwv
 498 {
 499         return _want('wwv', @_);
 500 }
 501
 502 sub wantwcy
 503 {
 504         return _want('wcy', @_);
 505 }
 506
 507 sub wantecho
 508 {
 509         return _want('echo', @_);
 510 }
 511
 512 sub wantwx
 513 {
 514         return _want('wx', @_);
 515 }
 516
 517 sub wantdx
 518 {
 519         return _want('dx', @_);
 520 }
 521
 522 sub wanttalk
 523 {
 524         return _want('talk', @_);
 525 }
 526
 527 sub wantgrid
 528 {
 529         return _wantnot('grid', @_);
 530 }
 531
 532 sub wantemail
 533 {
 534         return _want('email', @_);
 535 }
 536
 537 sub wantann_talk
 538 {
 539         return _want('ann_talk', @_);
 540 }
 541
 542 sub wantpc16
 543 {
 544         return _want('pc16', @_);
 545 }
 546
 547 sub wantsendpc16
 548 {
 549         return _want('sendpc16', @_);
 550 }
 551
 552 sub wantroutepc16
 553 {
 554         return _want('routepc16', @_);
 555 }
 556
 557 sub wantusstate
 558 {
 559         return _want('usstate', @_);
 560 }
 561
 562 sub wantdxcq
 563 {
 564         return _wantnot('dxcq', @_);
 565 }
 566
 567 sub wantdxitu
 568 {
 569         return _wantnot('dxitu', @_);
 570 }
 571
 572 sub wantgtk
 573 {
 574         return _want('gtk', @_);
 575 }
 576
 577 sub wantpc9x
 578 {
 579         return _want('pc9x', @_);
 580 }
 581
 582 sub wantlogininfo
 583 {
 584         my $self = shift;
 585         my $val = shift;
 586         $self->{wantlogininfo} = $val if defined $val;
 587         return $self->{wantlogininfo};
 588 }
 589
 590 sub is_node
 591 {
 592         my $self = shift;
 593         return $self->{sort} =~ /^[ACRSX]$/;
 594 }
 595
 596 sub is_local_node
 597 {
 598         my $self = shift;
 599         return grep $_ eq 'local_node', @{$self->{group}};
 600 }
 601
 602 sub is_user
 603 {
 604         my $self = shift;
 605         return $self->{sort} =~ /^[UW]$/;
 606 }
 607
 608 sub is_web
 609 {
 610         my $self = shift;
 611         return $self->{sort} eq 'W';
 612 }
 613
 614 sub is_bbs
 615 {
 616         my $self = shift;
 617         return $self->{sort} eq 'B';
 618 }
 619
 620 sub is_spider
 621 {
 622         my $self = shift;
 623         return $self->{sort} eq 'S';
 624 }
 625
 626 sub is_clx
 627 {
 628         my $self = shift;
 629         return $self->{sort} eq 'C';
 630 }
 631
 632 sub is_dxnet
 633 {
 634         my $self = shift;
 635         return $self->{sort} eq 'X';
 636 }
 637
 638 sub is_arcluster
 639 {
 640         my $self = shift;
 641         return $self->{sort} eq 'R';
 642 }
 643
 644 sub is_ak1a
 645 {
 646         my $self = shift;
 647         return $self->{sort} eq 'A';
 648 }
 649
 650 sub is_rbn
 651 {
 652         my $self = shift;
 653         return $self->{sort} eq 'N'
 654 }
 655
 656 sub unset_passwd
 657 {
 658         my $self = shift;
 659         delete $self->{passwd};
 660 }
 661
 662 sub unset_passphrase
 663 {
 664         my $self = shift;
 665         delete $self->{passphrase};
 666 }
 667
 668 sub set_believe
 669 {
 670         my $self = shift;
 671         my $call = uc shift;
 672         $self->{believe} ||= [];
 673         push @{$self->{believe}}, $call unless grep $_ eq $call, @{$self->{believe}};
 674 }
 675
 676 sub unset_believe
 677 {
 678         my $self = shift;
 679         my $call = uc shift;
 680         if (exists $self->{believe}) {
 681                 $self->{believe} = [grep {$_ ne $call} @{$self->{believe}}];
 682                 delete $self->{believe} unless @{$self->{believe}};
 683         }
 684 }
 685
 686 sub believe
 687 {
 688         my $self = shift;
 689         return exists $self->{believe} ? @{$self->{believe}} : ();
 690 }
 691
 692 sub lastping
 693 {
 694         my $self = shift;
 695         my $call = shift;
 696         $self->{lastping} ||= {};
 697         $self->{lastping} = {} unless ref $self->{lastping};
 698         my $b = $self->{lastping};
 699         $b->{$call} = shift if @_;
 700         return $b->{$call};
 701 }
 702
 703
 704 #
 705 # export the database to an ascii file
 706 #
 707
 708 sub export
 709 {
 710         my $name = shift || 'user_json';
 711
 712         my $fn = $name ne 'user_json' ? $name : "$main::local_data/$name";                       # force use of local
 713
 714         # save old ones
 715         copy $fn, "$fn.keep" unless -e "$fn.keep";
 716         copy "$fn.ooooo", "$fn.backstop" unless -e "$fn,backstop";
 717
 718         move "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo";
 719         move "$fn.ooo", "$fn.oooo" if -e "$fn.ooo";
 720         move "$fn.oo", "$fn.ooo" if -e "$fn.oo";
 721         move "$fn.o", "$fn.oo" if -e "$fn.o";
 722         move "$fn", "$fn.o" if -e "$fn";
 723
 724
 725         my $ta = [gettimeofday];
 726         my $count = 0;
 727         my $err = 0;
 728         my $del = 0;
 729         my $spurious = 0;
 730         my $unlocked = 0;
 731         my $old =  0;
 732         my $ancient =  0;
 733         my $nodes = 0;
 734         my $renamed = 0;
 735
 736         my %del;
 737
 738         my $fh = new IO::File ">$fn" or return "cannot open $fn ($!)";
 739         if ($fh) {
 740                 my $key = 0;
 741                 my $val = undef;
 742                 my $action;
 743                 my $t = scalar localtime;
 744                 print $fh export_preamble();
 745
 746
 747         for ($action = R_FIRST; !$dbm->seq($key, $val, $action); $action = R_NEXT) {
 748                         if (!is_callsign($key) || $key =~ /^0/) {
 749                                 my $eval = $val;
 750                                 my $ekey = $key;
 751                                 $eval =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg;
 752                                 $ekey =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg;
 753                                 LogDbg('DXCommand', "Export Error1: invalid call '$key' => '$val'");
 754
 755                                 $del{$key} = $val;
 756                                 ++$err;
 757                                 next;
 758                         }
 759                         my $ref;
 760                         eval {$ref = decode($val); };
 761                         if ($ref) {
 762                                 my $t = $ref->{lastseen} if exists $ref->{lastseen};
 763                                 $t ||= $ref->{lastin} if exists $ref->{lastin};
 764                                 $t ||= $ref->{lastoper} if exists $ref->{lastoper};
 765                                 $t //= 0;
 766
 767                                 if ($ref->is_user) {
 768                                         if (!$ref->{priv} && $main::systime > $t + $tooold) {
 769                                                 unless (($ref->{lat} && $ref->{long}) || $ref->{qth} || $ref->{name} || $ref->{qra}) {
 770                                                         LogDbg('DXCommand', sprintf("$ref->{call} deleted, empty and too Old at %s", difft($t, ' ')));
 771                                                         ++$del;
 772                                                         ++$old;
 773                                                         $del{$key} = $val;
 774                                                         next;
 775                                                 }
 776                                         }
 777                                         if ($main::systime > $t + $veryold) {
 778                                                 LogDbg('DXCommand', sprintf("$ref->{call} deleted, POSITIVELY ANCIENT at %s", difft($t, ' ')));
 779                                                 ++$del;
 780                                                 ++$ancient;
 781                                                 $del{$key} = $val;
 782                                                 next;
 783                                         }
 784                                         if (exists $ref->{lockout} && $ref->{lockout} == 1 && exists $ref->{priv} && $ref->{priv} == 1) {
 785                                                 LogDbg('DXCommand', "$ref->{call} depriv'd and unlocked");
 786                                                 $ref->{lockout} = $ref->{priv} = 0;
 787                                                 $ref->put;
 788                                                 ++$unlocked;
 789                                         }
 790                                         if ($ref->is_node && $main::systime > $t + $veryold) {
 791                                                 LogDbg('DXCommand', sprintf("NODE $ref->{call} deleted (%s) old", difft($t, ' ')));
 792                                                 ++$del;
 793                                                 ++$nodes;
 794                                                 $del{$key} = $val;
 795                                                 next;
 796                                         }
 797
 798                                         my $normcall = normalise_call($key);
 799                                         if ($normcall ne $key) {
 800                                                 # if the normalised call does not exist, create it from the duff call.
 801                                                 my $nref = DXUser::get_current($normcall);
 802                                                 unless ($nref) {
 803                                                         $ref->{call} = $normcall;
 804                                                         $ref->put;
 805                                                         LogDbg('DXCommand', "DXProt: spurious call $key normalises to $normcall renaming $key -> $normcall");
 806                                                         ++$renamed;
 807                                                 }
 808                                                 LogDbg('DXCommand', "DXProt: spurious call $key (should be $normcall), removing");
 809                                                 $del{$key} = $val;
 810                                                 ++$spurious;
 811                                                 ++$del;
 812                                                 next;
 813                                         }
 814                                 }
 815                         } else {
 816                                 LogDbg('DXCommand', "Export Error3: '$key'\t" . carp($val) ."\n$@");
 817                                 $del{$key} = $val;
 818                                 ++$err;
 819                                 next;
 820                         }
 821
 822                         # only store users that are reasonably active or have useful information
 823                         print $fh "$key\t" . encode($ref) . "\n";
 824                         ++$count;
 825                 }
 826         }
 827         $fh->close;
 828
 829         while (my ($k, $v) = each %del) {
 830                 eval {$dbm->del($k)};
 831                 LogDbg('DXCommand', "Error deleting key: $k value: $v error: $@") if $@;
 832         }
 833
 834         my $diff = _diffms($ta);
 835         my $s = qq{Exported users to $fn - $count Users,  $del Deleted ($old empty \& too old, $ancient ancient, $nodes nodes, $spurious spurious), $renamed renamed, $unlocked Unlocked, $err Errors in $diff mS ('sh/log Export' for details)};
 836         LogDbg('command', $s);
 837         return ($s);
 838 }
 839
 840 sub export_preamble
 841 {
 842         return q{#!/usr/bin/perl
 843 #
 844 # The exported userfile for a DXSpider System
 845 #
 846 # Input file: $filename
 847 #       Time: $t
 848 #
 849
 850 package main;
 851
 852 # search local then perl directories
 853 BEGIN {
 854         umask 002;
 855
 856         # root of directory tree for this system
 857         $root = "/spider";
 858         $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
 859
 860         unshift @INC, "$root/perl";     # this IS the right way round!
 861         unshift @INC, "$root/local";
 862
 863         # try to detect a lockfile (this isn't atomic but
 864         # should do for now
 865         $lockfn = "$root/local_data/cluster.lck";       # lock file name
 866         if (-e $lockfn) {
 867                 open(CLLOCK, "$lockfn") or die "Can't open Lockfile ($lockfn) $!";
 868                 my $pid = <CLLOCK>;
 869                 chomp $pid;
 870                 die "Lockfile ($lockfn) and process $pid exists - cluster must be stopped first\n" if kill 0, $pid;
 871                 close CLLOCK;
 872         }
 873 }
 874
 875 use SysVar;
 876 use DXUtil;
 877 use DXUser;
 878 use DXChannel;
 879 use JSON;
 880 use Time::HiRes qw(gettimeofday tv_interval);
 881 package DXUser;
 882
 883 our $json = JSON->new->canonical(1);
 884
 885 my $ta = [gettimeofday];
 886 our $filename = "$main::local_data/users.v3j";
 887 my $exists = -e $filename ? "OVERWRITING" : "CREATING";
 888 print "perl user_json $exists $filename\n";
 889
 890 del_file();
 891 init(2);
 892 %u = ();
 893 my $count = 0;
 894 my $err = 0;
 895
 896 while (<DATA>) {
 897         chomp;
 898         my @f = split /\t/;
 899         my $ref = decode($f[1]);
 900         if ($ref) {
 901                 $ref->put();
 902                 $count++;
 903         } else {
 904                 print "# Error: $f[0]\t$f[1]\n";
 905                 $err++
 906         }
 907 }
 908 DXUser::sync(); DXUser::finish();
 909 my $diff = _diffms($ta);
 910 print "There are $count user records and $err errors in $diff mS\n";
 911
 912 exit $err ? -1 : 0;
 913
 914 __DATA__
 915 };
 916
 917 }
 918
 919 sub recover
 920 {
 921         my $name = shift || 'recover_json';
 922
 923         my $fn = $name ne 'recover_json' ? $name : "$main::local_data/$name";                       # force use of local
 924
 925         # save old ones
 926         move "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo";
 927         move "$fn.ooo", "$fn.oooo" if -e "$fn.ooo";
 928         move "$fn.oo", "$fn.ooo" if -e "$fn.oo";
 929         move "$fn.o", "$fn.oo" if -e "$fn.o";
 930         move "$fn", "$fn.o" if -e "$fn";
 931
 932         my $ta = [gettimeofday];
 933         my $count = 0;
 934         my $errs = 0;
 935         my $total = 0;
 936
 937         my $strings = "strings $filename";
 938         my $ifh = new IO::File "$strings |" or return "cannot open input $filename ($!)";
 939         my $fh = new IO::File ">$fn" or return "cannot open output $fn ($!)";
 940         if ($ifh && $fh) {
 941                 my $key = 0;
 942                 my $val = undef;
 943                 my $action;
 944                 my $t = scalar localtime;
 945                 print $fh export_preamble();
 946
 947                 my $call;
 948                 my $l;
 949
 950                 my $last = '';
 951                 while (defined ($l = $ifh->getline)) {
 952                         next unless  $l =~ /^{"call":"[-\d\w\/]+"/;
 953                         dbg("recover: $l");
 954                         $l =~ s/[^}]+$//;
 955                         my $data = $l;
 956                         if ($data) {
 957                                 my $v;
 958
 959                                 eval{ $v = decode($data); };
 960                                 if ($@) {
 961                                         ++$errs;
 962                                         ++$total;
 963                                 } else {
 964                                         next if $data eq $last;
 965                                         print $fh  "$v->{call}\t$l\n";
 966                                         ++$count;
 967                                         ++$total;
 968                                         $last = $l;
 969                                 }
 970                         }
 971                 }
 972         }
 973         $fh->close;
 974         $ifh->close;
 975
 976         my $diff = _diffms($ta);
 977         my $s = qq{Recovered users to $fn - $count Users, $errs errors $total possible records read in $diff mS ('sh/log recover' for details)};
 978         LogDbg('command', $s);
 979         return ($s);
 980 }
 981
 982 sub END
 983 {
 984         if ($dbm) {
 985                 print "DXUser Ended\n";
 986                 finish();
 987         }
 988 }
 989
 990 1;
 991 __END__
 992
 993
 994
 995
 996