mirror of
git://scm.dxcluster.org/scm/spider
synced 2024-09-21 07:47:10 +00:00
1. fixed problem with missing DXDebug in DXProt.
2. Fixed DXDebug so that it actually works as advertised with and without trailing \n. 3. Added deduping of WWV spots as well (at for date,time,sfi,k and i) dups 4. Replaced the 0 in "02-Dec-1998" with ' ' so it reads " 2-Dec-1998", it seems hard to credit it but some 'programs' out there that connect to clusters have problems with the leading '0'! 5. In the same vain, included a strictly AK1A compatible sh/heading, apparently this is necessary for the same reason as 4. 6. Started contrib tree stored the old show/heading in contrib/g0rdi/show. 7. Because I now correctly dedupe spots and wwv (there's a hostage to fortune..) I have added a merge command.
This commit is contained in:
djk
parent
4c0591c17b
commit
d5b4190c36
13
Changes
13
Changes
@ -1,3 +1,16 @@
|
||||
21Dec98============= late! ====================================================
|
||||
1. fixed problem with missing DXDebug in DXProt.
|
||||
2. Fixed DXDebug so that it actually works as advertised with and without
|
||||
trailing \n.
|
||||
3. Added deduping of WWV spots as well (at for date,time,sfi,k and i) dups
|
||||
4. Replaced the 0 in "02-Dec-1998" with ' ' so it reads " 2-Dec-1998", it seems
|
||||
hard to credit it but some 'programs' out there that connect to clusters have
|
||||
problems with the leading '0'!
|
||||
5. In the same vain, included a strictly AK1A compatible sh/heading, apparently
|
||||
this is necessary for the same reason as 4.
|
||||
6. Started contrib tree stored the old show/heading in contrib/g0rdi/show.
|
||||
7. Because I now correctly dedupe spots and wwv (there's a hostage to fortune..)
|
||||
I have added a merge command.
|
||||
21Dec98========================================================================
|
||||
1. Added "issue" to the client program for 'login' connections
|
||||
2. Added more docs for client program.
|
||||
|
||||
@ -139,6 +139,15 @@ this command. You can remove more than one message at a time.
|
||||
=== 5^KILL-^
|
||||
As a sysop you can kill any message on the system.
|
||||
|
||||
=== 5^MERGE <node> [<no spots>/<no wwv>]^Ask for the latest spots and WWV
|
||||
MERGE allows you to bring your spot and wwv database up to date. By default
|
||||
it will request the last 10 spots and 5 WWVs from the node you select. The
|
||||
node must be connected locally.
|
||||
|
||||
You can request any number of spots or wwv and although they will be appended
|
||||
to your databases they will not duplicate any that have recently been added
|
||||
(the last 2 days for spots and last month for WWV data).
|
||||
|
||||
=== 8^PC <call> <text>^Send arbitrary text to a connected callsign
|
||||
Send any text you like to the callsign requested. This is used mainly to send
|
||||
PC protocol to connected nodes either for testing or to unstick things.
|
||||
@ -243,8 +252,8 @@ what your latitude and longitude is. If you have not yet done a SET/QRA
|
||||
then this command will set your QRA locator for you. For example:-
|
||||
SET/LOCATION 52 22 N 0 57 E
|
||||
|
||||
=== 0^SET/LOCKOUT <call>^Stop a callsign connecting to the cluster
|
||||
=== 0^UNSET/LOCKOUT <call>^Allow a callsign to connect to the cluster
|
||||
=== 9^SET/LOCKOUT <call>^Stop a callsign connecting to the cluster
|
||||
=== 9^UNSET/LOCKOUT <call>^Allow a callsign to connect to the cluster
|
||||
|
||||
=== 0^SET/NAME <your name>^Set your name
|
||||
Tell the system what your name is eg:-
|
||||
|
||||
@ -39,10 +39,8 @@ if ($sort eq "FULL") {
|
||||
} elsif ($sort eq "LOCAL") {
|
||||
$line =~ s/^$f[0]\s+//; # remove it
|
||||
$to = "LOCAL";
|
||||
} elsif ($sort eq "") {
|
||||
$to = "LOCAL";
|
||||
} else {
|
||||
return (1, $self->msg('e11'));
|
||||
$to = "LOCAL";
|
||||
}
|
||||
|
||||
Log('ann', $to, $from, $line);
|
||||
|
||||
@ -3,32 +3,33 @@
|
||||
#
|
||||
# $Id$
|
||||
#
|
||||
|
||||
# AK1A-compatible output Iain Philipps, G0RDI 16-Dec-1998
|
||||
#
|
||||
my ($self, $line) = @_;
|
||||
my @list = split /\s+/, $line; # generate a list of callsigns
|
||||
my @list = split /\s+/, $line; # generate a list of callsigns
|
||||
|
||||
my $l;
|
||||
my @out;
|
||||
my $lat = $self->user->lat;
|
||||
my $long = $self->user->long;
|
||||
if (!$long && !$lat) {
|
||||
push @out, $self->msg('heade1');
|
||||
$lat = $main::mylatitude;
|
||||
$long = $main::mylongitude;
|
||||
push @out, $self->msg('heade1');
|
||||
$lat = $main::mylatitude;
|
||||
$long = $main::mylongitude;
|
||||
}
|
||||
|
||||
foreach $l (@list) {
|
||||
# prefixes --->
|
||||
my @ans = Prefix::extract($l);
|
||||
next if !@ans;
|
||||
my $pre = shift @ans;
|
||||
my $a;
|
||||
foreach $a (@ans) {
|
||||
my ($b, $dx) = DXBearing::bdist($lat, $long, $a->{lat}, $a->{long});
|
||||
my ($r, $rdx) = DXBearing::bdist($a->{lat}, $a->{long}, $lat, $long);
|
||||
push @out, sprintf "%-9s (%s, %s) Bearing: %.0f Recip: %.0f %.0fKm %.0fMi", uc $l, $pre, $a->name(), $b, $r, $dx, $dx * 0.62133785;
|
||||
$l = "";
|
||||
}
|
||||
# prefixes --->
|
||||
my @ans = Prefix::extract($l);
|
||||
next if !@ans;
|
||||
my $pre = shift @ans;
|
||||
my $a;
|
||||
foreach $a (@ans) {
|
||||
my ($b, $dx) = DXBearing::bdist($lat, $long, $a->{lat}, $a->{long});
|
||||
my ($r, $rdx) = DXBearing::bdist($a->{lat}, $a->{long}, $lat, $long);
|
||||
push @out, sprintf "%-2s %s: %.0f degs - dist: %.0f mi, %.0f km Reciprocal heading: %.0f degs", $pre, $a->name(), $b, $dx * 0.62133785, $dx, $r;
|
||||
$l = "";
|
||||
}
|
||||
}
|
||||
|
||||
return (1, @out);
|
||||
|
||||
@ -21,7 +21,7 @@ while ($f = shift @f) { # next field
|
||||
next if $from && $to > $from;
|
||||
}
|
||||
if (!$to) {
|
||||
($to) = $f =~ /^(\d+)$/o if !$to; # is it a to count?
|
||||
($to) = $f =~ /^(\d+)$/o; # is it a to count?
|
||||
next if $to;
|
||||
}
|
||||
}
|
||||
|
||||
@ -156,12 +156,11 @@ sub send_now
|
||||
my $conn = $self->{conn};
|
||||
my $sort = shift;
|
||||
my $call = $self->{call};
|
||||
my $line;
|
||||
|
||||
foreach $line (@_) {
|
||||
chomp $line;
|
||||
$conn->send_now("$sort$call|$line") if $conn;
|
||||
dbg('chan', "-> $sort $call $line") if $conn;
|
||||
for (@_) {
|
||||
chomp;
|
||||
$conn->send_now("$sort$call|$_") if $conn;
|
||||
dbg('chan', "-> $sort $call $_") if $conn;
|
||||
}
|
||||
$self->{t} = time;
|
||||
}
|
||||
@ -174,12 +173,11 @@ sub send # this is always later and always data
|
||||
my $self = shift;
|
||||
my $conn = $self->{conn};
|
||||
my $call = $self->{call};
|
||||
my $line;
|
||||
|
||||
foreach $line (@_) {
|
||||
chomp $line;
|
||||
$conn->send_later("D$call|$line") if $conn;
|
||||
dbg('chan', "-> D $call $line") if $conn;
|
||||
for (@_) {
|
||||
chomp;
|
||||
$conn->send_later("D$call|$_") if $conn;
|
||||
dbg('chan', "-> D $call $_") if $conn;
|
||||
}
|
||||
$self->{t} = time;
|
||||
}
|
||||
|
||||
@ -258,12 +258,20 @@ sub finish
|
||||
{
|
||||
my $self = shift;
|
||||
my $call = $self->call;
|
||||
|
||||
|
||||
# log out text
|
||||
if (-e "$main::data/logout") {
|
||||
open(I, "$main::data/logout") or confess;
|
||||
my @in = <I>;
|
||||
close(I);
|
||||
$self->sendnow('D', @in);
|
||||
}
|
||||
|
||||
if ($call eq $main::myalias) { # unset the channel if it is us really
|
||||
my $node = DXNode->get($main::mycall);
|
||||
$node->{dxchan} = 0;
|
||||
}
|
||||
my $ref = DXNodeuser->get($call);
|
||||
my $ref = DXCluster->get_exact($call);
|
||||
|
||||
# issue a pc17 to everybody interested
|
||||
my $nchan = DXChannel->get($main::mycall);
|
||||
|
||||
@ -29,13 +29,14 @@ sub dbg
|
||||
{
|
||||
my $l = shift;
|
||||
if ($dbglevel{$l}) {
|
||||
for (@_) {
|
||||
s/\n$//og;
|
||||
s/\a//og; # beeps
|
||||
}
|
||||
print "@_\n" if defined \*STDOUT;
|
||||
my @in = @_;
|
||||
my $t = time;
|
||||
$fp->writeunix($t, "$t^@_");
|
||||
for (@in) {
|
||||
s/\n$//o;
|
||||
s/\a//og; # beeps
|
||||
print "$_\n" if defined \*STDOUT;
|
||||
$fp->writeunix($t, "$t^$_");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
@ -21,15 +21,18 @@ use DXCommandmode;
|
||||
use DXLog;
|
||||
use Spot;
|
||||
use DXProtout;
|
||||
use DXDebug;
|
||||
use Carp;
|
||||
|
||||
use strict;
|
||||
use vars qw($me $pc11_max_age $pc11_dup_age %dup $last_hour %pings %rcmds %nodehops);
|
||||
use vars qw($me $pc11_max_age $pc11_dup_age $pc23_dup_age %spotdup %wwvdup $last_hour %pings %rcmds %nodehops);
|
||||
|
||||
$me = undef; # the channel id for this cluster
|
||||
$pc11_max_age = 1*3600; # the maximum age for an incoming 'real-time' pc11
|
||||
$pc11_dup_age = 24*3600; # the maximum time to keep the dup list for
|
||||
%dup = (); # the pc11 and 26 dup hash
|
||||
$pc11_dup_age = 24*3600; # the maximum time to keep the spot dup list for
|
||||
$pc23_dup_age = 24*3600; # the maximum time to keep the wwv dup list for
|
||||
%spotdup = (); # the pc11 and 26 dup hash
|
||||
%wwvdup = (); # the pc23 and 27 dup hash
|
||||
$last_hour = time; # last time I did an hourly periodic update
|
||||
%pings = (); # outstanding ping requests outbound
|
||||
%rcmds = (); # outstanding rcmd requests outbound
|
||||
@ -46,6 +49,24 @@ sub init
|
||||
do "$main::data/hop_table.pl" if -e "$main::data/hop_table.pl";
|
||||
confess $@ if $@;
|
||||
# $me->{sort} = 'M'; # M for me
|
||||
|
||||
# now prime the spot duplicates file with today's and yesterday's data
|
||||
my @today = Julian::unixtoj(time);
|
||||
my @spots = Spot::readfile(@today);
|
||||
@today = Julian::sub(@today, 1);
|
||||
push @spots, Spot::readfile(@today);
|
||||
for (@spots) {
|
||||
my $dupkey = "$_->[0]$_->[1]$_->[2]$_->[3]$_->[4]";
|
||||
$spotdup{$dupkey} = $_->[2];
|
||||
}
|
||||
|
||||
# now prime the wwv duplicates file with just this month's data
|
||||
my @wwv = Geomag::readfile(time);
|
||||
for (@wwv) {
|
||||
my $dupkey = "$_->[1].$_->[2]$_->[3]$_->[4]";
|
||||
$wwvdup{$dupkey} = $_->[1];
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
#
|
||||
@ -135,7 +156,7 @@ sub normal
|
||||
my $d = cltounix($field[3], $field[4]);
|
||||
# bang out (and don't pass on) if date is invalid or the spot is too old
|
||||
if (!$d || ($pcno == 11 && $d < $main::systime - $pc11_max_age)) {
|
||||
dbg('chan', "Spot ignored, invalid date or too old");
|
||||
dbg('chan', "Spot ignored, invalid date or too old\n");
|
||||
return;
|
||||
}
|
||||
|
||||
@ -147,21 +168,25 @@ sub normal
|
||||
$spotter =~ s/-\d+$//o; # strip off the ssid from the spotter
|
||||
|
||||
# do some de-duping
|
||||
my $dupkey = "$field[1]$field[2]$d$text$field[6]";
|
||||
if ($dup{$dupkey}) {
|
||||
dbg('chan', "Duplicate Spot ignored");
|
||||
my $freq = $field[1] - 0;
|
||||
my $dupkey = "$freq$field[2]$d$text$spotter";
|
||||
if ($spotdup{$dupkey}) {
|
||||
dbg('chan', "Duplicate Spot ignored\n");
|
||||
return;
|
||||
}
|
||||
|
||||
$dup{$dupkey} = $d;
|
||||
$spotdup{$dupkey} = $d;
|
||||
|
||||
my $spot = Spot::add($field[1], $field[2], $d, $text, $spotter);
|
||||
my $spot = Spot::add($freq, $field[2], $d, $text, $spotter);
|
||||
|
||||
# send orf to the users
|
||||
if ($spot && $pcno == 11) {
|
||||
my $buf = Spot::formatb($field[1], $field[2], $d, $text, $spotter);
|
||||
broadcast_users("$buf\a\a");
|
||||
}
|
||||
|
||||
# DON'T be silly and send on PC26s!
|
||||
return if $pcno == 26;
|
||||
|
||||
last SWITCH;
|
||||
}
|
||||
@ -328,7 +353,23 @@ sub normal
|
||||
}
|
||||
|
||||
if ($pcno == 23 || $pcno == 27) { # WWV info
|
||||
Geomag::update(@field[1..$#field]);
|
||||
# do some de-duping
|
||||
my $d = cltounix($field[1], sprintf("%02d18Z", $field[2]));
|
||||
my $sfi = unpad($field[3]);
|
||||
my $k = unpad($field[4]);
|
||||
my $i = unpad($field[5]);
|
||||
my $dupkey = "$d.$sfi$k$i";
|
||||
if ($wwvdup{$dupkey}) {
|
||||
dbg('chan', "Dup WWV Spot ignored\n");
|
||||
return;
|
||||
}
|
||||
|
||||
$wwvdup{$dupkey} = $d;
|
||||
Geomag::update($field[1], $field[2], $sfi, $k, $i, @field[6..$#field]);
|
||||
|
||||
# DON'T be silly and send on PC27s!
|
||||
return if $pcno == 27;
|
||||
|
||||
last SWITCH;
|
||||
}
|
||||
|
||||
@ -512,8 +553,12 @@ sub process
|
||||
my $cutoff;
|
||||
if ($main::systime - 3600 > $last_hour) {
|
||||
$cutoff = $main::systime - $pc11_dup_age;
|
||||
while (($key, $val) = each %dup) {
|
||||
delete $dup{$key} if $val < $cutoff;
|
||||
while (($key, $val) = each %spotdup) {
|
||||
delete $spotdup{$key} if $val < $cutoff;
|
||||
}
|
||||
$cutoff = $main::systime - $pc23_dup_age;
|
||||
while (($key, $val) = each %wwvdup) {
|
||||
delete $wwvdup{$key} if $val < $cutoff;
|
||||
}
|
||||
$last_hour = $main::systime;
|
||||
}
|
||||
|
||||
@ -46,7 +46,7 @@ sub cldate
|
||||
my $t = shift;
|
||||
my ($sec,$min,$hour,$mday,$mon,$year) = gmtime((defined $t) ? $t : time);
|
||||
$year += 1900;
|
||||
my $buf = sprintf "%02d-%s-%04d", $mday, $month[$mon], $year;
|
||||
my $buf = sprintf "%2d-%s-%04d", $mday, $month[$mon], $year;
|
||||
return $buf;
|
||||
}
|
||||
|
||||
|
||||
@ -142,13 +142,11 @@ sub forecast
|
||||
#
|
||||
sub print
|
||||
{
|
||||
my $self = $fp;
|
||||
my $from = shift;
|
||||
my $to = shift;
|
||||
my @date = $self->unixtoj(shift);
|
||||
my @date = $fp->unixtoj(shift);
|
||||
my $pattern = shift;
|
||||
my $search;
|
||||
my @in;
|
||||
my @out;
|
||||
my $eval;
|
||||
my $count;
|
||||
@ -161,19 +159,19 @@ sub print
|
||||
\$ref = \$in[\$c];
|
||||
if ($search) {
|
||||
\$count++;
|
||||
next if \$count < $from;
|
||||
next if \$count < \$from;
|
||||
push \@out, print_item(\$ref);
|
||||
last LOOP if \$count >= \$to; # stop after n
|
||||
}
|
||||
}
|
||||
);
|
||||
|
||||
$self->close; # close any open files
|
||||
$fp->close; # close any open files
|
||||
|
||||
my $fh = $self->open(@date);
|
||||
my $fh = $fp->open(@date);
|
||||
LOOP:
|
||||
while ($count < $to) {
|
||||
my @spots = ();
|
||||
my @in = ();
|
||||
if ($fh) {
|
||||
while (<$fh>) {
|
||||
chomp;
|
||||
@ -182,7 +180,7 @@ LOOP:
|
||||
eval $eval; # do the search on this file
|
||||
return ("Spot search error", $@) if $@;
|
||||
}
|
||||
$fh = $self->openprev(); # get the next file
|
||||
$fh = $fp->openprev(); # get the next file
|
||||
last if !$fh;
|
||||
}
|
||||
|
||||
@ -209,5 +207,23 @@ sub print_item
|
||||
return sprintf("$d %02d %5d %3d %3d %-37s <%s>", $t, $ref[2], $ref[3], $ref[4], $ref[5], $ref[0]);
|
||||
}
|
||||
|
||||
#
|
||||
# read in this month's data
|
||||
#
|
||||
sub readfile
|
||||
{
|
||||
my @date = $fp->unixtoj(shift);
|
||||
my $fh = $fp->open(@date);
|
||||
my @spots = ();
|
||||
my @in;
|
||||
|
||||
if ($fh) {
|
||||
while (<$fh>) {
|
||||
chomp;
|
||||
push @in, [ split '\^' ] if length > 2;
|
||||
}
|
||||
}
|
||||
return @in;
|
||||
}
|
||||
1;
|
||||
__END__;
|
||||
|
||||
@ -39,6 +39,8 @@ package DXM;
|
||||
e8 => 'Need a callsign and some text',
|
||||
e9 => 'Need at least some text',
|
||||
e10 => '$_[0] not connected locally',
|
||||
e12 => 'Need a node callsign',
|
||||
e13 => '$_[0] is not a node',
|
||||
emaile1 => 'Please enter your email address, set/email <your e-mail address>',
|
||||
emaila => 'Your E-Mail Address is now \"$_[0]\"',
|
||||
email => 'E-mail address set to: $_[0]',
|
||||
@ -63,6 +65,7 @@ package DXM;
|
||||
lockout => '$_[0] Locked out',
|
||||
lockoutun => '$_[0] Unlocked',
|
||||
m2 => '$_[0] Information: $_[1]',
|
||||
merge1 => 'Merge request for $_[1] spots and $_[2] WWV sent to $_[0]',
|
||||
namee1 => 'Please enter your name, set/name <your name>',
|
||||
namee2 => 'Can\'t find user $_[0]!',
|
||||
name => 'Your name is now \"$_[0]\"',
|
||||
|
||||
244
perl/Prefix.pm
244
perl/Prefix.pm
@ -17,66 +17,66 @@ use Carp;
|
||||
use strict;
|
||||
use vars qw($db %prefix_loc %pre);
|
||||
|
||||
$db = undef; # the DB_File handle
|
||||
%prefix_loc = (); # the meat of the info
|
||||
%pre = (); # the prefix list
|
||||
$db = undef; # the DB_File handle
|
||||
%prefix_loc = (); # the meat of the info
|
||||
%pre = (); # the prefix list
|
||||
|
||||
sub load
|
||||
{
|
||||
if ($db) {
|
||||
untie %pre;
|
||||
%pre = ();
|
||||
%prefix_loc = ();
|
||||
}
|
||||
$db = tie(%pre, "DB_File", undef, O_RDWR|O_CREAT, 0666, $DB_BTREE) or confess "can't tie \%pre ($!)";
|
||||
my $out = $@ if $@;
|
||||
do "$main::data/prefix_data.pl" if !$out;
|
||||
$out = $@ if $@;
|
||||
# print Data::Dumper->Dump([\%pre, \%prefix_loc], [qw(pre prefix_loc)]);
|
||||
return $out;
|
||||
if ($db) {
|
||||
untie %pre;
|
||||
%pre = ();
|
||||
%prefix_loc = ();
|
||||
}
|
||||
$db = tie(%pre, "DB_File", undef, O_RDWR|O_CREAT, 0666, $DB_BTREE) or confess "can't tie \%pre ($!)";
|
||||
my $out = $@ if $@;
|
||||
do "$main::data/prefix_data.pl" if !$out;
|
||||
$out = $@ if $@;
|
||||
# print Data::Dumper->Dump([\%pre, \%prefix_loc], [qw(pre prefix_loc)]);
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub store
|
||||
{
|
||||
my ($k, $l);
|
||||
my $fh = new FileHandle;
|
||||
my $fn = "$main::data/prefix_data.pl";
|
||||
my ($k, $l);
|
||||
my $fh = new FileHandle;
|
||||
my $fn = "$main::data/prefix_data.pl";
|
||||
|
||||
confess "Prefix system not started" if !$db;
|
||||
confess "Prefix system not started" if !$db;
|
||||
|
||||
# save versions!
|
||||
rename "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo";
|
||||
rename "$fn.ooo", "$fn.oooo" if -e "$fn.ooo";
|
||||
rename "$fn.oo", "$fn.ooo" if -e "$fn.oo";
|
||||
rename "$fn.o", "$fn.oo" if -e "$fn.o";
|
||||
rename "$fn", "$fn.o" if -e "$fn";
|
||||
# save versions!
|
||||
rename "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo";
|
||||
rename "$fn.ooo", "$fn.oooo" if -e "$fn.ooo";
|
||||
rename "$fn.oo", "$fn.ooo" if -e "$fn.oo";
|
||||
rename "$fn.o", "$fn.oo" if -e "$fn.o";
|
||||
rename "$fn", "$fn.o" if -e "$fn";
|
||||
|
||||
$fh->open(">$fn") or die "Can't open $fn ($!)";
|
||||
$fh->open(">$fn") or die "Can't open $fn ($!)";
|
||||
|
||||
# prefix location data
|
||||
$fh->print("%prefix_loc = (\n");
|
||||
foreach $l (sort {$a <=> $b} keys %prefix_loc) {
|
||||
my $r = $prefix_loc{$l};
|
||||
$fh->printf(" $l => bless( { name => '%s', dxcc => %d, itu => %d, utcoff => %d, lat => %f, long => %f }, 'Prefix'),\n",
|
||||
$r->{name}, $r->{dxcc}, $r->{itu}, $r->{cq}, $r->{utcoff}, $r->{lat}, $r->{long});
|
||||
}
|
||||
$fh->print(");\n\n");
|
||||
# prefix location data
|
||||
$fh->print("%prefix_loc = (\n");
|
||||
foreach $l (sort {$a <=> $b} keys %prefix_loc) {
|
||||
my $r = $prefix_loc{$l};
|
||||
$fh->printf(" $l => bless( { name => '%s', dxcc => %d, itu => %d, utcoff => %d, lat => %f, long => %f }, 'Prefix'),\n",
|
||||
$r->{name}, $r->{dxcc}, $r->{itu}, $r->{cq}, $r->{utcoff}, $r->{lat}, $r->{long});
|
||||
}
|
||||
$fh->print(");\n\n");
|
||||
|
||||
# prefix data
|
||||
$fh->print("%pre = (\n");
|
||||
foreach $k (sort keys %pre) {
|
||||
$fh->print(" '$k' => [");
|
||||
my @list = @{$pre{$k}};
|
||||
my $l;
|
||||
my $str;
|
||||
foreach $l (@list) {
|
||||
$str .= " $l,";
|
||||
}
|
||||
chop $str;
|
||||
$fh->print("$str ],\n");
|
||||
}
|
||||
$fh->print(");\n");
|
||||
$fh->close;
|
||||
# prefix data
|
||||
$fh->print("%pre = (\n");
|
||||
foreach $k (sort keys %pre) {
|
||||
$fh->print(" '$k' => [");
|
||||
my @list = @{$pre{$k}};
|
||||
my $l;
|
||||
my $str;
|
||||
foreach $l (@list) {
|
||||
$str .= " $l,";
|
||||
}
|
||||
chop $str;
|
||||
$fh->print("$str ],\n");
|
||||
}
|
||||
$fh->print(");\n");
|
||||
$fh->close;
|
||||
}
|
||||
|
||||
# what you get is a list that looks like:-
|
||||
@ -88,18 +88,18 @@ sub store
|
||||
#
|
||||
sub get
|
||||
{
|
||||
my $key = shift;
|
||||
my @out;
|
||||
my @outref;
|
||||
my $ref;
|
||||
my $gotkey;
|
||||
my $key = shift;
|
||||
my @out;
|
||||
my @outref;
|
||||
my $ref;
|
||||
my $gotkey;
|
||||
|
||||
$gotkey = $key;
|
||||
return () if $db->seq($gotkey, $ref, R_CURSOR);
|
||||
return () if $key ne substr $gotkey, 0, length $key;
|
||||
$gotkey = $key;
|
||||
return () if $db->seq($gotkey, $ref, R_CURSOR);
|
||||
return () if $key ne substr $gotkey, 0, length $key;
|
||||
|
||||
@outref = map { $prefix_loc{$_} } split ',', $ref;
|
||||
return ($gotkey, @outref);
|
||||
@outref = map { $prefix_loc{$_} } split ',', $ref;
|
||||
return ($gotkey, @outref);
|
||||
}
|
||||
|
||||
#
|
||||
@ -108,17 +108,17 @@ sub get
|
||||
#
|
||||
sub next
|
||||
{
|
||||
my $key = shift;
|
||||
my @out;
|
||||
my @outref;
|
||||
my $ref;
|
||||
my $gotkey;
|
||||
my $key = shift;
|
||||
my @out;
|
||||
my @outref;
|
||||
my $ref;
|
||||
my $gotkey;
|
||||
|
||||
return () if $db->seq($gotkey, $ref, R_NEXT);
|
||||
return () if $key ne substr $gotkey, 0, length $key;
|
||||
return () if $db->seq($gotkey, $ref, R_NEXT);
|
||||
return () if $key ne substr $gotkey, 0, length $key;
|
||||
|
||||
@outref = map { $prefix_loc{$_} } split ',', $ref;
|
||||
return ($gotkey, @outref);
|
||||
@outref = map { $prefix_loc{$_} } split ',', $ref;
|
||||
return ($gotkey, @outref);
|
||||
}
|
||||
|
||||
#
|
||||
@ -131,75 +131,75 @@ sub next
|
||||
|
||||
sub extract
|
||||
{
|
||||
my $call = uc shift;
|
||||
my @out;
|
||||
my @nout;
|
||||
my $p;
|
||||
my @parts;
|
||||
my ($sp, $i);
|
||||
my $call = uc shift;
|
||||
my @out;
|
||||
my @nout;
|
||||
my $p;
|
||||
my @parts;
|
||||
my ($sp, $i);
|
||||
|
||||
# first check if the whole thing succeeds
|
||||
@out = get($call);
|
||||
return @out if @out > 0 && $out[0] eq $call;
|
||||
# first check if the whole thing succeeds
|
||||
@out = get($call);
|
||||
return @out if @out > 0 && $out[0] eq $call;
|
||||
|
||||
# now split the call into parts if required
|
||||
@parts = ($call =~ '/') ? split('/', $call) : ($call);
|
||||
# now split the call into parts if required
|
||||
@parts = ($call =~ '/') ? split('/', $call) : ($call);
|
||||
|
||||
# remove any /0-9 /P /A /M /MM /AM suffixes etc
|
||||
if (@parts > 1) {
|
||||
$p = $parts[$#parts];
|
||||
pop @parts if $p =~ /^(\d+|[PABM]|AM|MM|BCN|SIX|Q\w+)$/o;
|
||||
$p = $parts[$#parts];
|
||||
pop @parts if $p =~ /^(\d+|[PABM]|AM|MM|BCN|SIX|Q\w+)$/o;
|
||||
# remove any /0-9 /P /A /M /MM /AM suffixes etc
|
||||
if (@parts > 1) {
|
||||
$p = $parts[$#parts];
|
||||
pop @parts if $p =~ /^(\d+|[PABM]|AM|MM|BCN|SIX|Q\w+)$/o;
|
||||
$p = $parts[$#parts];
|
||||
pop @parts if $p =~ /^(\d+|[PABM]|AM|MM|BCN|SIX|Q\w+)$/o;
|
||||
|
||||
# can we resolve them by direct lookup
|
||||
foreach $p (@parts) {
|
||||
@out = get($p);
|
||||
return @out if @out > 0 && $out[0] eq $call;
|
||||
# can we resolve them by direct lookup
|
||||
foreach $p (@parts) {
|
||||
@out = get($p);
|
||||
return @out if @out > 0 && $out[0] eq $call;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# which is the shortest part (first if equal)?
|
||||
$sp = $parts[0];
|
||||
foreach $p (@parts) {
|
||||
$sp = $p if length $sp > length $p;
|
||||
}
|
||||
# now start to resolve it from the left hand end
|
||||
for (@out = (), $i = 1; $i <= length $sp; ++$i) {
|
||||
@nout = get(substr($sp, 0, $i));
|
||||
last if @nout > 0 && $nout[0] gt $sp;
|
||||
last if @nout == 0;
|
||||
@out = @nout;
|
||||
}
|
||||
# which is the shortest part (first if equal)?
|
||||
$sp = $parts[0];
|
||||
foreach $p (@parts) {
|
||||
$sp = $p if length $sp > length $p;
|
||||
}
|
||||
# now start to resolve it from the left hand end
|
||||
for (@out = (), $i = 1; $i <= length $sp; ++$i) {
|
||||
@nout = get(substr($sp, 0, $i));
|
||||
last if @nout > 0 && $nout[0] gt $sp;
|
||||
last if @nout == 0;
|
||||
@out = @nout;
|
||||
}
|
||||
|
||||
# not found
|
||||
return (@out > 0) ? @out : ();
|
||||
# not found
|
||||
return (@out > 0) ? @out : ();
|
||||
}
|
||||
|
||||
my %valid = (
|
||||
lat => '0,Latitude,slat',
|
||||
long => '0,Longitude,slong',
|
||||
dxcc => '0,DXCC',
|
||||
name => '0,Name',
|
||||
itu => '0,ITU',
|
||||
cq => '0,CQ',
|
||||
utcoff => '0,UTC offset',
|
||||
);
|
||||
lat => '0,Latitude,slat',
|
||||
long => '0,Longitude,slong',
|
||||
dxcc => '0,DXCC',
|
||||
name => '0,Name',
|
||||
itu => '0,ITU',
|
||||
cq => '0,CQ',
|
||||
utcoff => '0,UTC offset',
|
||||
);
|
||||
|
||||
no strict;
|
||||
sub AUTOLOAD
|
||||
{
|
||||
my $self = shift;
|
||||
my $name = $AUTOLOAD;
|
||||
my $self = shift;
|
||||
my $name = $AUTOLOAD;
|
||||
|
||||
return if $name =~ /::DESTROY$/;
|
||||
$name =~ s/.*:://o;
|
||||
return if $name =~ /::DESTROY$/;
|
||||
$name =~ s/.*:://o;
|
||||
|
||||
confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
|
||||
if (@_) {
|
||||
$self->{$name} = shift;
|
||||
}
|
||||
return $self->{$name};
|
||||
confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
|
||||
if (@_) {
|
||||
$self->{$name} = shift;
|
||||
}
|
||||
return $self->{$name};
|
||||
}
|
||||
use strict;
|
||||
|
||||
@ -209,8 +209,8 @@ use strict;
|
||||
|
||||
sub field_prompt
|
||||
{
|
||||
my ($self, $ele) = @_;
|
||||
return $valid{$ele};
|
||||
my ($self, $ele) = @_;
|
||||
return $valid{$ele};
|
||||
}
|
||||
1;
|
||||
|
||||
|
||||
200
perl/Spot.pm
200
perl/Spot.pm
@ -21,9 +21,9 @@ use strict;
|
||||
use vars qw($fp $maxspots $defaultspots $maxdays $dirprefix);
|
||||
|
||||
$fp = undef;
|
||||
$maxspots = 50; # maximum spots to return
|
||||
$defaultspots = 10; # normal number of spots to return
|
||||
$maxdays = 35; # normal maximum no of days to go back
|
||||
$maxspots = 50; # maximum spots to return
|
||||
$defaultspots = 10; # normal number of spots to return
|
||||
$maxdays = 35; # normal maximum no of days to go back
|
||||
$dirprefix = "spots";
|
||||
|
||||
sub init
|
||||
@ -34,32 +34,32 @@ sub init
|
||||
|
||||
sub prefix
|
||||
{
|
||||
return $fp->{prefix};
|
||||
return $fp->{prefix};
|
||||
}
|
||||
|
||||
# add a spot to the data file (call as Spot::add)
|
||||
sub add
|
||||
{
|
||||
my @spot = @_; # $freq, $call, $t, $comment, $spotter = @_
|
||||
my @spot = @_; # $freq, $call, $t, $comment, $spotter = @_
|
||||
|
||||
# sure that the numeric things are numeric now (saves time later)
|
||||
$spot[0] = 0 + $spot[0];
|
||||
$spot[2] = 0 + $spot[2];
|
||||
# sure that the numeric things are numeric now (saves time later)
|
||||
$spot[0] = 0 + $spot[0];
|
||||
$spot[2] = 0 + $spot[2];
|
||||
|
||||
# remove ssid if present on spotter
|
||||
$spot[4] =~ s/-\d+$//o;
|
||||
# remove ssid if present on spotter
|
||||
$spot[4] =~ s/-\d+$//o;
|
||||
|
||||
# add the 'dxcc' country on the end
|
||||
my @dxcc = Prefix::extract($spot[1]);
|
||||
push @spot, (@dxcc > 0 ) ? $dxcc[1]->dxcc() : 0;
|
||||
# add the 'dxcc' country on the end
|
||||
my @dxcc = Prefix::extract($spot[1]);
|
||||
push @spot, (@dxcc > 0 ) ? $dxcc[1]->dxcc() : 0;
|
||||
|
||||
my $buf = join("\^", @spot);
|
||||
my $buf = join("\^", @spot);
|
||||
|
||||
# compare dates to see whether need to open another save file (remember, redefining $fp
|
||||
# automagically closes the output file (if any)).
|
||||
$fp->writeunix($spot[2], $buf);
|
||||
# compare dates to see whether need to open another save file (remember, redefining $fp
|
||||
# automagically closes the output file (if any)).
|
||||
$fp->writeunix($spot[2], $buf);
|
||||
|
||||
return $buf;
|
||||
return $buf;
|
||||
}
|
||||
|
||||
# search the spot database for records based on the field no and an expression
|
||||
@ -86,93 +86,109 @@ sub add
|
||||
|
||||
sub search
|
||||
{
|
||||
my ($expr, $dayfrom, $dayto, $from, $to) = @_;
|
||||
my $eval;
|
||||
my @out;
|
||||
my $ref;
|
||||
my $i;
|
||||
my $count;
|
||||
my @today = Julian::unixtoj(time);
|
||||
my @fromdate;
|
||||
my @todate;
|
||||
my ($expr, $dayfrom, $dayto, $from, $to) = @_;
|
||||
my $eval;
|
||||
my @out;
|
||||
my $ref;
|
||||
my $i;
|
||||
my $count;
|
||||
my @today = Julian::unixtoj(time);
|
||||
my @fromdate;
|
||||
my @todate;
|
||||
|
||||
if ($dayfrom > 0) {
|
||||
@fromdate = Julian::sub(@today, $dayfrom);
|
||||
} else {
|
||||
@fromdate = @today;
|
||||
$dayfrom = 0;
|
||||
}
|
||||
if ($dayto > 0) {
|
||||
@todate = Julian::sub(@fromdate, $dayto);
|
||||
} else {
|
||||
@todate = Julian::sub(@fromdate, $maxdays);
|
||||
}
|
||||
if ($from || $to) {
|
||||
$to = $from + $maxspots if $to - $from > $maxspots || $to - $from <= 0;
|
||||
} else {
|
||||
$from = 0;
|
||||
$to = $defaultspots;
|
||||
}
|
||||
|
||||
$expr =~ s/\$f(\d)/\$ref->[$1]/g; # swap the letter n for the correct field name
|
||||
# $expr =~ s/\$f(\d)/\$spots[$1]/g; # swap the letter n for the correct field name
|
||||
|
||||
dbg("search", "expr='$expr', spotno=$from-$to, day=$dayfrom-$dayto\n");
|
||||
|
||||
# build up eval to execute
|
||||
$eval = qq(
|
||||
my \$c;
|
||||
my \$ref;
|
||||
for (\$c = \$#spots; \$c >= 0; \$c--) {
|
||||
\$ref = \$spots[\$c];
|
||||
if ($expr) {
|
||||
\$count++;
|
||||
next if \$count < \$from; # wait until from
|
||||
push(\@out, \$ref);
|
||||
last LOOP if \$count >= \$to; # stop after to
|
||||
}
|
||||
}
|
||||
);
|
||||
|
||||
$fp->close; # close any open files
|
||||
|
||||
LOOP:
|
||||
for ($i = 0; $i < $maxdays; ++$i) { # look thru $maxdays worth of files only
|
||||
my @now = Julian::sub(@fromdate, $i); # but you can pick which $maxdays worth
|
||||
last if Julian::cmp(@now, @todate) <= 0;
|
||||
|
||||
my @spots = ();
|
||||
my $fh = $fp->open(@now); # get the next file
|
||||
if ($fh) {
|
||||
my $in;
|
||||
while (<$fh>) {
|
||||
chomp;
|
||||
push @spots, [ split '\^' ];
|
||||
}
|
||||
eval $eval; # do the search on this file
|
||||
return ("Spot search error", $@) if $@;
|
||||
if ($dayfrom > 0) {
|
||||
@fromdate = Julian::sub(@today, $dayfrom);
|
||||
} else {
|
||||
@fromdate = @today;
|
||||
$dayfrom = 0;
|
||||
}
|
||||
if ($dayto > 0) {
|
||||
@todate = Julian::sub(@fromdate, $dayto);
|
||||
} else {
|
||||
@todate = Julian::sub(@fromdate, $maxdays);
|
||||
}
|
||||
if ($from || $to) {
|
||||
$to = $from + $maxspots if $to - $from > $maxspots || $to - $from <= 0;
|
||||
} else {
|
||||
$from = 0;
|
||||
$to = $defaultspots;
|
||||
}
|
||||
}
|
||||
|
||||
return @out;
|
||||
$expr =~ s/\$f(\d)/\$ref->[$1]/g; # swap the letter n for the correct field name
|
||||
# $expr =~ s/\$f(\d)/\$spots[$1]/g; # swap the letter n for the correct field name
|
||||
|
||||
dbg("search", "expr='$expr', spotno=$from-$to, day=$dayfrom-$dayto\n");
|
||||
|
||||
# build up eval to execute
|
||||
$eval = qq(
|
||||
my \$c;
|
||||
my \$ref;
|
||||
for (\$c = \$ #spots; \$c >= 0; \$c--) {
|
||||
\$ref = \$spots[\$c];
|
||||
if ($expr) {
|
||||
\$count++;
|
||||
next if \$count < \$from; # wait until from
|
||||
push(\@out, \$ref);
|
||||
last LOOP if \$count >= \$to; # stop after to
|
||||
}
|
||||
}
|
||||
);
|
||||
|
||||
$fp->close; # close any open files
|
||||
|
||||
LOOP:
|
||||
for ($i = 0; $i < $maxdays; ++$i) { # look thru $maxdays worth of files only
|
||||
my @now = Julian::sub(@fromdate, $i); # but you can pick which $maxdays worth
|
||||
last if Julian::cmp(@now, @todate) <= 0;
|
||||
|
||||
my @spots = ();
|
||||
my $fh = $fp->open(@now); # get the next file
|
||||
if ($fh) {
|
||||
my $in;
|
||||
while (<$fh>) {
|
||||
chomp;
|
||||
push @spots, [ split '\^' ];
|
||||
}
|
||||
eval $eval; # do the search on this file
|
||||
return ("Spot search error", $@) if $@;
|
||||
}
|
||||
}
|
||||
|
||||
return @out;
|
||||
}
|
||||
|
||||
# format a spot for user output in 'broadcast' mode
|
||||
sub formatb
|
||||
{
|
||||
my @dx = @_;
|
||||
my $t = ztime($dx[2]);
|
||||
return sprintf "DX de %-7.7s%11.1f %-12.12s %-30s %s", "$dx[4]:", $dx[0], $dx[1], $dx[3], $t ;
|
||||
my @dx = @_;
|
||||
my $t = ztime($dx[2]);
|
||||
return sprintf "DX de %-7.7s%11.1f %-12.12s %-30s %s", "$dx[4]:", $dx[0], $dx[1], $dx[3], $t ;
|
||||
}
|
||||
|
||||
# format a spot for user output in list mode
|
||||
sub formatl
|
||||
{
|
||||
my @dx = @_;
|
||||
my $t = ztime($dx[2]);
|
||||
my $d = cldate($dx[2]);
|
||||
return sprintf "%8.1f %-11s %s %s %-28.28s%7s>", $dx[0], $dx[1], $d, $t, $dx[3], "<$dx[4]" ;
|
||||
my @dx = @_;
|
||||
my $t = ztime($dx[2]);
|
||||
my $d = cldate($dx[2]);
|
||||
return sprintf "%8.1f %-11s %s %s %-28.28s%7s>", $dx[0], $dx[1], $d, $t, $dx[3], "<$dx[4]" ;
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# return all the spots from a day's file as an array of references
|
||||
# the parameter passed is a julian day
|
||||
sub readfile
|
||||
{
|
||||
my @spots;
|
||||
|
||||
my $fh = $fp->open(@_);
|
||||
if ($fh) {
|
||||
my $in;
|
||||
while (<$fh>) {
|
||||
chomp;
|
||||
push @spots, [ split '\^' ];
|
||||
}
|
||||
}
|
||||
return @spots;
|
||||
}
|
||||
1;
|
||||
|
||||
@ -50,7 +50,7 @@ package main;
|
||||
|
||||
@inqueue = (); # the main input queue, an array of hashes
|
||||
$systime = 0; # the time now (in seconds)
|
||||
$version = "1.13"; # the version no of the software
|
||||
$version = "1.14"; # the version no of the software
|
||||
$starttime = 0; # the starting time of the cluster
|
||||
|
||||
# handle disconnections
|
||||
@ -245,15 +245,17 @@ DXM->init();
|
||||
# read in command aliases
|
||||
CmdAlias->init();
|
||||
|
||||
# initialise the protocol engine
|
||||
DXProt->init();
|
||||
|
||||
# initialise the Geomagnetic data engine
|
||||
Geomag->init();
|
||||
|
||||
# initial the Spot stuff
|
||||
Spot->init();
|
||||
|
||||
# initialise the protocol engine
|
||||
print "reading in duplicate spot and WWV info ...\n";
|
||||
DXProt->init();
|
||||
|
||||
|
||||
# put in a DXCluster node for us here so we can add users and take them away
|
||||
DXNode->new(0, $mycall, 0, 1, $DXProt::myprot_version);
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user