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

@@ -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

cmd/Aliases

@@ -23,7 +23,7 @@ package CmdAlias;
 
 %alias = (
     '?' => [
-	  '^\?', 'help', 'help',
+	  '^\?', 'apropos', 'apropos',
 	],
     'a' => [
 	  '^ann.*/full', 'announce full', 'announce', 

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);

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);

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);

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);

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 (<IMP>) {
+	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);

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);

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);

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");

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: <name> [<remote node call>]
+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;

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);
-
-				# 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) {
+
+			# 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
 			queue_msg(0);
 			$lastq = $main::systime;
 		}
@@ -367,7 +368,6 @@ sub process
 				$ref->stop_msg($self->call);
 				$ref = undef;
 			}
-			
 			last SWITCH;
 		}
 

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;
+						}
 					}
 				}
 				

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
 {

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;
+}

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]',

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
 		};