$main::build += $VERSION;
$main::branch += $BRANCH;
-use vars qw(%u $dbm $filename %valid $lastoperinterval $lasttime $lru $lrusize);
+use vars qw(%u $dbm $filename %valid $lastoperinterval $lasttime $lru $lrusize $tooold $v3);
%u = ();
$dbm = undef;
$filename = undef;
$lastoperinterval = 60*24*60*60;
$lasttime = 0;
-$lrusize = 500;
+$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 = (
wantann_talk => '0,Talklike Anns,yesno',
wantpc90 => '1,Req PC90,yesno',
wantnp => '1,Req New Protocol,yesno',
+ wantpc16 => '9,Want Users from node,yesno',
+ wantsendpc16 => '9,Send PC16,yesno',
+ wantroutepc19 => '9,Route PC19,yesno',
lastoper => '9,Last for/oper,cldatetime',
nothere => '0,Not Here Text',
registered => '9,Registered?,yesno',
build => '1,Build',
);
-no strict;
+#no strict;
sub AUTOLOAD
{
- my $self = shift;
+ no strict;
my $name = $AUTOLOAD;
return if $name =~ /::DESTROY$/;
- $name =~ s/.*:://o;
+ $name =~ s/^.*:://o;
confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
# this clever line of code creates a subroutine which takes over from autoload
# from OO Perl - Conway
- *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
- if (@_) {
- $self->{$name} = shift;
- }
- return $self->{$name};
+ *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}};
+ goto &$AUTOLOAD;
}
-use strict;
+#use strict;
#
# initialise the system
my ($pkg, $fn, $mode) = @_;
confess "need a filename in User" if !$fn;
- $fn .= ".v2";
+
+ my $ufn;
+ my $convert;
+
+ eval {
+ require Storable;
+ };
+
+# eval "use Storable qw(nfreeze thaw)";
+
+ if ($@) {
+ $ufn = "$fn.v2";
+ } else {
+ import Storable qw(nfreeze thaw);
+
+ $ufn = "$fn.v3";
+ $v3 = 1;
+ $convert = ! -e $ufn;
+ }
+
if ($mode) {
- $dbm = tie (%u, 'DB_File', $fn, O_CREAT|O_RDWR, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!)";
+ $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', $fn, O_RDONLY, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!)";
+ $dbm = tie (%u, 'DB_File', $ufn, O_RDONLY, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]";
}
- $filename = $fn;
+ # 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 (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 ($!) [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;
$lru = LRU->newbase("DXUser", $lrusize);
}
my ($pkg, $fn) = @_;
confess "need a filename in User" if !$fn;
- $fn .= ".v2";
+ $fn .= $v3 ? ".v3" : ".v2";
unlink $fn;
}
$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]);
}
#
-# create a hash from a string
+# create a hash from a string (in ascii)
#
-sub decode
+sub asc_decode
{
my $s = shift;
my $ref;
my $count = 0;
my $err = 0;
+ my $del = 0;
my $fh = new IO::File ">$fn" or return "cannot open $fn ($!)";
if ($fh) {
my $key = 0;
# 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 = <CLLOCK>;
while (<DATA>) {
chomp;
my @f = split /\t/;
- my $ref = decode($f[1]);
+ my $ref = asc_decode($f[1]);
if ($ref) {
$ref->put();
$count++;
}
my $ref = decode($val);
if ($ref) {
- print $fh "$key\t" . $ref->encode . "\n";
+ my $t = $ref->{lastin} || 0;
+ if ($main::systime > $t + $tooold) {
+ unless ($ref->{lat} && $ref->{long} || $ref->{qth} || $ref->{qra}) {
+ eval {$dbm->del($key)};
+ dbg(carp("Export Error2: $key\t$val\n$@")) if $@;
+ Log('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 . "\n";
++$count;
} else {
- Log('DXCommand', "Export Error2: $key\t$val");
+ Log('DXCommand', "Export Error3: $key\t$val");
eval {$dbm->del($key)};
- dbg(carp("Export Error2: $key\t$val\n$@")) if $@;
+ dbg(carp("Export Error3: $key\t$val\n$@")) if $@;
++$err;
}
}
$fh->close;
}
- return "$count Users $err Errors ('sh/log Export' for details)";
+ return "$count Users $del Deleted $err Errors ('sh/log Export' for details)";
}
#
return _want('ann_talk', @_);
}
+sub wantpc16
+{
+ return _want('pc16', @_);
+}
+
+sub wantsendpc16
+{
+ return _want('sendpc16', @_);
+}
+
+sub wantroutepc16
+{
+ return _want('routepc16', @_);
+}
+
sub wantlogininfo
{
my $self = shift;
projects / spider.git / blobdiff