2003-03-10 23:34:26 +00:00
|
|
|
#!/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 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";
|
2003-03-11 00:19:48 +00:00
|
|
|
|
|
|
|
eval {
|
|
|
|
require Storable;
|
|
|
|
};
|
2003-03-10 23:34:26 +00:00
|
|
|
|
2003-03-11 00:19:48 +00:00
|
|
|
if ($@) {
|
|
|
|
dbg("Storable appears to be missing");
|
|
|
|
dbg("In order to use the QSL feature you must");
|
|
|
|
dbg("load Storable from CPAN");
|
|
|
|
return undef;
|
|
|
|
}
|
2003-03-12 13:30:46 +00:00
|
|
|
import Storable qw(nfreeze freeze thaw);
|
2003-03-10 23:34:26 +00:00
|
|
|
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
|
|
|
|
{
|
2003-03-11 00:19:48 +00:00
|
|
|
return unless $dbm;
|
2003-03-10 23:34:26 +00:00
|
|
|
my $self = shift;
|
|
|
|
my $line = shift;
|
|
|
|
my $t = shift;
|
|
|
|
my $by = shift;
|
|
|
|
|
2003-03-12 13:30:46 +00:00
|
|
|
my @tok = map {/^(?:HC|BUR|QRZ|HOME)/ || is_callsign($_) ? $_ : ()} split(/\b/, uc $line);
|
2003-03-10 23:34:26 +00:00
|
|
|
foreach my $man (@tok) {
|
2003-03-12 13:30:46 +00:00
|
|
|
if ($man =~ /^BUR/) {
|
|
|
|
$man = 'BUREAU';
|
|
|
|
} elsif ($man eq 'HC' || $man =~ /^HOM/) {
|
|
|
|
$man = 'HOME CALL';
|
|
|
|
} elsif ($man =~ /^QRZ/) {
|
|
|
|
$man = 'QRZ.com';
|
|
|
|
}
|
2003-03-10 23:34:26 +00:00
|
|
|
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];
|
2003-03-11 11:59:35 +00:00
|
|
|
unshift @{$self->[1]}, $r;
|
2003-03-10 23:34:26 +00:00
|
|
|
}
|
|
|
|
}
|
|
|
|
$self->put;
|
|
|
|
}
|
|
|
|
|
|
|
|
sub get
|
|
|
|
{
|
|
|
|
return undef unless $dbm;
|
2003-03-11 01:19:43 +00:00
|
|
|
my $key = uc shift;
|
2003-03-10 23:34:26 +00:00
|
|
|
my $value;
|
|
|
|
|
|
|
|
my $r = $dbm->get($key, $value);
|
|
|
|
return undef if $r;
|
|
|
|
return thaw($value);
|
|
|
|
}
|
|
|
|
|
|
|
|
sub put
|
|
|
|
{
|
2003-03-11 00:19:48 +00:00
|
|
|
return unless $dbm;
|
2003-03-10 23:34:26 +00:00
|
|
|
my $self = shift;
|
|
|
|
my $key = $self->[0];
|
|
|
|
my $value = nfreeze($self);
|
|
|
|
$dbm->put($key, $value);
|
|
|
|
}
|
|
|
|
|
|
|
|
1;
|