perl/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);
  18 $qslfn = 'qsl';
  19 $dbm = undef;
  20
  21 sub init
  22 {
  23         my $mode = shift;
  24         my $ufn = "$main::root/data/$qslfn.v1";
  25
  26         Prefix::load() unless Prefix::loaded();
  27
  28         eval {
  29                 require Storable;
  30         };
  31
  32         if ($@) {
  33                 dbg("Storable appears to be missing");
  34                 dbg("In order to use the QSL feature you must");
  35                 dbg("load Storable from CPAN");
  36                 return undef;
  37         }
  38         import Storable qw(nfreeze freeze thaw);
  39         my %u;
  40         if ($mode) {
  41                 $dbm = tie (%u, 'DB_File', $ufn, O_CREAT|O_RDWR, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)";
  42         } else {
  43                 $dbm = tie (%u, 'DB_File', $ufn, O_RDONLY, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)";
  44         }
  45         return $dbm;
  46 }
  47
  48 sub finish
  49 {
  50         undef $dbm;
  51 }
  52
  53 sub new
  54 {
  55         my ($pkg, $call) = @_;
  56         return bless [uc $call, []], $pkg;
  57 }
  58
  59 # the format of each entry is [manager, times found, last time, last reporter]
  60 sub update
  61 {
  62         return unless $dbm;
  63         my $self = shift;
  64         my $line = shift;
  65         my $t = shift;
  66         my $by = shift;
  67         my $changed;
  68
  69         foreach my $man (split /\b/, uc $line) {
  70                 my $tok;
  71
  72                 if (is_callsign($man)) {
  73                         my @pre = Prefix::extract($man);
  74                         $tok = $man if @pre && $pre[0] ne 'Q';
  75                 } elsif ($man =~ /^BUR/) {
  76                         $tok = 'BUREAU';
  77                 } elsif ($man eq 'HC' || $man =~ /^HOM/ || $man =~ /^DIR/) {
  78                         $tok = 'HOME CALL';
  79                 } elsif ($man =~ /^QRZ/) {
  80                         $tok = 'QRZ.com';
  81                 }
  82                 if ($tok) {
  83                         my ($r) = grep {$_->[0] eq $tok} @{$self->[1]};
  84                         if ($r) {
  85                                 $r->[1]++;
  86                                 if ($t > $r->[2]) {
  87                                         $r->[2] = $t;
  88                                         $r->[3] = $by;
  89                                 }
  90                                 $changed++;
  91                         } else {
  92                                 $r = [$tok, 1, $t, $by];
  93                                 unshift @{$self->[1]}, $r;
  94                                 $changed++;
  95                         }
  96                 }
  97         }
  98         $self->put if $changed;
  99 }
 100
 101 sub get
 102 {
 103         return undef unless $dbm;
 104         my $key = uc shift;
 105         my $value;
 106
 107         my $r = $dbm->get($key, $value);
 108         return undef if $r;
 109         return thaw($value);
 110 }
 111
 112 sub put
 113 {
 114         return unless $dbm;
 115         my $self = shift;
 116         my $key = $self->[0];
 117         my $value = nfreeze($self);
 118         $dbm->put($key, $value);
 119 }
 120
 121 1;