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 freeze 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 {/^(?:HC|BUR|QRZ|HOME)/ || is_callsign($_) ? $_ : ()} split(/\b/, uc $line);
  72         foreach my $man (@tok) {
  73                 if ($man =~ /^BUR/) {
  74                         $man = 'BUREAU';
  75                 } elsif ($man eq 'HC' || $man =~ /^HOM/) {
  76                         $man = 'HOME CALL';
  77                 } elsif ($man =~ /^QRZ/) {
  78                         $man = 'QRZ.com';
  79                 }
  80                 my ($r) = grep {$_->[0] eq $man} @{$self->[1]};
  81                 if ($r) {
  82                         $r->[1]++;
  83                         if ($t > $r->[2]) {
  84                                 $r->[2] = $t;
  85                                 $r->[3] = $by;
  86                         }
  87                 } else {
  88                         $r = [$man, 1, $t, $by];
  89                         unshift @{$self->[1]}, $r;
  90                 }
  91         }
  92         $self->put;
  93 }
  94
  95 sub get
  96 {
  97         return undef unless $dbm;
  98         my $key = uc shift;
  99         my $value;
 100
 101         my $r = $dbm->get($key, $value);
 102         return undef if $r;
 103         return thaw($value);
 104 }
 105
 106 sub put
 107 {
 108         return unless $dbm;
 109         my $self = shift;
 110         my $key = $self->[0];
 111         my $value = nfreeze($self);
 112         $dbm->put($key, $value);
 113 }
 114
 115 1;