From: minima Date: Mon, 10 Mar 2003 23:34:26 +0000 (+0000) Subject: added builtin sh.qsl command X-Git-Tag: PRE-1-52~31 X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=commitdiff_plain;h=bcf2892aa7f3c9957ee61365a6e032dd93044834;p=spider.git added builtin sh.qsl command --- diff --git a/cmd/Commands_en.hlp b/cmd/Commands_en.hlp index db5742dd..fef7749a 100644 --- a/cmd/Commands_en.hlp +++ b/cmd/Commands_en.hlp @@ -2095,6 +2095,25 @@ is provided for users of this software by http://www.qrz.com See also SHOW/WM7D for an alternative. +=== 0^SHOW/QSL ^Show any QSL info gathered from spots +The node collects information from the comment fields in spots (things +like 'VIA EA7WA' or 'QSL-G1TLH') and stores these in a database. + +This command allows you to interrogate that database and if the callsign +is found will display the manager(s) that people have spotted. This +information is NOT reliable, but it is normally reasonably accurate if +it is spotted enough times. + +For example:- + + sh/qsl 4k9w + +You can check the raw input spots yourself with:- + + sh/dx 4k9w qsl + +This gives you more background information. + === 9^SHOW/REGISTERED []^Show the registered users === 0^SHOW/ROUTE ...^Show the route to the callsign diff --git a/cmd/load/qsl.pl b/cmd/load/qsl.pl new file mode 100644 index 00000000..ddf51d34 --- /dev/null +++ b/cmd/load/qsl.pl @@ -0,0 +1,7 @@ +# +# load the QSL file after changing it +# +my $self = shift; +return (1, $self->msg('e5')) if $self->priv < 9; +my $r = QSL::init(1); +return (1, $r ? $self->msg('ok') : $self->msg('e2', "$!")); diff --git a/cmd/show/node.pl b/cmd/show/node.pl index 53a974ca..46e0b32d 100644 --- a/cmd/show/node.pl +++ b/cmd/show/node.pl @@ -17,8 +17,6 @@ my ($self, $line) = @_; return (1, $self->msg('e5')) unless $self->priv >= 1; -use DB_File; - my @call = map {uc $_} split /\s+/, $line; my @out; my $count; diff --git a/cmd/show/qsl.pl b/cmd/show/qsl.pl new file mode 100644 index 00000000..082dc8ba --- /dev/null +++ b/cmd/show/qsl.pl @@ -0,0 +1,31 @@ +# +# Display QSL information from the local database +# +# Copyright (c) 2003 Dirk Koopman G1TLH +# +# $Id$ +# + +my ($self, $line) = @_; +my @call = split /\s+/, uc $line; +my @out; + +$DB::single=1; + +return (1, $self->msg('db3', 'QSL')) unless $QSL::dbm; + +push @out, $self->msg('qsl1'); +foreach my $call (@call) { + my $q = QSL::get($call); + if ($q) { + my $c = $call; + for (@{$q->[1]}) { + push @out, sprintf "%-14s %-10s %4d %s %s", $c, $_->[0], $_->[1], cldatetime($_->[2]), $_->[3]; + $c = ""; + } + } else { + push @out, $self->msg('db2', $call, 'QSL'); + } +} + +return (1, @out); diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index 5a53dc6e..270183bf 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -32,6 +32,8 @@ use Sun; use Internet; use Script; use Net::Telnet; +use QSL; +use DB_File; use strict; use vars qw(%Cache %cmd_cache $errstr %aliases $scriptbase $maxerrors %nothereslug $maxbadcount); diff --git a/perl/Messages b/perl/Messages index df00b3f6..34d92901 100644 --- a/perl/Messages +++ b/perl/Messages @@ -235,6 +235,7 @@ package DXM; qrashe1 => 'Please enter a QRA locator, eg sh/qra JO02LQ or sh/qra JO02LQ IO93NS', qrae2 => 'Don\'t recognise \"$_[0]\" as a QRA locator (eg JO02LQ)', qra => 'Your QRA Locator is now \"$_[0]\"', + qsl1 => 'Call Manager Times Last Time Seen De', rcmdo => 'RCMD \"$_[0]\" sent to $_[1]', read1 => 'Sorry, no new messages for you', read2 => 'Msg $_[0] not found', diff --git a/perl/QSL.pm b/perl/QSL.pm new file mode 100644 index 00000000..35117b1b --- /dev/null +++ b/perl/QSL.pm @@ -0,0 +1,98 @@ +#!/usr/bin/perl -w +# +# Local 'autoqsl' module for DXSpider +# +# Copyright (c) 2003 Dirk Koopman G1TLH +# + +package QSL; + +use strict; +use DXVars; +use DXUtil; +use DB_File; +use DXDebug; +use Storable qw(nfreeze thaw); + +use vars qw($VERSION $BRANCH); +$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); +$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0)); +$main::build += $VERSION; +$main::branch += $BRANCH; + +use vars qw($qslfn $dbm); +$qslfn = 'qsl'; +$dbm = undef; + +sub init +{ + my $mode = shift; + my $ufn = "$main::root/data/$qslfn.v1"; + + my %u; + if ($mode) { + $dbm = tie (%u, 'DB_File', $ufn, O_CREAT|O_RDWR, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)"; + } else { + $dbm = tie (%u, 'DB_File', $ufn, O_RDONLY, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)"; + } + return $dbm; +} + +sub finish +{ + undef $dbm; +} + +sub new +{ + my ($pkg, $call) = @_; + return bless [uc $call, []], $pkg; +} + +# the format of each entry is [manager, times found, last time] +sub update +{ + my $self = shift; + my $line = shift; + my $t = shift; + my $by = shift; + + my @tok = map {/^BUR/ || is_callsign($_) ? $_ : ()} split(/\b/, uc $line); + foreach my $man (@tok) { + $man = 'BUREAU' if $man =~ /^BUR/; + my ($r) = grep {$_->[0] eq $man} @{$self->[1]}; + if ($r) { + $r->[1]++; + if ($t > $r->[2]) { + $r->[2] = $t; + $r->[3] = $by; + } + } else { + $r = [$man, 1, $t, $by]; + push @{$self->[1]}, $r; + } + } + $self->put; +} + +sub get +{ + my $key = uc shift; + return undef unless $dbm; + my $value; + + my $r = $dbm->get($key, $value); + return undef if $r; + return thaw($value); +} + +sub put +{ + my $self = shift; + my $key = $self->[0]; + my $value = nfreeze($self); + $dbm->del($key); + $dbm->put($key, $value); +} + +1; diff --git a/perl/Spot.pm b/perl/Spot.pm index dc63dbff..4b0e7c72 100644 --- a/perl/Spot.pm +++ b/perl/Spot.pm @@ -17,6 +17,7 @@ use Julian; use Prefix; use DXDupe; use Data::Dumper; +use QSL; use strict; @@ -160,6 +161,10 @@ sub add } else { $vhfspots++; } + if ($_[3] =~ /(?:QSL|VIA)/i) { + my $q = QSL::get($_[1]) || new QSL $_[1]; + $q->update($_[3], $_[2], $_[4]); + } } # search the spot database for records based on the field no and an expression diff --git a/perl/cluster.pl b/perl/cluster.pl index c0050279..e786edb6 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -98,6 +98,7 @@ use Editable; use Mrtg; use USDB; use UDPMsg; +use QSL; use Data::Dumper; use IO::File; @@ -125,7 +126,7 @@ $reqreg = 0; # 1 = registration required, 2 = deregister people use vars qw($VERSION $BRANCH $build $branch); $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0)); -$main::build += 6; # add an offset to make it bigger than last system +$main::build += 5; # add an offset to make it bigger than last system $main::build += $VERSION; $main::branch += $BRANCH; @@ -522,6 +523,7 @@ DXDb::load(); # starting local stuff dbg("doing local initialisation ..."); +QSL::init(1) or die "Cannot open local QSL database"; eval { Local::init(); }; diff --git a/perl/create_localqsl.pl b/perl/create_localqsl.pl deleted file mode 100755 index e3f447f0..00000000 --- a/perl/create_localqsl.pl +++ /dev/null @@ -1,116 +0,0 @@ -#!/usr/bin/perl -# -# Implement a 'GO' database list -# -# Copyright (c) 2003 Dirk Koopman G1TLH -# -# $Id$ -# - -# search local then perl directories -BEGIN { - use vars qw($root); - - # root of directory tree for this system - $root = "/spider"; - $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'}; - - unshift @INC, "$root/perl"; # this IS the right way round! - unshift @INC, "$root/local"; -} - -use strict; - -use IO::File; -use DXVars; -use DXUtil; -use Spot; -use DXDb; - -use vars qw($end $lastyear $lastday); - -$end = 0; -$SIG{TERM} = $SIG{INT} = sub { $end++ }; - -my $qslfn = "localqsl"; -$lastyear = 0; -$lastday = 0; - -$main::systime = time; - -DXDb::load(); -my $db = DXDb::getdesc($qslfn); -unless ($db) { - DXDb::new($qslfn); - DXDb::load(); - $db = DXDb::getdesc($qslfn); -} -die "cannot load $qslfn $!" unless $db; - -# find start point (if any) -my $statefn = "$root/data/$qslfn.state"; -my $s = readfilestr($statefn); -eval $s if $s; - -my $base = "$root/data/spots"; - -opendir YEAR, $base or die "$base $!"; -foreach my $year (sort readdir YEAR) { - next if $year =~ /^\./; - next unless $year ge $lastyear; - - my $baseyear = "$base/$year"; - opendir DAY, $baseyear or die "$baseyear $!"; - foreach my $day (sort readdir DAY) { - next unless $day =~ /(\d+)\.dat$/; - my $dayno = $1 + 0; - next unless $dayno >= $lastday; - - my $fn = "$baseyear/$day"; - my $f = new IO::File $fn or die "$fn ($!)"; - print "doing: $fn\n"; - while (<$f>) { - if (/(QSL|VIA)/i) { - my ($freq, $call, $t, $comment, $by, @rest) = split /\^/; - my $value = $db->getkey($call) || ""; - my $newvalue = update($value, $call, $t, $comment, $by); - if ($newvalue ne $value) { - $db->putkey($call, $newvalue); - } - } - } - $f->close; - $f = new IO::File ">$statefn" or die "cannot open $statefn $!"; - print $f "\$lastyear = $year; \$lastday = $dayno;\n"; - $f->close; - } -} - -DXDb::closeall(); -exit(0); - -sub update -{ - my ($line, $call, $t, $comment, $by) = @_; - my @lines = split /\n/, $line; - my @in; - - # decode the lines - foreach my $l (@lines) { - my ($date, $time, $oby, $ocom) = $l =~ /^(\s?\S+)\s+(\s?\S+)\s+de\s+(\S+):\s+(.*)$/; - if ($date) { - my $ot = cltounix($date, $time); - push @in, [$ot, $oby, $ocom]; - } - } - - # is this newer than the earliest one? - if (@in && $in[0]->[0] < $t) { - @in = grep {$_->[1] ne $by} @in; - } - $comment =~ s/://g; - unshift @in, [$t, $by, $comment] if grep /^bur/i || is_callsign(uc $_), split(/\b/, $comment); - pop @in, if @in > 10; - return join "\n", (map {(cldatetime($_->[0]) . " de $_->[1]: $_->[2]")} @in); -} -