projects
/
spider.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
improve dbg tagging and dbgdump, Add call to conns
[spider.git]
/
perl
/
DXUser.pm
diff --git
a/perl/DXUser.pm
b/perl/DXUser.pm
index 02ed86cd002949b5d94c8f74def12ccd1e8d3db9..642649e844e45567d07557f7a9f8630dbaf43d45 100644
(file)
--- a/
perl/DXUser.pm
+++ b/
perl/DXUser.pm
@@
-20,6
+20,7
@@
use File::Copy;
use Data::Structure::Util qw(unbless);
use Time::HiRes qw(gettimeofday tv_interval);
use IO::File;
use Data::Structure::Util qw(unbless);
use Time::HiRes qw(gettimeofday tv_interval);
use IO::File;
+use JSON;
use strict;
use strict;
@@
-30,7
+31,7
@@
$dbm = undef;
$filename = undef;
$lastoperinterval = 60*24*60*60;
$lasttime = 0;
$filename = undef;
$lastoperinterval = 60*24*60*60;
$lasttime = 0;
-$lrusize =
3
000;
+$lrusize =
10
000;
$tooold = 86400 * 365; # this marks an old user who hasn't given enough info to be useful
$v3 = 0;
our $maxconnlist = 3; # remember this many connection time (duration) [start, end] pairs
$tooold = 86400 * 365; # this marks an old user who hasn't given enough info to be useful
$v3 = 0;
our $maxconnlist = 3; # remember this many connection time (duration) [start, end] pairs
@@
-49,6
+50,7
@@
my $json;
email => '0,E-mail Address,parray',
priv => '9,Privilege Level',
lastin => '0,Last Time in,cldatetime',
email => '0,E-mail Address,parray',
priv => '9,Privilege Level',
lastin => '0,Last Time in,cldatetime',
+ lastseen => '0,Last Seen,cldatetime',
passwd => '9,Password,yesno',
passphrase => '9,Pass Phrase,yesno',
addr => '0,Full Address',
passwd => '9,Password,yesno',
passphrase => '9,Pass Phrase,yesno',
addr => '0,Full Address',
@@
-105,6
+107,7
@@
my $json;
maxconnect => '1,Max Connections',
startt => '0,Start Time,cldatetime',
connlist => '1,Connections,parraydifft',
maxconnect => '1,Max Connections',
startt => '0,Start Time,cldatetime',
connlist => '1,Connections,parraydifft',
+ width => '0,Preferred Width'
);
#no strict;
);
#no strict;
@@
-179,6
+182,7
@@
sub process
sub finish
{
sub finish
{
+ $dbm->sync;
undef $dbm;
untie %u;
}
undef $dbm;
untie %u;
}
@@
-204,6
+208,7
@@
sub new
# confess "can't create existing call $call in User\n!" if $u{$call};
my $self = $pkg->alloc($call);
# confess "can't create existing call $call in User\n!" if $u{$call};
my $self = $pkg->alloc($call);
+ $self->{lastseen} = $main::systime;
$self->put;
return $self;
}
$self->put;
return $self;
}
@@
-220,7
+225,10
@@
sub get
# is it in the LRU cache?
my $ref = $lru->get($call);
# is it in the LRU cache?
my $ref = $lru->get($call);
- return $ref if $ref && ref $ref eq 'DXUser';
+ if ($ref && ref $ref eq 'DXUser') {
+ $ref->{lastseen} = $main::systime;
+ return $ref;
+ }
# search for it
unless ($dbm->get($call, $data)) {
# search for it
unless ($dbm->get($call, $data)) {
@@
-240,6
+248,7
@@
sub get
}
return undef;
}
}
return undef;
}
+ $ref->{lastseen} = $main::systime;
$lru->put($call, $ref);
return $ref;
}
$lru->put($call, $ref);
return $ref;
}
@@
-316,9
+325,15
@@
sub encode
{
my $ref = shift;
unbless($ref);
{
my $ref = shift;
unbless($ref);
- my $s = $json->encode($ref);
- bless $ref, 'DXUser';
- return $s;
+ my $s;
+
+ eval {$s = $json->encode($ref) };
+ if ($s && !$@) {
+ bless $ref, 'DXUser';
+ return $s;
+ } else {
+ LogDbg('DXUser', "DXUser::json_encode $ref->{call}, $@");
+ }
}
}
@@
-343,7
+358,7
@@
sub close
my $self = shift;
my $startt = shift;
my $ip = shift;
my $self = shift;
my $startt = shift;
my $ip = shift;
- $self->{lastin} = $main::systime;
+ $self->{last
seen} = $self->{last
in} = $main::systime;
# add a record to the connect list
my $ref = [$startt || $self->{startt}, $main::systime];
push @$ref, $ip if $ip;
# add a record to the connect list
my $ref = [$startt || $self->{startt}, $main::systime];
push @$ref, $ip if $ip;
@@
-474,10
+489,10
@@
print "There are $count user records and $err errors in $diff mS\n";
my $eval = $val;
my $ekey = $key;
$eval =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg;
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:
$ekey\t$eval
");
+ $ekey =~ s/([\%\x00-\x1f\x7f-\xff])/sprintf("%%%02X", ord($1))/eg;
+ LogDbg('DXCommand', "Export Error1:
invalid call '$key' => '$val'
");
eval {$dbm->del($key)};
eval {$dbm->del($key)};
-
dbg(carp("Export Error1: $ekey\t$eval\n
$@")) if $@;
+
dbg(carp("Export Error1: delete $key => '$val'
$@")) if $@;
++$err;
next;
}
++$err;
next;
}
@@
-488,7
+503,7
@@
print "There are $count user records and $err errors in $diff mS\n";
if ($ref->is_user && !$ref->{priv} && $main::systime > $t + $tooold) {
unless ($ref->{lat} && $ref->{long} || $ref->{qth} || $ref->{qra}) {
eval {$dbm->del($key)};
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:
$key\t$val\n
$@")) if $@;
+ dbg(carp("Export Error2:
delete '$key' => '$val'
$@")) if $@;
LogDbg('DXCommand', "$ref->{call} deleted, too old");
$del++;
next;
LogDbg('DXCommand', "$ref->{call} deleted, too old");
$del++;
next;
@@
-498,9
+513,9
@@
print "There are $count user records and $err errors in $diff mS\n";
print $fh "$key\t" . encode($ref) . "\n";
++$count;
} else {
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)};
eval {$dbm->del($key)};
- dbg(carp("Export Error3:
$key\t$val\n
$@")) if $@;
+ dbg(carp("Export Error3:
delete '$key' => '$val'
$@")) if $@;
++$err;
}
}
++$err;
}
}
@@
-663,7
+678,7
@@
sub wanttalk
sub wantgrid
{
sub wantgrid
{
- return _want('grid', @_);
+ return _want
not
('grid', @_);
}
sub wantemail
}
sub wantemail
@@
-698,12
+713,12
@@
sub wantusstate
sub wantdxcq
{
sub wantdxcq
{
- return _want('dxcq', @_);
+ return _want
not
('dxcq', @_);
}
sub wantdxitu
{
}
sub wantdxitu
{
- return _want('dxitu', @_);
+ return _want
not
('dxitu', @_);
}
sub wantgtk
}
sub wantgtk