From d5b4190c36f130852973121042876af3c5642cd7 Mon Sep 17 00:00:00 2001 From: djk Date: Mon, 21 Dec 1998 23:49:08 +0000 Subject: [PATCH] 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. --- Changes | 13 +++ cmd/Commands_en.hlp | 13 ++- cmd/announce.pl | 4 +- cmd/show/heading.pl | 33 +++--- cmd/show/wwv.pl | 2 +- perl/DXChannel.pm | 18 ++- perl/DXCommandmode.pm | 12 +- perl/DXDebug.pm | 11 +- perl/DXProt.pm | 69 ++++++++++-- perl/DXUtil.pm | 2 +- perl/Geomag.pm | 32 ++++-- perl/Messages | 3 + perl/Prefix.pm | 250 +++++++++++++++++++++--------------------- perl/Spot.pm | 194 +++++++++++++++++--------------- perl/cluster.pl | 10 +- 15 files changed, 388 insertions(+), 278 deletions(-) diff --git a/Changes b/Changes index c8f8ee15..58f0b328 100644 --- a/Changes +++ b/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. diff --git a/cmd/Commands_en.hlp b/cmd/Commands_en.hlp index 80f2765a..368d57d5 100644 --- a/cmd/Commands_en.hlp +++ b/cmd/Commands_en.hlp @@ -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 [/]^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 ^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 ^Stop a callsign connecting to the cluster -=== 0^UNSET/LOCKOUT ^Allow a callsign to connect to the cluster +=== 9^SET/LOCKOUT ^Stop a callsign connecting to the cluster +=== 9^UNSET/LOCKOUT ^Allow a callsign to connect to the cluster === 0^SET/NAME ^Set your name Tell the system what your name is eg:- diff --git a/cmd/announce.pl b/cmd/announce.pl index b839e9c7..6c66bcd0 100644 --- a/cmd/announce.pl +++ b/cmd/announce.pl @@ -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); diff --git a/cmd/show/heading.pl b/cmd/show/heading.pl index aa7bb2f8..122ed5e4 100644 --- a/cmd/show/heading.pl +++ b/cmd/show/heading.pl @@ -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); diff --git a/cmd/show/wwv.pl b/cmd/show/wwv.pl index a8e4992a..ed5022d7 100644 --- a/cmd/show/wwv.pl +++ b/cmd/show/wwv.pl @@ -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; } } diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index 7319344c..8f641a44 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -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; } diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index e8fd7d5a..1450a6c6 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -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 = ; + 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); diff --git a/perl/DXDebug.pm b/perl/DXDebug.pm index c03f92af..e19f309c 100644 --- a/perl/DXDebug.pm +++ b/perl/DXDebug.pm @@ -29,13 +29,14 @@ sub dbg { my $l = shift; if ($dbglevel{$l}) { - for (@_) { - s/\n$//og; + my @in = @_; + my $t = time; + for (@in) { + s/\n$//o; s/\a//og; # beeps + print "$_\n" if defined \*STDOUT; + $fp->writeunix($t, "$t^$_"); } - print "@_\n" if defined \*STDOUT; - my $t = time; - $fp->writeunix($t, "$t^@_"); } } diff --git a/perl/DXProt.pm b/perl/DXProt.pm index 15466e36..c1fad111 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -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; } diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm index 5c6c51af..994cdd98 100644 --- a/perl/DXUtil.pm +++ b/perl/DXUtil.pm @@ -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; } diff --git a/perl/Geomag.pm b/perl/Geomag.pm index a63d19b6..3ee01361 100644 --- a/perl/Geomag.pm +++ b/perl/Geomag.pm @@ -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__; diff --git a/perl/Messages b/perl/Messages index 26bf7fa8..e43667bf 100644 --- a/perl/Messages +++ b/perl/Messages @@ -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 ', 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 ', namee2 => 'Can\'t find user $_[0]!', name => 'Your name is now \"$_[0]\"', diff --git a/perl/Prefix.pm b/perl/Prefix.pm index cab54cd8..ba9ea2b9 100644 --- a/perl/Prefix.pm +++ b/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 ($!)"; - - # 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; + $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 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); - - # 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; + # 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; - # 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; diff --git a/perl/Spot.pm b/perl/Spot.pm index 7fb1c227..b8938bb9 100644 --- a/perl/Spot.pm +++ b/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 + 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"); + 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; + # 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 $@; + 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; + 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; diff --git a/perl/cluster.pl b/perl/cluster.pl index 32f90d88..26f3b97a 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -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); -- 2.43.0