From: Dirk Koopman Date: Sun, 28 Jun 2020 14:14:44 +0000 (+0100) Subject: Merge branch 'mojo' into users.v3j X-Git-Url: http://www.dxcluster.org/gitweb/gitweb.cgi?a=commitdiff_plain;h=dd73f6f34ce7f3e142e480dfb7153611d87f509b;hp=-c;p=spider.git Merge branch 'mojo' into users.v3j Also convert QSL.pm and create_qsl.pl to JSON format. --- dd73f6f34ce7f3e142e480dfb7153611d87f509b diff --combined perl/DXUser.pm index f78c8120,0b72a680..1249b0b6 --- a/perl/DXUser.pm +++ b/perl/DXUser.pm @@@ -17,9 -17,6 +17,10 @@@ use DXDebug use DXUtil; use LRU; use File::Copy; +use Data::Structure::Util qw(unbless); +use Time::HiRes qw(gettimeofday tv_interval); +use IO::File; ++use JSON; use strict; @@@ -35,8 -32,6 +36,8 @@@ $tooold = 86400 * 365; # this marks a $v3 = 0; our $maxconnlist = 3; # remember this many connection time (duration) [start, end] pairs +my $json; + # hash of valid elements and a simple prompt %valid = ( call => '0,Callsign', @@@ -106,6 -101,7 +107,7 @@@ maxconnect => '1,Max Connections', startt => '0,Start Time,cldatetime', connlist => '1,Connections,parraydifft', + width => '0,Preferred Width' ); #no strict; @@@ -133,34 -129,73 +135,34 @@@ sub ini { my $mode = shift; - my $ufn; - my $convert; - - eval { - require Storable; - }; - + $json = JSON->new->canonical(1); my $fn = "users"; - - if ($@) { - $ufn = localdata("users.v2"); - $v3 = $convert = 0; - dbg("the module Storable appears to be missing!!"); - dbg("trying to continue in compatibility mode (this may fail)"); - dbg("please install Storable from CPAN as soon as possible"); - } else { - import Storable qw(nfreeze thaw); - - $ufn = localdata("users.v3"); - $v3 = 1; - $convert++ if -e localdata("users.v2") && !-e $ufn; + $filename = localdata("$fn.v3j"); + unless (-e $filename || $mode == 2) { + LogDbg('DXUser', "New User File version $filename does not exist, running conversion from users.v3 or v2, please wait"); + system('/spider/perl/convert-users-v3-to-v3j.pl'); + init(1); + export(); + return; } - - if ($mode) { - $dbm = tie (%u, 'DB_File', $ufn, O_CREAT|O_RDWR, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]"; - } else { - $dbm = tie (%u, 'DB_File', $ufn, O_RDONLY, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]"; - } - - die "Cannot open $ufn ($!)\n" unless $dbm; - - $lru = LRU->newbase("DXUser", $lrusize); - - # do a conversion if required - if ($dbm && $convert) { - my ($key, $val, $action, $count, $err) = ('','',0,0,0); - - my %oldu; - dbg("Converting the User File to V3 "); - dbg("This will take a while, I suggest you go and have cup of strong tea"); - my $odbm = tie (%oldu, 'DB_File', localdata("users.v2"), O_RDONLY, 0666, $DB_BTREE) or confess "can't open user file: $fn.v2 ($!) [rebuild it from user_asc?]"; - for ($action = R_FIRST; !$odbm->seq($key, $val, $action); $action = R_NEXT) { - my $ref; - eval { $ref = asc_decode($val) }; - unless ($@) { - if ($ref) { - $ref->put; - $count++; - } else { - $err++ - } - } else { - Log('err', "DXUser: error decoding $@"); - } - } - undef $odbm; - untie %oldu; - dbg("Conversion completed $count records $err errors"); + if (-e $filename || $mode == 2) { + $lru = LRU->newbase("DXUser", $lrusize); + if ($mode) { + $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?]"; + } else { + $dbm = tie (%u, 'DB_File', $filename, O_RDONLY, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_json?]"; + } } - $filename = $ufn; + die "Cannot open $filename ($!)\n" unless $dbm || $mode == 2; + return; } +# delete files with extreme prejudice sub del_file { # with extreme prejudice - unlink "$main::data/users.v3"; - unlink "$main::local_data/users.v3"; + unlink "$main::data/users.v3j"; + unlink "$main::local_data/users.v3j"; } # @@@ -303,37 -338,60 +305,37 @@@ sub pu $dbm->put($call, $ref); } -# freeze the user -sub encode -{ - goto &asc_encode unless $v3; - my $self = shift; - return nfreeze($self); -} # thaw the user sub decode { - goto &asc_decode unless $v3; - my $ref; - $ref = thaw(shift); - return $ref; + my $s = shift; + my $ref; + eval { $ref = $json->decode($s) }; + if ($ref && !$@) { + return bless $ref, 'DXUser'; + } else { + LogDbg('DXUser', "DXUser::json_decode: on '$s' $@"); + } + return undef; } -# -# create a string from a user reference (in_ascii) -# -sub asc_encode +# freeze the user +sub encode { - my $self = shift; - my $strip = shift; - my $p; - - if ($strip) { - my $ref = bless {}, ref $self; - foreach my $k (qw(qth lat long qra sort call homenode node lastoper lastin)) { - $ref->{$k} = $self->{$k} if exists $self->{$k}; - } - $ref->{name} = $self->{name} if exists $self->{name} && $self->{name} !~ /selfspot/i; - $p = dd($ref); + my $ref = shift; + unbless($ref); + my $s; + + eval {$s = $json->encode($ref) }; + if ($s && !$@) { + bless $ref, 'DXUser'; + return $s; } else { - $p = dd($self); + LogDbg('DXUser', "DXUser::json_encode $ref->{call}, $@"); } - return $p; } -# -# create a hash from a string (in ascii) -# -sub asc_decode -{ - my $s = shift; - my $ref; - $s =~ s/\%([0-9A-F][0-9A-F])/chr(hex($1))/eg; - eval '$ref = ' . $s; - if ($@) { - LogDbg('err', "DXUser::asc_decode: on '$s' $@"); - $ref = undef; - } - return $ref; -} # # del - delete a user @@@ -390,10 -448,10 +392,10 @@@ sub field sub export { - my $name = shift || 'user_asc'; + my $name = shift || 'user_json'; my $basic_info_only = shift; - my $fn = $name ne 'user_asc' ? $name : "$main::local_data/$name"; # force use of local + my $fn = $name ne 'user_json' ? $name : "$main::local_data/$name"; # force use of local # save old ones move "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo"; @@@ -402,7 -460,6 +404,7 @@@ move "$fn.o", "$fn.oo" if -e "$fn.o"; move "$fn", "$fn.o" if -e "$fn"; + my $ta = [gettimeofday]; my $count = 0; my $err = 0; my $del = 0; @@@ -446,39 -503,35 +448,39 @@@ BEGIN } use SysVar; +use DXUtil; use DXUser; +use JSON; +use Time::HiRes qw(gettimeofday tv_interval); +package DXUser; -if (@ARGV) { - $main::userfn = shift @ARGV; - print "user filename now $userfn\n"; -} +our $json = JSON->new->canonical(1); -package DXUser; +my $ta = [gettimeofday]; +our $filename = "$main::local_data/users.v3j"; +my $exists = -e $filename ? "OVERWRITING" : "CREATING"; +print "perl user_json $exists $filename\n"; del_file(); -init(1); +init(2); %u = (); my $count = 0; my $err = 0; while () { chomp; my @f = split /\t/; - my $ref = asc_decode($f[1]); + my $ref = decode($f[1]); if ($ref) { $ref->put(); $count++; - DXUser::sync() unless $count % 10000; } else { print "# Error: $f[0]\t$f[1]\n"; $err++ } } DXUser::sync(); DXUser::finish(); -print "There are $count user records and $err errors\n"; +my $diff = _diffms($ta); +print "There are $count user records and $err errors in $diff mS\n"; }; print $fh "__DATA__\n"; @@@ -487,10 -540,10 +489,10 @@@ my $eval = $val; my $ekey = $key; $eval =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg; - $ekey =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg; - LogDbg('DXCommand', "Export Error1: invalid callsign($ekey) => '$eval'"); + $ekey =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg; + LogDbg('DXCommand', "Export Error1: invalid call '$key' => '$val'"); eval {$dbm->del($key)}; - dbg(carp("Export Error1: delete call $ekey => '$eval' $@")) if $@; + dbg(carp("Export Error1: delete $key => '$val' $@")) if $@; ++$err; next; } @@@ -501,26 -554,25 +503,26 @@@ if ($ref->is_user && !$ref->{priv} && $main::systime > $t + $tooold) { unless ($ref->{lat} && $ref->{long} || $ref->{qth} || $ref->{qra}) { eval {$dbm->del($key)}; - dbg(carp("Export Error2: delete $key => '$val' $@")) if $@; + dbg(carp("Export Error2: delete '$key' => '$val' $@")) if $@; LogDbg('DXCommand', "$ref->{call} deleted, too old"); $del++; next; } } # only store users that are reasonably active or have useful information - print $fh "$key\t" . $ref->asc_encode($basic_info_only) . "\n"; + print $fh "$key\t" . encode($ref) . "\n"; ++$count; } else { - LogDbg('DXCommand', "Export Error3: $key\t" . carp($val) ."\n$@"); + LogDbg('DXCommand', "Export Error3: '$key'\t" . carp($val) ."\n$@"); eval {$dbm->del($key)}; - dbg(carp("Export Error3: $key\t$val\n$@")) if $@; + dbg(carp("Export Error3: delete '$key' => '$val' $@")) if $@; ++$err; } } $fh->close; } - my $s = qq{Exported users to $fn - $count Users $del Deleted $err Errors ('sh/log Export' for details)}; + my $diff = _diffms($ta); + my $s = qq{Exported users to $fn - $count Users $del Deleted $err Errors in $diff mS ('sh/log Export' for details)}; LogDbg('command', $s); return $s; } diff --combined perl/QSL.pm index 0df7570b,0df7570b..e303e123 --- a/perl/QSL.pm +++ b/perl/QSL.pm @@@ -8,37 -8,37 +8,33 @@@ package QSL; use strict; --use DXVars; ++use SysVar; use DXUtil; use DB_File; use DXDebug; use Prefix; ++use JSON; ++use Data::Structure::Util qw(unbless); use vars qw($qslfn $dbm $maxentries); --$qslfn = 'qsl'; ++$qslfn = 'dxqsl'; $dbm = undef; $maxentries = 50; --localdata_mv("$qslfn.v1"); ++my $json; ++ ++localdata_mv("$qslfn.v1j"); sub init { my $mode = shift; -- my $ufn = localdata("$qslfn.v1"); ++ my $ufn = localdata("$qslfn.v1j"); -- Prefix::load() unless Prefix::loaded(); ++ $json = JSON->new->canonical(1); -- eval { -- require Storable; -- }; ++ Prefix::load() unless Prefix::loaded(); -- if ($@) { -- dbg("Storable appears to be missing"); -- dbg("In order to use the QSL feature you must"); -- dbg("load Storable from CPAN"); -- return undef; -- } -- import Storable qw(nfreeze freeze thaw); ++ my %u; undef $dbm; if ($mode) { @@@ -119,7 -119,7 +115,7 @@@ sub ge my $r = $dbm->get($key, $value); return undef if $r; -- return thaw($value); ++ return decode($value); } sub put @@@ -127,8 -127,8 +123,40 @@@ return unless $dbm; my $self = shift; my $key = $self->[0]; -- my $value = nfreeze($self); ++ my $value = encode($self); $dbm->put($key, $value); } ++sub remove_files ++{ ++ unlink "$main::data/qsl.v1j"; ++ unlink "$main::local_data/qsl.v1j"; ++} ++ ++# thaw the user ++sub decode ++{ ++ my $s = shift; ++ my $ref; ++ eval { $ref = $json->decode($s) }; ++ if ($ref && !$@) { ++ return bless $ref, 'QSL'; ++ } ++ return undef; ++} ++ ++# freeze the user ++sub encode ++{ ++ my $ref = shift; ++ unbless($ref); ++ my $s; ++ ++ eval {$s = $json->encode($ref) }; ++ if ($s && !$@) { ++ bless $ref, 'QSL'; ++ return $s; ++ } ++} ++ 1; diff --combined perl/create_qsl.pl index f4083f55,f4083f55..38fccc5a --- a/perl/create_qsl.pl +++ b/perl/create_qsl.pl @@@ -32,13 -32,13 +32,11 @@@ use vars qw($end $lastyear $lastday $la $end = 0; $SIG{TERM} = $SIG{INT} = sub { $end++ }; --my $qslfn = "qsl"; ++my $qslfn = "dxqsl"; $main::systime = time; --unlink "$data/qsl.v1"; --unlink "$local_data/qsl.v1"; -- ++QSL::remove_files(); QSL::init(1) or die "cannot open QSL file"; my $base = localdata("spots");