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
  16 use vars qw($VERSION $BRANCH);
  17 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
  18 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
  19 $main::build += $VERSION;
  20 $main::branch += $BRANCH;
  21
  22 use vars qw($qslfn $dbm);
  23 $qslfn = 'qsl';
  24 $dbm = undef;
  25
  26 sub init
  27 {
  28         my $mode = shift;
  29         my $ufn = "$main::root/data/$qslfn.v1";
  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 thaw);
  42         my %u;
  43         if ($mode) {
  44                 $dbm = tie (%u, 'DB_File', $ufn, O_CREAT|O_RDWR, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)";
  45         } else {
  46                 $dbm = tie (%u, 'DB_File', $ufn, O_RDONLY, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)";
  47         }
  48         return $dbm;
  49 }
  50
  51 sub finish
  52 {
  53         undef $dbm;
  54 }
  55
  56 sub new
  57 {
  58         my ($pkg, $call) = @_;
  59         return bless [uc $call, []], $pkg;
  60 }
  61
  62 # the format of each entry is [manager, times found, last time]
  63 sub update
  64 {
  65         return unless $dbm;
  66         my $self = shift;
  67         my $line = shift;
  68         my $t = shift;
  69         my $by = shift;
  70
  71         my @tok = map {/^BUR/ || is_callsign($_) ? $_ : ()} split(/\b/, uc $line);
  72         foreach my $man (@tok) {
  73                 $man = 'BUREAU' if $man =~ /^BUR/;
  74                 my ($r) = grep {$_->[0] eq $man} @{$self->[1]};
  75                 if ($r) {
  76                         $r->[1]++;
  77                         if ($t > $r->[2]) {
  78                                 $r->[2] = $t;
  79                                 $r->[3] = $by;
  80                         }
  81                 } else {
  82                         $r = [$man, 1, $t, $by];
  83                         push @{$self->[1]}, $r;
  84                 }
  85         }
  86         $self->put;
  87 }
  88
  89 sub get
  90 {
  91         my $key = uc shift;
  92         return undef unless $dbm;
  93         my $value;
  94
  95         my $r = $dbm->get($key, $value);
  96         return undef if $r;
  97         return thaw($value);
  98 }
  99
 100 sub put
 101 {
 102         return unless $dbm;
 103         my $self = shift;
 104         my $key = $self->[0];
 105         my $value = nfreeze($self);
 106         $dbm->put($key, $value);
 107 }
 108
 109 1;