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 Storable qw(nfreeze thaw);
  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         my %u;
  33         if ($mode) {
  34                 $dbm = tie (%u, 'DB_File', $ufn, O_CREAT|O_RDWR, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)";
  35         } else {
  36                 $dbm = tie (%u, 'DB_File', $ufn, O_RDONLY, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)";
  37         }
  38         return $dbm;
  39 }
  40
  41 sub finish
  42 {
  43         undef $dbm;
  44 }
  45
  46 sub new
  47 {
  48         my ($pkg, $call) = @_;
  49         return bless [uc $call, []], $pkg;
  50 }
  51
  52 # the format of each entry is [manager, times found, last time]
  53 sub update
  54 {
  55         my $self = shift;
  56         my $line = shift;
  57         my $t = shift;
  58         my $by = shift;
  59
  60         my @tok = map {/^BUR/ || is_callsign($_) ? $_ : ()} split(/\b/, uc $line);
  61         foreach my $man (@tok) {
  62                 $man = 'BUREAU' if $man =~ /^BUR/;
  63                 my ($r) = grep {$_->[0] eq $man} @{$self->[1]};
  64                 if ($r) {
  65                         $r->[1]++;
  66                         if ($t > $r->[2]) {
  67                                 $r->[2] = $t;
  68                                 $r->[3] = $by;
  69                         }
  70                 } else {
  71                         $r = [$man, 1, $t, $by];
  72                         push @{$self->[1]}, $r;
  73                 }
  74         }
  75         $self->put;
  76 }
  77
  78 sub get
  79 {
  80         my $key = uc shift;
  81         return undef unless $dbm;
  82         my $value;
  83
  84         my $r = $dbm->get($key, $value);
  85         return undef if $r;
  86         return thaw($value);
  87 }
  88
  89 sub put
  90 {
  91         my $self = shift;
  92         my $key = $self->[0];
  93         my $value = nfreeze($self);
  94         $dbm->put($key, $value);
  95 }
  96
  97 1;