X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXUser.pm;h=e62123bfc1ef1a8235bb3c942b93f501db367f38;hb=d384410d4d5d1031cabab44350b80f2a55fe808d;hp=7c9a4b369e56de0f63aabe15bf242d7e1ebe31dc;hpb=985ef8460d1cd74eee9576e6d32e625fdeb6a76c;p=spider.git diff --git a/perl/DXUser.pm b/perl/DXUser.pm index 7c9a4b36..e62123bf 100644 --- a/perl/DXUser.pm +++ b/perl/DXUser.pm @@ -25,7 +25,7 @@ $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0)) $main::build += $VERSION; $main::branch += $BRANCH; -use vars qw(%u $dbm $filename %valid $lastoperinterval $lasttime $lru $lrusize $tooold); +use vars qw(%u $dbm $filename %valid $lastoperinterval $lasttime $lru $lrusize $tooold $v3); %u = (); $dbm = undef; @@ -34,6 +34,7 @@ $lastoperinterval = 60*24*60*60; $lasttime = 0; $lrusize = 2000; $tooold = 86400 * 365; # this marks an old user who hasn't given enough info to be useful +$v3 = 0; # hash of valid elements and a simple prompt %valid = ( @@ -60,7 +61,7 @@ $tooold = 86400 * 365; # this marks an old user who hasn't given enough info to annok => '9,Accept Announces?,yesno', # accept his announces? lang => '0,Language', hmsgno => '0,Highest Msgno', - group => '0,Access Group,parray', # used to create a group of users/nodes for some purpose or other + group => '0,Chat Group,parray', # used to create a group of users/nodes for some purpose or other isolate => '9,Isolate network,yesno', wantbeep => '0,Req Beep,yesno', wantann => '0,Req Announce,yesno', @@ -75,13 +76,16 @@ $tooold = 86400 * 365; # this marks an old user who hasn't given enough info to pingint => '9,Node Ping interval', nopings => '9,Ping Obs Count', wantlogininfo => '9,Login info req,yesno', - wantgrid => '0,DX Grid Info,yesno', + wantgrid => '0,Show DX Grid,yesno', wantann_talk => '0,Talklike Anns,yesno', wantpc90 => '1,Req PC90,yesno', - wantnp => '1,Req New Protocol,yesno', + wantnp => '1,Req New Proto,yesno', wantpc16 => '9,Want Users from node,yesno', wantsendpc16 => '9,Send PC16,yesno', wantroutepc19 => '9,Route PC19,yesno', + wantusstate => '0,Show US State,yesno', + wantdxcq => '0,Show CQ Zone,yesno', + wantdxitu => '0,Show ITU Zone,yesno', lastoper => '9,Last for/oper,cldatetime', nothere => '0,Not Here Text', registered => '9,Registered?,yesno', @@ -116,15 +120,60 @@ sub init my ($pkg, $fn, $mode) = @_; confess "need a filename in User" if !$fn; - $fn .= ".v2"; - if ($mode) { - $dbm = tie (%u, 'DB_File', $fn, O_CREAT|O_RDWR, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]"; + + my $ufn; + my $convert; + + eval { + require Storable; + }; + +# eval "use Storable qw(nfreeze thaw)"; + + if ($@) { + $ufn = "$fn.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 { - $dbm = tie (%u, 'DB_File', $fn, O_RDONLY, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]"; + import Storable qw(nfreeze thaw); + + $ufn = "$fn.v3"; + $v3 = 1; + $convert++ unless -e $ufn; } - $filename = $fn; + 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?]"; + } + $lru = LRU->newbase("DXUser", $lrusize); + + # do a conversion if required + if ($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', "$fn.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 = asc_decode($val); + if ($ref) { + $ref->put; + $count++; + } else { + $err++ + } + } + undef $odbm; + untie %oldu; + dbg("Conversion completed $count records $err errors"); + } + $filename = $ufn; } sub del_file @@ -132,7 +181,7 @@ sub del_file my ($pkg, $fn) = @_; confess "need a filename in User" if !$fn; - $fn .= ".v2"; + $fn .= $v3 ? ".v3" : ".v2"; unlink $fn; } @@ -250,10 +299,25 @@ sub put $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; + return thaw(shift); +} + # -# create a string from a user reference +# create a string from a user reference (in_ascii) # -sub encode +sub asc_encode { my $self = shift; my $dd = new Data::Dumper([$self]); @@ -264,9 +328,9 @@ sub encode } # -# create a hash from a string +# create a hash from a string (in ascii) # -sub decode +sub asc_decode { my $s = shift; my $ref; @@ -372,7 +436,7 @@ BEGIN { # try to detect a lockfile (this isn't atomic but # should do for now - $lockfn = "$root/perl/cluster.lck"; # lock file name + $lockfn = "$root/local/cluster.lck"; # lock file name if (-e $lockfn) { open(CLLOCK, "$lockfn") or die "Can't open Lockfile ($lockfn) $!"; my $pid = ; @@ -400,7 +464,7 @@ my $err = 0; while () { chomp; my @f = split /\t/; - my $ref = decode($f[1]); + my $ref = asc_decode($f[1]); if ($ref) { $ref->put(); $count++; @@ -435,7 +499,7 @@ print "There are $count user records and $err errors\n"; } } # only store users that are reasonably active or have useful information - print $fh "$key\t" . $ref->encode . "\n"; + print $fh "$key\t" . $ref->asc_encode . "\n"; ++$count; } else { Log('DXCommand', "Export Error3: $key\t$val"); @@ -608,6 +672,21 @@ sub wantroutepc16 return _want('routepc16', @_); } +sub wantusstate +{ + return _want('usstate', @_); +} + +sub wantdxcq +{ + return _want('dxcq', @_); +} + +sub wantdxitu +{ + return _want('dxitu', @_); +} + sub wantlogininfo { my $self = shift;