X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXUser.pm;h=84b6df3dd721ee99704c0a8867ece5c09dd8235a;hb=6951e5c6623c813b5f3da77796aa22c7e0848e44;hp=3df7fc20b218e42a2afb90da8fa03d0dec82cbf7;hpb=4f9aaa802abf523aab9e02e17809cdc17e6035f9;p=spider.git diff --git a/perl/DXUser.pm b/perl/DXUser.pm index 3df7fc20..84b6df3d 100644 --- a/perl/DXUser.pm +++ b/perl/DXUser.pm @@ -3,13 +3,12 @@ # # Copyright (c) 1998 - Dirk Koopman G1TLH # -# $Id$ +# # package DXUser; use DXLog; -use DB_File; use Data::Dumper; use Fcntl; use IO::File; @@ -19,16 +18,11 @@ use LRU; use strict; -use vars qw($VERSION $BRANCH); -$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); -$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 $v3); +use vars qw(%u $dbm $dbh $filename %valid $lastoperinterval $lasttime $lru $lrusize $tooold $v3 $v4); %u = (); $dbm = undef; +$dbh = undef; $filename = undef; $lastoperinterval = 60*24*60*60; $lasttime = 0; @@ -36,6 +30,8 @@ $lrusize = 2000; $tooold = 86400 * 365; # this marks an old user who hasn't given enough info to be useful $v3 = 0; +my $dbh_working; + # hash of valid elements and a simple prompt %valid = ( call => '0,Callsign', @@ -61,7 +57,8 @@ $v3 = 0; annok => '9,Accept Announces?,yesno', # accept his announces? lang => '0,Language', hmsgno => '0,Highest Msgno', - group => '0,Chat Group,parray', # used to create a group of users/nodes for some purpose or other + group => '0,Group,parray', # used to create a group of users/nodes for some purpose or other + buddies => '0,Buddies,parray', isolate => '9,Isolate network,yesno', wantbeep => '0,Req Beep,yesno', wantann => '0,Req Announce,yesno', @@ -78,14 +75,14 @@ $v3 = 0; wantlogininfo => '0,Login Info Req,yesno', wantgrid => '0,Show DX Grid,yesno', wantann_talk => '0,Talklike Anns,yesno', - wantpc90 => '1,Req PC90,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', + wantgtk => '0,Want GTK interface,yesno', + wantpc9x => '0,Want PC9X interface,yesno', lastoper => '9,Last for/oper,cldatetime', nothere => '0,Not Here Text', registered => '9,Registered?,yesno', @@ -94,6 +91,7 @@ $v3 = 0; build => '1,Build', believe => '1,Believable nodes,parray', lastping => '1,Last Ping at,ptimelist', + maxconnect => '1,Max Connections', ); #no strict; @@ -125,44 +123,95 @@ sub init my $ufn; my $convert; - + eval { - require Storable; + require DBI; + require DBD::SQLite; + require JSON; }; - -# eval "use Storable qw(nfreeze thaw)"; if ($@) { - $ufn = "$fn.v2"; - $v3 = $convert = 0; - dbg("the module Storable appears to be missing!!"); + + $ufn = "$fn.v3"; + $v3 = 1; $convert = 0; + dbg("One of more of the modules DBI, DBD::SQLite and JSON appear to be missing!!"); dbg("trying to continue in compatibility mode (this may fail)"); - dbg("please install Storable from CPAN as soon as possible"); + dbg("please install DBI, DBD::SQLite and JSON from CPAN as soon as possible"); + + eval { + require DB_File; + require Storable; + }; + + if ($@) { + $ufn = "$fn.v2"; + $v3 = $convert = 0; + dbg("One of the modules DB_File and 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 DB_File; + import Storable qw(nfreeze thaw); + + $ufn = "$fn.v3"; + $v3 = 1; + $convert++ if -e "$fn.v2" && !-e $ufn; + } } else { - import Storable qw(nfreeze thaw); + import DBI; + import DBD::SQLite; + import JSON qw(-convert_blessed_universally); + + $ufn = "$fn.v4"; + $v4 = 1; + $convert++ if -e "$fn.v3" && !-e $ufn; + } - $ufn = "$fn.v3"; - $v3 = 1; - $convert++ unless -e $ufn; + $main::systime ||= time; # becuase user_asc doesn't set it + + # open "database" files + if ($v3) { + if ($mode) { + $dbm = tie (%u, 'DB_File', "$fn.v3", O_CREAT|O_RDWR, 0666, $DB::File::DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]"; + } else { + $dbm = tie (%u, 'DB_File', "$fn.v3", O_RDONLY, 0666, $DB_File::DB_BTREE) or confess "can't open user file: $fn ($!) [rebuild it from user_asc?]"; + } + die "Cannot open $fn.v3 ($!)\n" unless $dbm; } - - 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?]"; + if ($v4) { + my $new = ! -e $ufn; + $dbh = DBI->connect("dbi:SQLite:dbname=$ufn","","") or die "Cannot open $ufn ($!)\n"; + if ($new) { + # create the table + my $table = q{create table user( +call text not null unique, +lastseen int not null, +data text not null +)}; + $dbh->do($table) or die "cannot create user table in $ufn " . $dbh->errstr; + + # Add indexes + $dbh->do(q(create index x1 on user(lastseen))) or die $dbh->errstr; + } + $dbh->do(q{PRAGMA cache_size = 8000}); + $dbh->do(q{PRAGMA synchronous = OFF}); } - $lru = LRU->newbase("DXUser", $lrusize); - + # do a conversion if required - if ($convert) { + if ($dbm && $v3 && $convert) { my ($key, $val, $action, $count, $err) = ('','',0,0,0); + + require DB_File; + require Storable; + import DB_File; + import Storable qw(nfreeze thaw); 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) { + dbg("This will take a while, I suggest you go and have a cup of strong tea"); + my $odbm = tie (%oldu, 'DB_File', "$fn.v2", O_RDONLY, 0666, $DB_File::DB_BTREE) or confess "can't open user file: $fn.v2 ($!) [rebuild it from user_asc?]"; + for ($action = DB_File::R_FIRST(); !$odbm->seq($key, $val, $action); $action = DB_File::R_NEXT()) { my $ref = asc_decode($val); if ($ref) { $ref->put; @@ -175,6 +224,44 @@ sub init untie %oldu; dbg("Conversion completed $count records $err errors"); } + + if ($dbh && $v4 && $convert) { + my ($key, $val, $action, $count, $err) = ('','',0,0,0); + + + my %oldu; + dbg("Converting the User File to V4 "); + dbg("This will take a while, I suggest you go and have a cup of strong tea"); + require DB_File; + require Storable; + import DB_File; + import Storable qw(nfreeze thaw); + my $odbm = tie (%oldu, 'DB_File', "$fn.v3", O_RDONLY, 0666, $DB_File::DB_BTREE) or confess "can't open user file: $fn.v3 ($!) [rebuild it from user_asc?]"; + $dbh->begin_work; + $dbh_working++; + for ($action = DB_File::R_FIRST(); !$odbm->seq($key, $val, $action); $action = DB_File::R_NEXT()) { + my $ref = thaw($val); + if ($ref) { + my $r = _insert($ref); + if ($r) { + $count++; + } else { + $err++; + dbg("error converting call $ref->{call} - " . $dbh->errstr); + } + } else { + $err++ + } + } + sync(); + undef $odbm; + untie %oldu; + dbg("Conversion completed $count records $err errors"); + + } + + $lru = LRU->newbase("DXUser", $lrusize); + $filename = $ufn; } @@ -183,7 +270,11 @@ sub del_file my ($pkg, $fn) = @_; confess "need a filename in User" if !$fn; - $fn .= $v3 ? ".v3" : ".v2"; + my $suffix; + $suffix = '.v4' if $v4; + $suffix ||= '.v3' if $v3; + $suffix ||= '.v2'; + $fn .= $suffix; unlink $fn; } @@ -192,8 +283,8 @@ sub del_file # sub process { - if ($main::systime > $lasttime + 15) { - $dbm->sync; + if ($main::systime > $lasttime + 5) { + sync(); $lasttime = $main::systime; } } @@ -204,26 +295,64 @@ sub process sub finish { - undef $dbm; - untie %u; + if ($dbm) { + undef $dbm; + untie %u; + } + $dbh->disconnect if $dbh; } # # new - create a new user # -sub new +sub alloc { my $pkg = shift; my $call = uc shift; + my $self = bless {call => $call, 'sort'=>'U'}, $pkg; + _insert($self) or confess($dbh->errstr) if $v4; + return $self; +} + +sub _insert +{ + my $self = shift; + my $json = JSON->new->allow_blessed->convert_blessed->encode($self); + $dbh->begin_work unless $dbh_working++; + my $r = $dbh->do(q{replace into user values(?,?,?)}, undef, $self->{call}, $main::systime, $json); + return $r; +} + +sub _select +{ + my $call = shift; + my $sth = $dbh->prepare(qq{select data from user where call = ?}) or confess($dbh->errstr); + my $rv = $sth->execute($call); + if ($rv) { + my @row = $sth->fetchrow_array; + return $row[0]; + } + return undef; +} + +sub _delete +{ + my $call =shift; + my $r = $dbh->do(q{delete from user where call = ?}, undef, $call); + return $r; +} + +sub new +{ + my $pkg = shift; + my $call = shift; # $call =~ s/-\d+$//o; # confess "can't create existing call $call in User\n!" if $u{$call}; - my $self = bless {}, $pkg; - $self->{call} = $call; - $self->{'sort'} = 'U'; - $self->put; + my $self = $pkg->alloc($call); + $self->put unless $v4; return $self; } @@ -234,20 +363,35 @@ sub new sub get { - my $pkg = shift; my $call = uc shift; my $data; # is it in the LRU cache? my $ref = $lru->get($call); - return $ref if $ref; + return $ref if $ref && ref $ref eq 'DXUser'; # search for it - unless ($dbm->get($call, $data)) { - $ref = decode($data); - $lru->put($call, $ref); - return $ref; + if ($v4) { + if ($data = _select($call)) { + $ref = bless decode_json($data), 'DXUser'; + } + } else { + unless ($dbm->get($call, $data)) { + $ref = decode($data); + } + } + + if ($ref) { + if (UNIVERSAL::isa($ref, 'DXUser')) { + dbg("DXUser::get: got strange answer from decode of $call". ref $ref. " ignoring"); + return undef; + } + # we have a reference and it *is* a DXUser + } else { + dbg("DXUser::get: no reference returned from decode of $call $!"); + return undef; } + $lru->put($call, $ref); return undef; } @@ -261,14 +405,16 @@ sub get sub get_current { - my $pkg = shift; my $call = uc shift; my $dxchan = DXChannel::get($call); - return $dxchan->user if $dxchan; - my $rref = Route::get($call); - return $rref->user if $rref && exists $rref->{user}; - return $pkg->get($call); + if ($dxchan) { + my $ref = $dxchan->user; + return $ref if $ref && UNIVERSAL::isa($ref, 'DXUser'); + + dbg("DXUser::get_current: got invalid user ref for $call from dxchan $dxchan->{call} ". ref $ref. " ignoring"); + } + return get($call); } # @@ -277,7 +423,20 @@ sub get_current sub get_all_calls { - return (sort keys %u); + if ($v4) { + my $sth = $dbh->prepare(qq{select call from user}) or confess($dbh->errstr); + my $rv = $sth->execute(); + if ($rv) { + my @row; + my @r; + while (my @r = $sth->fetchrow_array) { + push @row, @r; + } + return @row; # 'cos it's already sorted + } + } else { + return (sort keys %u); + } } # @@ -289,16 +448,18 @@ sub put my $self = shift; confess "Trying to put nothing!" unless $self && ref $self; my $call = $self->{call}; - # delete all instances of this -# for ($dbm->get_dup($call)) { -# $dbm->del_dup($call, $_); -# } - $dbm->del($call); + delete $self->{annok} if $self->{annok}; delete $self->{dxok} if $self->{dxok}; + $lru->put($call, $self); - my $ref = $self->encode; - $dbm->put($call, $ref); + if ($v4) { + _insert($self); + } else { + $dbm->del($call); + my $ref = $self->encode; + $dbm->put($call, $ref); + } } # freeze the user @@ -322,11 +483,20 @@ sub decode sub asc_encode { my $self = shift; - my $dd = new Data::Dumper([$self]); - $dd->Indent(0); - $dd->Terse(1); - $dd->Quotekeys($] < 5.005 ? 1 : 0); - return $dd->Dumpxs; + 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); + } else { + $p = dd($self); + } + return $p; } # @@ -336,10 +506,10 @@ sub asc_decode { my $s = shift; my $ref; + $s =~ s/\%([0-9A-F][0-9A-F])/chr(hex($1))/eg; eval '$ref = ' . $s; if ($@) { - dbg($@); - Log('err', $@); + LogDbg('err', $@); $ref = undef; } return $ref; @@ -352,13 +522,13 @@ sub asc_decode sub del { my $self = shift; - my $call = $self->{call}; - # delete all instances of this -# for ($dbm->get_dup($call)) { -# $dbm->del_dup($call, $_); -# } - $lru->remove($call); - $dbm->del($call); + if ($v4) { + _delete($self) + } else { + my $call = $self->{call}; + $lru->remove($call); + $dbm->del($call); + } } # @@ -369,7 +539,7 @@ sub close { my $self = shift; $self->{lastin} = time; - $self->put(); + $self->put; } # @@ -378,7 +548,12 @@ sub close sub sync { - $dbm->sync; + if ($v4) { + $dbh->commit if $dbh_working; + $dbh_working = 0; + } else { + $dbm->sync; + } } # @@ -398,22 +573,20 @@ sub fields sub export { my $fn = shift; + my $basic_info_only = shift; # save old ones - rename "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo"; - rename "$fn.ooo", "$fn.oooo" if -e "$fn.ooo"; - rename "$fn.oo", "$fn.ooo" if -e "$fn.oo"; - rename "$fn.o", "$fn.oo" if -e "$fn.o"; - rename "$fn", "$fn.o" if -e "$fn"; + rename "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo"; + rename "$fn.ooo", "$fn.oooo" if -e "$fn.ooo"; + rename "$fn.oo", "$fn.ooo" if -e "$fn.oo"; + rename "$fn.o", "$fn.oo" if -e "$fn.o"; + rename "$fn", "$fn.o" if -e "$fn"; 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; - my $val = undef; - my $action; my $t = scalar localtime; print $fh q{#!/usr/bin/perl # @@ -480,40 +653,76 @@ print "There are $count user records and $err errors\n"; }; print $fh "__DATA__\n"; - for ($action = R_FIRST; !$dbm->seq($key, $val, $action); $action = R_NEXT) { - if (!is_callsign($key) || $key =~ /^0/) { - 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; - Log('DXCommand', "Export Error1: $ekey\t$eval"); - eval {$dbm->del($key)}; - dbg(carp("Export Error1: $ekey\t$eval\n$@")) if $@; - ++$err; - next; - } - my $ref = decode($val); - if ($ref) { - my $t = $ref->{lastin} || 0; - if ($ref->{sort} eq 'U' && !$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 $@; - Log('DXCommand', "$ref->{call} deleted, too old"); - $del++; + if ($v4) { + my $sth = $dbh->prepare(q{select call,data from user}) or confess($dbh->errstr); + my $rv = $sth->execute; + if ($rv) { + while (my @row = $sth->fetchrow_array) { + my $call = shift @row; + my $data = shift @row; + if (!is_callsign($call) || $call =~ /^0/) { + LogDbg('DXCommand', "Export Error1: $call\t$data"); + _delete($call); + ++$err; next; } + my $ref = bless decode_json($data), __PACKAGE__; + my $t = $ref->{lastin} || 0; + if ($ref->{sort} eq 'U' && !$ref->{priv} && $main::systime > $t + $tooold) { + unless ($ref->{lat} && $ref->{long} || $ref->{qth} || $ref->{qra}) { + LogDbg('DXCommand', "$ref->{call} deleted, too old"); + _delete($call); + $del++; + next; + } + } + + # only store users that are reasonably active or have useful information + print $fh "$call\t" . $ref->asc_encode($basic_info_only) . "\n"; + ++$count; } - # only store users that are reasonably active or have useful information - print $fh "$key\t" . $ref->asc_encode . "\n"; - ++$count; } else { - Log('DXCommand', "Export Error3: $key\t$val"); - eval {$dbm->del($key)}; - dbg(carp("Export Error3: $key\t$val\n$@")) if $@; - ++$err; + dbg(carp($dbh->errstr)); } - } + } else { + my $key = 0; + my $val = undef; + my $action; + for ($action = DB_File::R_FIRST(); !$dbm->seq($key, $val, $action); $action = DB_File::R_NEXT()) { + if (!is_callsign($key) || $key =~ /^0/) { + 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"); + eval {$dbm->del($key)}; + dbg(carp("Export Error1: $ekey\t$eval\n$@")) if $@; + ++$err; + next; + } + my $ref = decode($val); + if ($ref) { + my $t = $ref->{lastin} || 0; + if ($ref->{sort} eq 'U' && !$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 $@; + 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"; + ++$count; + } else { + LogDbg('DXCommand', "Export Error3: $key\t$val"); + eval {$dbm->del($key)}; + dbg(carp("Export Error3: $key\t$val\n$@")) if $@; + ++$err; + } + } + } $fh->close; } return "$count Users $del Deleted $err Errors ('sh/log Export' for details)"; @@ -580,6 +789,13 @@ sub new_group $self->{group} = [ 'local' ]; } +# set up empty buddies (only happens for them's that connect direct) +sub new_buddies +{ + my $self = shift; + $self->{buddies} = [ ]; +} + # # return a prompt for a field # @@ -681,11 +897,6 @@ sub wantpc16 return _want('pc16', @_); } -sub wantpc90 -{ - return _wantnot('pc90', @_); -} - sub wantsendpc16 { return _want('sendpc16', @_); @@ -711,9 +922,14 @@ sub wantdxitu return _want('dxitu', @_); } -sub wantnp +sub wantgtk { - return _wantnot('np', @_); + return _want('gtk', @_); +} + +sub wantpc9x +{ + return _want('pc9x', @_); } sub wantlogininfo @@ -730,6 +946,12 @@ sub is_node return $self->{sort} =~ /[ACRSX]/; } +sub is_local_node +{ + my $self = shift; + return grep $_ eq 'local_node', @{$self->{group}}; +} + sub is_user { my $self = shift;