From 9e2fbafcfdab1ee45e581524311f1a97ac41f6ad Mon Sep 17 00:00:00 2001 From: djk Date: Mon, 8 Nov 1999 00:45:20 +0000 Subject: [PATCH] 5. Only wonder down the msg queue every minute 6. Put in the initial DB code (at last), you can create and remove local and standard remote dbs, you can import AK1A style .FUL ascii databases, you can enquire on a local or remote database. 7. A return ping to a node will clear down all outstanding pings to that node (which might cause some confusion if more then one ping is outstanding for a node, but then - shit happens) --- Changes | 7 + cmd/Aliases | 2 +- cmd/db.pl | 0 cmd/dbavail.pl | 16 +++ cmd/dbcreate.pl | 16 +++ cmd/dbdelkey.pl | 12 ++ cmd/dbgetkey.pl | 31 ++++ cmd/dbimport.pl | 50 +++++++ cmd/dbremove.pl | 18 +++ cmd/dbupdate.pl | 12 ++ perl/DXCommandmode.pm | 6 +- perl/DXDb.pm | 319 ++++++++++++++++++++++++++++++++++++++++++ perl/DXMsg.pm | 30 ++-- perl/DXProt.pm | 15 +- perl/DXProtout.pm | 22 +++ perl/DXUtil.pm | 57 +++++++- perl/Messages | 10 ++ perl/cluster.pl | 8 ++ 18 files changed, 601 insertions(+), 30 deletions(-) delete mode 100644 cmd/db.pl create mode 100644 cmd/dbavail.pl create mode 100644 cmd/dbcreate.pl create mode 100644 cmd/dbdelkey.pl create mode 100644 cmd/dbgetkey.pl create mode 100644 cmd/dbimport.pl create mode 100644 cmd/dbremove.pl create mode 100644 cmd/dbupdate.pl diff --git a/Changes b/Changes index bc1bc03c..19f517d7 100644 --- a/Changes +++ b/Changes @@ -4,6 +4,13 @@ a WWV. 3. Added some logging for set/priv (un)set/lockout. 4. Added test long path calc to sh/muf +5. Only wonder down the msg queue every minute +6. Put in the initial DB code (at last), you can create and remove local and +standard remote dbs, you can import AK1A style .FUL ascii databases, you can +enquire on a local or remote database. +7. A return ping to a node will clear down all outstanding pings to +that node (which might cause some confusion if more then one ping is +outstanding for a node, but then - shit happens). 04Nov99======================================================================= 1. Removed ~ from the end of the PC18. 2. Removed a hangover from duff character checking in cluster.pl diff --git a/cmd/Aliases b/cmd/Aliases index 9c5094e4..ef5172cc 100644 --- a/cmd/Aliases +++ b/cmd/Aliases @@ -23,7 +23,7 @@ package CmdAlias; %alias = ( '?' => [ - '^\?', 'help', 'help', + '^\?', 'apropos', 'apropos', ], 'a' => [ '^ann.*/full', 'announce full', 'announce', diff --git a/cmd/db.pl b/cmd/db.pl deleted file mode 100644 index e69de29b..00000000 diff --git a/cmd/dbavail.pl b/cmd/dbavail.pl new file mode 100644 index 00000000..9d898514 --- /dev/null +++ b/cmd/dbavail.pl @@ -0,0 +1,16 @@ +#!/usr/bin/perl +# +# Database update routine +# +# Copyright (c) 1999 Dirk Koopman G1TLH +# +my ($self, $line) = @_; +my @out; + +my $f; + +foreach $f (values %DXDb::avail) { + push @out, "DB Name Location" unless @out; + push @out, sprintf "%-15s %-s", $f->name, $f->remote ? $f->remote : "Local"; +} +return (1, @out); diff --git a/cmd/dbcreate.pl b/cmd/dbcreate.pl new file mode 100644 index 00000000..5ef4fe7d --- /dev/null +++ b/cmd/dbcreate.pl @@ -0,0 +1,16 @@ +#!/usr/bin/perl +# +# Database update routine +# +# Copyright (c) 1999 Dirk Koopman G1TLH +# +my ($self, $line) = @_; +my ($name, $remote) = split /\s+/, $line; +my @out; + +return (1, $self->msg('e5')) if $self->priv < 9; + +return (1, $self->msg('db6', $name)) if DXDb::getdesc($name); +DXDb::new($name, $remote); +push @out, $self->msg($remote ? 'db7' : 'db8', $name, $remote); +return (1, @out); diff --git a/cmd/dbdelkey.pl b/cmd/dbdelkey.pl new file mode 100644 index 00000000..34198bfa --- /dev/null +++ b/cmd/dbdelkey.pl @@ -0,0 +1,12 @@ +#!/usr/bin/perl +# +# Database update routine +# +# Copyright (c) 1999 Dirk Koopman G1TLH +# +my ($self, $line) = @_; +my @f = split /\s+/, $line; +my @out; + + +return (1, @out); diff --git a/cmd/dbgetkey.pl b/cmd/dbgetkey.pl new file mode 100644 index 00000000..f48def42 --- /dev/null +++ b/cmd/dbgetkey.pl @@ -0,0 +1,31 @@ +#!/usr/bin/perl +# +# Database update routine +# +# Copyright (c) 1999 Dirk Koopman G1TLH +# +my ($self, $line) = @_; +my @f = split /\s+/, $line; +my @out; + +my $name = shift @f if @f; +my $db = DXDb::getdesc($name); +return (1, $self->msg('db3', $name)) unless $db; + +if ($db->remote) { + for (@f) { + my $n = DXDb::newstream($self->call); + DXProt::route(undef, $db->remote, DXProt::pc44($main::mycall, $db->remote, $n, uc $db->name,uc $_, $self->call)); + } +} else { + for (@f) { + my $value = $db->getkey($_); + if ($value) { + push @out, split /\n/, $value; + } else { + push @out, $self->msg('db2', $_, $db->{name}); + } + } +} + +return (1, @out); diff --git a/cmd/dbimport.pl b/cmd/dbimport.pl new file mode 100644 index 00000000..55d5e632 --- /dev/null +++ b/cmd/dbimport.pl @@ -0,0 +1,50 @@ +#!/usr/bin/perl +# +# Database update routine +# +# Copyright (c) 1999 Dirk Koopman G1TLH +# +my ($self, $line) = @_; +my ($name, $fn) = split /\s+/, $line; +my @out; + +return (1, $self->msg('e5')) if $self->priv < 9; + +my $db = DXDb::getdesc($name); +return (1, $self->msg('db3', $name)) unless $db; +return (1, $self->msg('db1', $db->remote )) if $db->remote; +return (1, $self->msg('e3', 'dbimport', $fn)) unless -e $fn; + +my $state = 0; +my $key; +my $value; +my $count; + +open(IMP, $fn) or return (1, "Cannot open $fn $!"); +while () { + chomp; + s/\r//g; + if ($state == 0) { + if (/^\&\&/) { + $state = 0; + next; + } + $key = uc $_; + $value = undef; + ++$state; + } elsif ($state == 1) { + if (/^\&\&/) { + if ($key =~ /^#/) { + } + $db->putkey($key, $value); + $state = 0; + $count++; + next; + } + $value .= $_ . "\n"; + } +} +close (IMP); + +push @out, $self->msg('db10', $count, $db->name); +return (1, @out); diff --git a/cmd/dbremove.pl b/cmd/dbremove.pl new file mode 100644 index 00000000..98cdfdf3 --- /dev/null +++ b/cmd/dbremove.pl @@ -0,0 +1,18 @@ +#!/usr/bin/perl +# +# Database update routine +# +# Copyright (c) 1999 Dirk Koopman G1TLH +# +my ($self, $line) = @_; +my ($name) = split /\s+/, $line; +my @out; + +return (1, $self->msg('e5')) if $self->priv < 9; +my $db = DXDb::getdesc($name); + +return (1, $self->msg('db3', $name)) unless $db; +$db->delete; +push @out, $self->msg('db9', $name); + +return (1, @out); diff --git a/cmd/dbupdate.pl b/cmd/dbupdate.pl new file mode 100644 index 00000000..34198bfa --- /dev/null +++ b/cmd/dbupdate.pl @@ -0,0 +1,12 @@ +#!/usr/bin/perl +# +# Database update routine +# +# Copyright (c) 1999 Dirk Koopman G1TLH +# +my ($self, $line) = @_; +my @f = split /\s+/, $line; +my @out; + + +return (1, @out); diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index b7f8e8f4..13286cc5 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -242,7 +242,11 @@ sub run_cmd $Cache{$package}->{sub} = $c; } $c = $Cache{$package}->{sub}; - @ans = &{$c}($self, $args); + eval { + @ans = &{$c}($self, $args); + }; + + return ($@) if $@; } } else { dbg('command', "cmd: $cmd not found"); diff --git a/perl/DXDb.pm b/perl/DXDb.pm index 1641a840..49da69c9 100644 --- a/perl/DXDb.pm +++ b/perl/DXDb.pm @@ -5,5 +5,324 @@ # Copyright (c) 1999 Dirk Koopman G1TLH # +package DXDb; + +use strict; +use DXVars; +use DXLog; +use DXUtil; +use DB_File; + +use Carp; + +use vars qw($opentime $dbbase %avail %valid $lastprocesstime $nextstream %stream); + +$opentime = 5*60; # length of time a database stays open after last access +$dbbase = "$main::root/db"; # where all the databases are kept; +%avail = (); # The hash contains a list of all the databases +%valid = ( + accesst => '9,Last Access Time,atime', + createt => '9,Create Time,atime', + lastt => '9,Last Update Time,atime', + name => '0,Name', + db => '9,DB Tied hash', + remote => '0,Remote Database', + ); + +$lastprocesstime = time; +$nextstream = 0; +%stream = (); + +# allocate a new stream for this request +sub newstream +{ + my $call = uc shift; + my $n = ++$nextstream; + $stream{$n} = { n=>$n, call=>$call, t=>$main::systime }; + return $n; +} + +# delete a stream +sub delstream +{ + my $n = shift; + delete $stream{$n}; +} + +# get a stream +sub getstream +{ + my $n = shift; + return $stream{$n}; +} + +# load all the database descriptors +sub load +{ + my $s = readfilestr($dbbase, "dbs", "pl"); + if ($s) { + my $a = { eval $s } ; + confess $@ if $@; + %avail = %{$a} if $a + } +} + +# save all the database descriptors +sub save +{ + my $date = cldatetime($main::systime); + + writefilestr($dbbase, "dbs", "pl", \%avail, "#\n# database descriptor file\n# Don't alter this by hand unless you know what you are doing\n# last modified $date\n#\n"); +} + +# get the descriptor of the database you want. +sub getdesc +{ + return undef unless %avail; + + my $name = lc shift; + my $r = $avail{$name}; + + # search for a partial if not found direct + unless ($r) { + for (values %avail) { + if ($_->{name} =~ /^$name/) { + $r = $_; + last; + } + } + } + return $r; +} + +# open it +sub open +{ + my $self = shift; + $self->{accesst} = $main::systime; + return $self->{db} if $self->{db}; + my %hash; + $self->{db} = tie %hash, 'DB_File', "$dbbase/$self->{name}"; +# untie %hash; + return $self->{db}; +} + +# close it +sub close +{ + my $self = shift; + if ($self->{db}) { + untie $self->{db}; + } +} + +# close all +sub closeall +{ + if (%avail) { + for (values %avail) { + $_->close(); + } + } +} + +# get a value from the database +sub getkey +{ + my $self = shift; + my $key = uc shift; + my $value; + + # make sure we are open + $self->open; + if ($self->{db}) { + my $s = $self->{db}->get($key, $value); + return $s ? undef : $value; + } + return undef; +} + +# put a value to the database +sub putkey +{ + my $self = shift; + my $key = uc shift; + my $value = shift; + + # make sure we are open + $self->open; + if ($self->{db}) { + my $s = $self->{db}->put($key, $value); + return $s ? undef : 1; + } + return undef; +} + +# create a new database params: [] +sub new +{ + my $self = bless {}; + my $name = shift; + my $remote = shift; + $self->{name} = lc $name; + $self->{remote} = uc $remote if $remote; + $self->{accesst} = $self->{createt} = $self->{lastt} = $main::systime; + $avail{$self->{name}} = $self; + mkdir $dbbase, 02775 unless -e $dbbase; + save(); +} + +# delete a database +sub delete +{ + my $self = shift; + $self->close; + unlink "$dbbase/$self->{name}"; + delete $avail{$self->{name}}; + save(); +} + +# +# process intermediate lines for an update +# NOTE THAT THIS WILL BE CALLED FROM DXCommandmode and the +# object will be a DXChannel (actually DXCommandmode) +# +sub normal +{ + +} + +# +# periodic maintenance +# +# just close any things that haven't been accessed for the default +# time +# +# +sub process +{ + my ($dxchan, $line) = @_; + + # this is periodic processing + if (!$dxchan || !$line) { + if ($main::systime - $lastprocesstime >= 60) { + if (%avail) { + for (values %avail) { + if ($main::systime - $_->{accesst} > $opentime) { + $_->close; + } + } + } + $lastprocesstime = $main::systime; + } + return; + } + + my @f = split /\^/, $line; + my ($pcno) = $f[0] =~ /^PC(\d\d)/; # just get the number + + # route out ones that are not for us + if ($f[1] eq $main::mycall) { + ; + } else { + $dxchan->route($f[1], $line); + return; + } + + SWITCH: { + if ($pcno == 37) { # probably obsolete + last SWITCH; + } + + if ($pcno == 44) { # incoming DB Request + my $db = getdesc($f[4]); + if ($db) { + if ($db->{remote}) { + sendremote($dxchan, $f[2], $f[3], $dxchan->msg('dx1', $db->{remote})); + } else { + my $value = $db->getkey($f[5]); + if ($value) { + my @out = split /\n/, $value; + sendremote($dxchan, $f[2], $f[3], @out); + } else { + sendremote($dxchan, $f[2], $f[3], $dxchan->msg('dx2', $f[5], $db->{name})); + } + } + } else { + sendremote($dxchan, $f[2], $f[3], $dxchan->msg('dx3', $f[4])); + } + last SWITCH; + } + + if ($pcno == 45) { # incoming DB Information + my $n = getstream($f[3]); + if ($n) { + my $mchan = DXChannel->get($n->{call}); + $mchan->send($f[2] . ":$f[4]"); + } + last SWITCH; + } + + if ($pcno == 46) { # incoming DB Complete + delstream($f[3]); + last SWITCH; + } + + if ($pcno == 47) { # incoming DB Update request + last SWITCH; + } + + if ($pcno == 48) { # incoming DB Update request + last SWITCH; + } + } +} + +# send back a trache of data to the remote +# remember $dxchan is a dxchannel +sub sendremote +{ + my $dxchan = shift; + my $tonode = shift; + my $stream = shift; + + for (@_) { + $dxchan->send(DXProt::pc45($main::mycall, $tonode, $stream, $_)); + } + $dxchan->send(DXProt::pc46($main::mycall, $tonode, $stream)); +} + +# various access routines + +# +# return a list of valid elements +# + +sub fields +{ + return keys(%valid); +} + +# +# return a prompt for a field +# + +sub field_prompt +{ + my ($self, $ele) = @_; + return $valid{$ele}; +} + +no strict; +sub AUTOLOAD +{ + my $self = shift; + my $name = $AUTOLOAD; + return if $name =~ /::DESTROY$/; + $name =~ s/.*:://o; + + confess "Non-existant field '$AUTOLOAD'" if !$valid{$name}; + @_ ? $self->{$name} = shift : $self->{$name} ; +} 1; diff --git a/perl/DXMsg.pm b/perl/DXMsg.pm index bc6ed47e..9f4a1d7b 100644 --- a/perl/DXMsg.pm +++ b/perl/DXMsg.pm @@ -43,8 +43,8 @@ $maxage = 30 * 86400; # the maximum age that a message shall live for if not m $last_clean = 0; # last time we did a clean @forward = (); # msg forward table $timeout = 30*60; # forwarding timeout -$waittime = 60*60; # time an aborted outgoing message waits before trying again -$queueinterval = 2*60; # run the queue every 2 minutes +$waittime = 30*60; # time an aborted outgoing message waits before trying again +$queueinterval = 1*60; # run the queue every 1 minute $lastq = 0; @@ -130,21 +130,22 @@ sub process # this is periodic processing if (!$self || !$line) { - # wander down the work queue stopping any messages that have timed out - for (keys %busy) { - my $node = $_; - my $ref = $busy{$_}; - if (exists $ref->{lastt} && $main::systime > $ref->{lastt} + $timeout) { - dbg('msg', "Timeout, stopping msgno: $ref->{msgno} -> $node"); - $ref->stop_msg($node); + if ($main::systime > $lastq + $queueinterval) { - # delay any outgoing messages that fail - $ref->{waitt} = $main::systime + $waittime + rand(120) if $node ne $main::mycall; + # wander down the work queue stopping any messages that have timed out + for (keys %busy) { + my $node = $_; + my $ref = $busy{$_}; + if (exists $ref->{lastt} && $main::systime >= $ref->{lastt} + $timeout) { + dbg('msg', "Timeout, stopping msgno: $ref->{msgno} -> $node"); + $ref->stop_msg($node); + + # delay any outgoing messages that fail + $ref->{waitt} = $main::systime + $waittime + rand(120) if $node ne $main::mycall; + } } - } - # queue some message if the interval timer has gone off - if ($main::systime > $lastq + $queueinterval) { + # queue some message if the interval timer has gone off queue_msg(0); $lastq = $main::systime; } @@ -367,7 +368,6 @@ sub process $ref->stop_msg($self->call); $ref = undef; } - last SWITCH; } diff --git a/perl/DXProt.pm b/perl/DXProt.pm index 751daf04..e433fdc4 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -24,6 +24,7 @@ use DXProtout; use DXDebug; use Filter; use Local; +use DXDb; use Carp; @@ -670,11 +671,7 @@ sub normal last SWITCH; } if ($pcno == 37 || $pcno == 44 || $pcno == 45 || $pcno == 46 || $pcno == 47) { - if ($field[1] eq $main::mycall) { - ; - } else { - $self->route($field[1], $line); - } + DXDb::process($self, $line); return; } @@ -699,9 +696,11 @@ sub normal # it's a reply, look in the ping list for this one my $ref = $pings{$field[2]}; if ($ref) { - my $r = shift @$ref; - my $dxchan = DXChannel->get($r->{call}); - $dxchan->send($dxchan->msg('pingi', $field[2], atime($main::systime), $main::systime - $r->{t})) if $dxchan; + while (@$ref) { + my $r = shift @$ref; + my $dxchan = DXChannel->get($r->{call}); + $dxchan->send($dxchan->msg('pingi', $field[2], atime($main::systime), $main::systime - $r->{t})) if $dxchan; + } } } diff --git a/perl/DXProtout.pm b/perl/DXProtout.pm index 6df70ad7..887e0dcb 100644 --- a/perl/DXProtout.pm +++ b/perl/DXProtout.pm @@ -272,6 +272,28 @@ sub pc42 return "PC42^$fromnode^$tonode^$stream^"; } +# remote db request +sub pc44 +{ + my ($fromnode, $tonode, $stream, $db, $req, $call) = @_; + $db = uc $db; + return "PC44^$tonode^$fromnode^$stream^$db^$req^$call^"; +} + +# remote db data +sub pc45 +{ + my ($fromnode, $tonode, $stream, $data) = @_; + return "PC45^$tonode^$fromnode^$stream^$data^"; +} + +# remote db data complete +sub pc46 +{ + my ($fromnode, $tonode, $stream) = @_; + return "PC46^$tonode^$fromnode^$stream^"; +} + # bull delete sub pc49 { diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm index 7fae6317..d7ca5ed2 100644 --- a/perl/DXUtil.pm +++ b/perl/DXUtil.pm @@ -10,13 +10,14 @@ package DXUtil; use Date::Parse; use IO::File; +use Data::Dumper; use Carp; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(atime ztime cldate cldatetime slat slong yesno promptf - parray parraypairs shellregex readfilestr + parray parraypairs shellregex readfilestr writefilestr print_all_fields cltounix iscallsign ); @@ -204,22 +205,25 @@ sub readfilestr { my ($dir, $file, $suffix) = @_; my $fn; - + my $f; if ($suffix) { - $fn = "$dir/$file.$suffix"; + $f = uc $file; + $fn = "$dir/$f.$suffix"; unless (-e $fn) { - my $f = uc $file; + $f = lc $file; $fn = "$dir/$file.$suffix"; } } elsif ($file) { + $f = uc $file; $fn = "$dir/$file"; unless (-e $fn) { - my $f = uc $file; + $f = lc $file; $fn = "$dir/$file"; } } else { $fn = $dir; } + my $fh = new IO::File $fn; my $s = undef; if ($fh) { @@ -229,3 +233,46 @@ sub readfilestr } return $s; } + +# write out a file in the format required for reading +# in via readfilestr, it expects the same arguments +# and a reference to an object +sub writefilestr +{ + my $dir = shift; + my $file = shift; + my $suffix = shift; + my $obj = shift; + my $fn; + my $f; + + confess('no object to write in writefilestr') unless $obj; + confess('object not a reference in writefilestr') unless ref $obj; + + if ($suffix) { + $f = uc $file; + $fn = "$dir/$f.$suffix"; + unless (-e $fn) { + $f = lc $file; + $fn = "$dir/$file.$suffix"; + } + } elsif ($file) { + $f = uc $file; + $fn = "$dir/$file"; + unless (-e $fn) { + $f = lc $file; + $fn = "$dir/$file"; + } + } else { + $fn = $dir; + } + + my $fh = new IO::File ">$fn"; + my $dd = new Data::Dumper([ $obj ]); + $dd->Indent(1); + $dd->Terse(1); + $dd->Quotekeys(0); +# $fh->print(@_) if @_ > 0; # any header comments, lines etc + $fh->print($dd->Dumpxs); + $fh->close; +} diff --git a/perl/Messages b/perl/Messages index ae63bd01..f0932783 100644 --- a/perl/Messages +++ b/perl/Messages @@ -25,6 +25,16 @@ package DXM; constart => 'connection to $_[0] started', disc1 => 'Disconnected by $_[0]', disc2 => '$_[0] disconnected', + db1 => 'This database is hosted at $_[0]', + db2 => 'Key: $_[0] not found in $_[1]', + db3 => 'Sorry, database $_[0] doesn\'t exist here', + db4 => 'Sorry, database $_[0] located at $_[1] isn\'t currently online', + db5 => 'Accessing remote database on $_[0]...standby...', + db6 => 'Database $_[0] already exists, delete it first', + db7 => 'Database $_[0] created for remote node $_[1]', + db8 => 'Database $_[0] created locally', + db9 => 'Database $_[0] removed', + db10 => '$_[0] records imported into $_[1]', dx1 => 'Frequency $_[0] not in band (see show/band); usage: DX [BY call] freq call comments', dx2 => 'Need a callsign; usage: DX [BY call] freq call comments', dxs => 'DX Spots flag set on $_[0]', diff --git a/perl/cluster.pl b/perl/cluster.pl index c3f61038..8b45e2bd 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -178,6 +178,9 @@ sub cease }; dbg('local', "Local::finish error $@") if $@; + # close all databases + DXDb::closeall; + # disconnect users foreach $dxchan (DXChannel->get_all()) { next if $dxchan->is_ak1a; @@ -346,6 +349,10 @@ DXMsg::clean_old(); print "reading cron jobs ...\n"; DXCron->init(); +# read in database descriptors +print "reading database descriptors ...\n"; +DXDb::load(); + # starting local stuff print "doing local initialisation ...\n"; eval { @@ -375,6 +382,7 @@ for (;;) { DXProt::process(); # process ongoing ak1a pcxx stuff DXConnect::process(); DXMsg::process(); + DXDb::process(); eval { Local::process(); # do any localised processing }; -- 2.43.0