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