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