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
%alias = (
'?' => [
- '^\?', 'help', 'help',
+ '^\?', 'apropos', 'apropos',
],
'a' => [
'^ann.*/full', 'announce full', 'announce',
--- /dev/null
+#!/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);
--- /dev/null
+#!/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);
--- /dev/null
+#!/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);
--- /dev/null
+#!/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);
--- /dev/null
+#!/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);
--- /dev/null
+#!/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);
--- /dev/null
+#!/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);
$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");
# 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;
$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;
# 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;
}
$ref->stop_msg($self->call);
$ref = undef;
}
-
last SWITCH;
}
use DXDebug;
use Filter;
use Local;
+use DXDb;
use Carp;
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;
}
# 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;
+ }
}
}
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
{
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
);
{
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) {
}
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;
+}
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]',
};
dbg('local', "Local::finish error $@") if $@;
+ # close all databases
+ DXDb::closeall;
+
# disconnect users
foreach $dxchan (DXChannel->get_all()) {
next if $dxchan->is_ak1a;
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 {
DXProt::process(); # process ongoing ak1a pcxx stuff
DXConnect::process();
DXMsg::process();
+ DXDb::process();
eval {
Local::process(); # do any localised processing
};
projects / spider.git / commitdiff