QSL.pm

   1 #!/usr/bin/perl -w
   2 #
   3 # Local 'autoqsl' module for DXSpider
   4 #
   5 # Copyright (c) 2003 Dirk Koopman G1TLH
   6 #
   7
   8 package QSL;
   9
  10 use strict;
  11 use DXVars;
  12 use DXUtil;
  13 use DB_File;
  14 use DXDebug;
  15 use Prefix;
  16
  17 use vars qw($qslfn $dbm $maxentries);
  18 $qslfn = 'qsl';
  19 $dbm = undef;
  20 $maxentries = 50;
  21
  22 localdata_mv("$qslfn.v1");
  23
  24 sub init
  25 {
  26         my $mode = shift;
  27         my $ufn = localdata("$qslfn.v1");
  28
  29         Prefix::load() unless Prefix::loaded();
  30
  31         eval {
  32                 require Storable;
  33         };
  34
  35         if ($@) {
  36                 dbg("Storable appears to be missing");
  37                 dbg("In order to use the QSL feature you must");
  38                 dbg("load Storable from CPAN");
  39                 return undef;
  40         }
  41         import Storable qw(nfreeze freeze thaw);
  42         my %u;
  43         undef $dbm;
  44         if ($mode) {
  45                 $dbm = tie (%u, 'DB_File', $ufn, O_CREAT|O_RDWR, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)";
  46         } else {
  47                 $dbm = tie (%u, 'DB_File', $ufn, O_RDONLY, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)";
  48         }
  49         return $dbm;
  50 }
  51
  52 sub finish
  53 {
  54         undef $dbm;
  55 }
  56
  57 sub new
  58 {
  59         my ($pkg, $call) = @_;
  60         return bless [uc $call, []], $pkg;
  61 }
  62
  63 # called $self->update(comment, time, spotter)
  64 # $self has the callsign as the first argument in an array of array references
  65 # the format of each entry is [manager, times found, last time, last reporter]
  66 sub update
  67 {
  68         return unless $dbm;
  69         my $self = shift;
  70         my $line = shift;
  71         my $t = shift;
  72         my $by = shift;
  73         my $changed;
  74
  75         return unless length $line && $line =~ /\b(?:QSL|VIA)\b/i;
  76         foreach my $man (split /\b/, uc $line) {
  77                 my $tok;
  78
  79                 if (is_callsign($man) && !is_qra($man)) {
  80                         my @pre = Prefix::extract($man);
  81                         $tok = $man if @pre && $pre[0] ne 'Q';
  82                 } elsif ($man =~ /^BUR/) {
  83                         $tok = 'BUREAU';
  84                 } elsif ($man =~ /^LOTW/) {
  85                         $tok = 'LOTW';
  86                 } elsif ($man eq 'HC' || $man =~ /^HOM/ || $man =~ /^DIR/) {
  87                         $tok = 'HOME CALL';
  88                 } elsif ($man =~ /^QRZ/) {
  89                         $tok = 'QRZ.com';
  90                 } else {
  91                         next;
  92                 }
  93                 if ($tok) {
  94                         my ($r) = grep {$_->[0] eq $tok} @{$self->[1]};
  95                         if ($r) {
  96                                 $r->[1]++;
  97                                 if ($t > $r->[2]) {
  98                                         $r->[2] = $t;
  99                                         $r->[3] = $by;
 100                                 }
 101                                 $changed++;
 102                         } else {
 103                                 $r = [$tok, 1, $t, $by];
 104                                 unshift @{$self->[1]}, $r;
 105                                 $changed++;
 106                         }
 107                         # prune the number of entries
 108                         pop @{$self->[1]} while (@{$self->[1]} > $maxentries);
 109                 }
 110         }
 111         $self->put if $changed;
 112 }
 113
 114 sub get
 115 {
 116         return undef unless $dbm;
 117         my $key = uc shift;
 118         my $value;
 119
 120         my $r = $dbm->get($key, $value);
 121         return undef if $r;
 122         return thaw($value);
 123 }
 124
 125 sub put
 126 {
 127         return unless $dbm;
 128         my $self = shift;
 129         my $key = $self->[0];
 130         my $value = nfreeze($self);
 131         $dbm->put($key, $value);
 132 }
 133
 134 1;