X-Git-Url: http://dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXUser.pm;h=e2c24f598a5eee6d7fdd941ade20ac7f46cb0c78;hb=ab811a0c902225075a9bd69749f65594079433a9;hp=136ddee13deed71e2b849efe0c7100ae2f96fdca;hpb=7bf828b924d7d1ddc7c81e65d816bdc36f55a92f;p=spider.git diff --git a/perl/DXUser.pm b/perl/DXUser.pm index 136ddee1..e2c24f59 100644 --- a/perl/DXUser.pm +++ b/perl/DXUser.pm @@ -3,7 +3,7 @@ # # Copyright (c) 1998 - Dirk Koopman G1TLH # -# $Id$ +# # package DXUser; @@ -19,12 +19,6 @@ 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); %u = (); @@ -61,7 +55,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 +73,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', @@ -143,7 +138,7 @@ sub init $ufn = "$fn.v3"; $v3 = 1; - $convert++ unless -e $ufn; + $convert++ if -e "$fn.v2" && !-e $ufn; } if ($mode) { @@ -152,10 +147,12 @@ sub init $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 ($convert) { + if ($dbm && $convert) { my ($key, $val, $action, $count, $err) = ('','',0,0,0); my %oldu; @@ -212,17 +209,23 @@ sub finish # new - create a new user # -sub new +sub alloc { my $pkg = shift; my $call = uc shift; + my $self = bless {call => $call, 'sort'=>'U'}, $pkg; + return $self; +} + +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'; + my $self = $pkg->alloc($call); $self->put; return $self; } @@ -234,7 +237,6 @@ sub new sub get { - my $pkg = shift; my $call = uc shift; my $data; @@ -245,6 +247,11 @@ sub get # search for it unless ($dbm->get($call, $data)) { $ref = decode($data); + dbg("DXUser::get: data error on $call $!") unless $ref; + if ($ref && ref $ref ne 'DXUser') { + dbg("DXUser::get: got strange answer from decode ". ref $ref. " ignoring"); + return undef; + } $lru->put($call, $ref); return $ref; } @@ -261,14 +268,11 @@ 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); + return get($call); } # @@ -322,11 +326,7 @@ 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; + return dd($self); } # @@ -336,10 +336,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; @@ -482,9 +482,13 @@ print "There are $count user records and $err errors\n"; for ($action = R_FIRST; !$dbm->seq($key, $val, $action); $action = R_NEXT) { if (!is_callsign($key) || $key =~ /^0/) { - Log('DXCommand', "Export Error1: $key\t$val"); + 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: $key\t$val\n$@")) if $@; + dbg(carp("Export Error1: $ekey\t$eval\n$@")) if $@; ++$err; next; } @@ -495,7 +499,7 @@ print "There are $count user records and $err errors\n"; 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"); + LogDbg('DXCommand', "$ref->{call} deleted, too old"); $del++; next; } @@ -504,7 +508,7 @@ print "There are $count user records and $err errors\n"; print $fh "$key\t" . $ref->asc_encode . "\n"; ++$count; } else { - Log('DXCommand', "Export Error3: $key\t$val"); + LogDbg('DXCommand', "Export Error3: $key\t$val"); eval {$dbm->del($key)}; dbg(carp("Export Error3: $key\t$val\n$@")) if $@; ++$err; @@ -576,6 +580,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 # @@ -677,11 +688,6 @@ sub wantpc16 return _want('pc16', @_); } -sub wantpc90 -{ - return _wantnot('pc90', @_); -} - sub wantsendpc16 { return _want('sendpc16', @_); @@ -707,9 +713,14 @@ sub wantdxitu return _want('dxitu', @_); } -sub wantnp +sub wantgtk { - return _wantnot('np', @_); + return _want('gtk', @_); +} + +sub wantpc9x +{ + return _want('pc9x', @_); } sub wantlogininfo @@ -726,6 +737,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;