package DXUser;
-require Exporter;
-@ISA = qw(Exporter);
-
use DXLog;
use DB_File;
use Data::Dumper;
use DXDebug;
use strict;
-use vars qw(%u $dbm $filename %valid);
+
+use vars qw($VERSION $BRANCH);
+$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
+$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ ) || 0;
+$main::build += $VERSION;
+$main::branch += $BRANCH;
+
+use vars qw(%u $dbm $filename %valid $lastoperinterval $lasttime);
%u = ();
$dbm = undef;
$filename = undef;
+$lastoperinterval = 30*24*60*60;
+$lasttime = 0;
# hash of valid elements and a simple prompt
%valid = (
lat => '0,Latitude,slat',
long => '0,Longitude,slong',
qra => '0,Locator',
- email => '0,E-mail Address',
+ email => '0,E-mail Address,parray',
priv => '9,Privilege Level',
lastin => '0,Last Time in,cldatetime',
- passwd => '9,Password',
+ passwd => '9,Password,yesno',
addr => '0,Full Address',
'sort' => '0,Type of User', # A - ak1a, U - User, S - spider cluster, B - BBS
xpert => '0,Expert Status,yesno',
lockout => '9,Locked out?,yesno', # won't let them in at all
dxok => '9,Accept DX Spots?,yesno', # accept his dx spots?
annok => '9,Accept Announces?,yesno', # accept his announces?
- reg => '0,Registered?,yesno', # is this user registered?
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
wanttalk => '0,Rec Talk,yesno',
wantwx => '0,Rec WX,yesno',
wantdx => '0,Rec DX Spots,yesno',
+ wantemail => '0,Rec Msgs as Email,yesno',
pagelth => '0,Current Pagelth',
pingint => '9,Node Ping interval',
nopings => '9,Ping Obs Count',
wantlogininfo => '9,Login info req,yesno',
- wantgrid => '0,DX Grid Info,yesno',
+ wantgrid => '0,DX Grid Info,yesno',
+ wantann_talk => '0,Talklike Anns,yesno',
lastoper => '9,Last for/oper,cldatetime',
+ nothere => '0,Not Here Text',
+ registered => '9,Registered?,yesno',
);
no strict;
$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};
}
+use strict;
+
#
# initialise the system
#
$filename = $fn;
}
-use strict;
+sub del_file
+{
+ my ($pkg, $fn) = @_;
+
+ confess "need a filename in User" if !$fn;
+ $fn .= ".v2";
+ unlink $fn;
+}
+
+#
+# periodic processing
+#
+sub process
+{
+ if ($main::systime > $lasttime + 15) {
+ $dbm->sync;
+ $lasttime = $main::systime;
+ }
+}
#
# close the system
{
my $pkg = shift;
my $call = uc shift;
- # $call =~ s/-\d+$//o; # strip ssid
- my $s = $u{$call};
- return $s ? decode($s) : undef;
-}
-
-#
-# get all callsigns in the database
-#
-
-sub get_all_calls
-{
- return (sort keys %u);
+ my $data;
+ unless ($dbm->get($call, $data)) {
+ return decode($data);
+ }
+ return undef;
}
#
{
my $pkg = shift;
my $call = uc shift;
- # $call =~ s/-\d+$//o; # strip ssid
my $dxchan = DXChannel->get($call);
return $dxchan->user if $dxchan;
- return get($pkg, $call);
+ my $data;
+ unless ($dbm->get($call, $data)) {
+ return decode($data);
+ }
+ return undef;
+}
+
+#
+# get all callsigns in the database
+#
+
+sub get_all_calls
+{
+ return (sort keys %u);
}
#
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, $_);
- }
+# for ($dbm->get_dup($call)) {
+# $dbm->del_dup($call, $_);
+# }
+ $dbm->del($call);
delete $self->{annok} if $self->{annok};
delete $self->{dxok} if $self->{dxok};
- $u{$call} = $self->encode();
- $dbm->sync;
+ $dbm->put($call, $self->encode);
}
#
{
my $s = shift;
my $ref;
- $s = '$ref = ' . $s;
- eval $s;
- Log('DXUser', $@) if $@;
- $ref = undef if $@;
+ eval '$ref = ' . $s;
+ if ($@) {
+ dbg($@);
+ Log('err', $@);
+ $ref = undef;
+ }
return $ref;
}
my $self = shift;
my $call = $self->{call};
# delete all instances of this
- for ($dbm->get_dup($call)) {
- $dbm->del_dup($call, $_);
- }
- $dbm->sync;
+# for ($dbm->get_dup($call)) {
+# $dbm->del_dup($call, $_);
+# }
+ $dbm->del($call);
}
#
$self->put();
}
+#
+# sync the database
+#
+
+sub sync
+{
+ $dbm->sync;
+}
+
#
# return a list of valid elements
#
my $count = 0;
my $fh = new IO::File ">$fn" or return "cannot open $fn ($!)";
if ($fh) {
- my $ref;
- my $key;
+ my $ref = 0;
+ my $key = 0;
my $action;
my $t = scalar localtime;
- print $fh "#!/usr/bin/perl
+ print $fh q{#!/usr/bin/perl
#
# The exported userfile for a DXSpider System
#
# Input file: $filename
# Time: $t
#
+
+package main;
+
+# search local then perl directories
+BEGIN {
+ umask 002;
+
+ # root of directory tree for this system
+ $root = "/spider";
+ $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
+
+ unshift @INC, "$root/perl"; # this IS the right way round!
+ unshift @INC, "$root/local";
+
+ # try to detect a lockfile (this isn't atomic but
+ # should do for now
+ $lockfn = "$root/perl/cluster.lck"; # lock file name
+ if (-e $lockfn) {
+ open(CLLOCK, "$lockfn") or die "Can't open Lockfile ($lockfn) $!";
+ my $pid = <CLLOCK>;
+ chomp $pid;
+ die "Lockfile ($lockfn) and process $pid exists - cluster must be stopped first\n" if kill 0, $pid;
+ close CLLOCK;
+ }
+}
package DXUser;
+use DXVars;
+use DXUser;
+
+if (@ARGV) {
+ $main::userfn = shift @ARGV;
+ print "user filename now $userfn\n";
+}
+
+DXUser->del_file($main::userfn);
+DXUser->init($main::userfn, 1);
+
%u = (
-";
+ };
- for ($action = R_FIRST; !$dbm->seq($key, $ref, $action); $action = R_NEXT) {
- print $fh "'$key' => $ref,\n";
+ for ($action = R_FIRST; !$dbm->seq($key, $ref, $action); $action = R_NEXT) {
+ print $fh "'$key' => q{$ref},\n";
++$count;
}
- print $fh ");\n#\n# there were $count records\n#\n";
- $fh->close;
- }
+ print $fh ");\n#\nprint \"there were $count records\\n\";\n#\n";
+ print $fh "DXUser->sync; DXUser->finish;\n#\n";
+ $fh->close;
+ }
return $count;
}
return _want('grid', @_);
}
+sub wantemail
+{
+ return _want('email', @_);
+}
+
+sub wantann_talk
+{
+ return _want('ann_talk', @_);
+}
+
sub wantlogininfo
{
my $self = shift;
- my $n = shift;
- $self->{wantlogininfo} = $n if $n;
- return exists $self->{wantlogininfo} ? $self->{wantlogininfo} : 0;
+ my $val = shift;
+ $self->{wantlogininfo} = $val if defined $val;
+ return $self->{wantlogininfo};
}
sub is_node
my $self = shift;
return $self->{sort} eq 'A';
}
+
+sub unset_passwd
+{
+ my $self = shift;
+ delete $self->{passwd};
+}
1;
__END__
projects / spider.git / blobdiff