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 SysVar;
  12 use DXUtil;
  13 use DB_File;
  14 use DXDebug;
  15 use Prefix;
  16 use DXJSON;
  17 use Data::Structure::Util qw(unbless);
  18
  19 use vars qw($qslfn $dbm $maxentries);
  20 $qslfn = 'dxqsl';
  21 $dbm = undef;
  22 $maxentries = 50;
  23
  24 my %u;
  25 my $json;
  26
  27 localdata_mv("$qslfn.v1j");
  28
  29 sub init
  30 {
  31         my $mode = shift;
  32         my $ufn = localdata("$qslfn.v1j");
  33
  34         $json = DXJSON->new;
  35
  36         Prefix::load() unless Prefix::loaded();
  37
  38         finish() if $dbm;
  39
  40         if ($mode) {
  41                 $dbm = tie (%u, 'DB_File', $ufn, O_CREAT|O_RDWR, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)";
  42         } else {
  43                 $dbm = tie (%u, 'DB_File', $ufn, O_RDONLY, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)";
  44         }
  45         return $dbm;
  46 }
  47
  48 sub finish
  49 {
  50         dbg("DXQSL finished");
  51         $dbm->sync;
  52         undef $dbm;
  53         untie %u;
  54 }
  55
  56 sub new
  57 {
  58         my ($pkg, $call) = @_;
  59         return bless [uc $call, []], $pkg;
  60 }
  61
  62 # called $self->update(comment, time, spotter)
  63 # $self has the callsign as the first argument in an array of array references
  64 # the format of each entry is [manager, times found, last time, last reporter]
  65 sub update
  66 {
  67         return unless $dbm;
  68         my $self = shift;
  69         my $line = shift;
  70         my $t = shift;
  71         my $by = shift;
  72         my $changed;
  73
  74         return unless length $line && $line =~ /\b(?:QSL|VIA)\b/i;
  75         foreach my $man (split /\b/, uc $line) {
  76                 my $tok;
  77
  78                 if (is_callsign($man) && !is_qra($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 =~ /^LOTW/) {
  84                         $tok = 'LOTW';
  85                 } elsif ($man eq 'HC' || $man =~ /^HOM/ || $man =~ /^DIR/) {
  86                         $tok = 'HOME CALL';
  87                 } elsif ($man =~ /^QRZ/) {
  88                         $tok = 'QRZ.com';
  89                 } else {
  90                         next;
  91                 }
  92                 if ($tok) {
  93                         my ($r) = grep {$_->[0] eq $tok} @{$self->[1]};
  94                         if ($r) {
  95                                 $r->[1]++;
  96                                 if ($t > $r->[2]) {
  97                                         $r->[2] = $t;
  98                                         $r->[3] = $by;
  99                                 }
 100                                 $changed++;
 101                         } else {
 102                                 $r = [$tok, 1, $t, $by];
 103                                 unshift @{$self->[1]}, $r;
 104                                 $changed++;
 105                         }
 106                         # prune the number of entries
 107                         pop @{$self->[1]} while (@{$self->[1]} > $maxentries);
 108                 }
 109         }
 110         $self->put if $changed;
 111 }
 112
 113 sub get
 114 {
 115         return undef unless $dbm;
 116         my $key = uc shift;
 117         my $value;
 118
 119         my $r = $dbm->get($key, $value);
 120         return undef if $r;
 121         return decode($value);
 122 }
 123
 124
 125 sub put
 126 {
 127         return unless $dbm;
 128         my $self = shift;
 129         my $key = $self->[0];
 130         my $value = encode($self);
 131         $dbm->put($key, $value);
 132 }
 133
 134 sub remove_files
 135 {
 136         unlink "$main::data/$qslfn.v1j";
 137         unlink "$main::local_data/$qslfn.v1j";
 138 }
 139
 140 # thaw the user
 141 sub decode
 142 {
 143         return $json->decode($_[0], __PACKAGE__);
 144 }
 145
 146 # freeze the user
 147 sub encode
 148 {
 149         return $json->encode($_[0]);
 150 }
 151
 152 sub END
 153 {
 154         if ($dbm) {
 155                 dbg "DXQSL ENDing";
 156                 finish();
 157         }
 158 }
 159
 160 1;