perl/QSL.pm

   1 #!/usr/bin/perl -w
   2 #
   3 # Local 'autoqsl' module for DXSpider
   4 #
   5 # Copyright (c) 2003-2020 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
  17 use JSON;
  18 use Data::Structure::Util qw(unbless);
  19
  20 use vars qw($qslfn $dbm $maxentries);
  21 $qslfn = 'dxqsl';
  22 $dbm = undef;
  23 $maxentries = 10;
  24
  25 my $json;
  26 my %u;
  27
  28 sub init
  29 {
  30         my $mode = shift;
  31         my $ufn = localdata("$qslfn.v2");
  32
  33         Prefix::load() unless Prefix::loaded();
  34         $json = JSON->new->canonical(1);
  35
  36         untie %u;
  37         undef $dbm;
  38         if ($mode) {
  39                 $dbm = tie (%u, 'DB_File', $ufn, O_CREAT|O_RDWR, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)";
  40         } else {
  41                 $dbm = tie (%u, 'DB_File', $ufn, O_RDONLY, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)";
  42         }
  43         return $dbm;
  44 }
  45
  46 sub finish
  47 {
  48         untie %u;
  49         undef $dbm;
  50 }
  51
  52 sub new
  53 {
  54         my ($pkg, $call) = @_;
  55         return undef if $call =~ /INFO|QSL|VIA/;
  56         return bless [uc $call, []], $pkg;
  57 }
  58
  59 # called $self->update(comment, time, spotter)
  60 # $self has the callsign as the first argument in an array of array references
  61 # the format of each entry is [manager, times found, last time, last reporter]
  62 sub update
  63 {
  64         return unless $dbm;
  65         my $self = shift;
  66         my $line = shift;
  67         my $t = shift;
  68         my $by = shift;
  69         my $changed;
  70
  71         return unless length $line && $line =~ /\b(?:QSL|VIA|BUR[OE]?A?U?|OQRS|LOTW)\b/i;
  72         foreach my $man (split /\b/, uc $line) {
  73                 my $tok;
  74
  75                 if (is_callsign($man) && !is_qra($man)) {
  76                         my @pre = Prefix::extract($man);
  77                         $tok = $man if @pre && $pre[0] ne 'Q';
  78                 } elsif ($man =~ /^BUR/) {
  79                         $tok = 'BUREAU';
  80                 } elsif ($man =~ /^LOTW/) {
  81                         $tok = 'LOTW';
  82                 } elsif ($man =~ /^OQRS/) {
  83                         $tok = 'OQRS';
  84                 } elsif ($man eq 'HC' || $man =~ /^HOM/ || $man =~ /^DIR/) {
  85                         $tok = 'HOME CALL';
  86                 } elsif ($man =~ /^QRZ/) {
  87                         $tok = 'QRZ.com';
  88                 } else {
  89                         next;
  90                 }
  91                 if ($tok) {
  92                         my ($r) = grep {$_->[0] eq $tok} @{$self->[1]};
  93                         if ($r) {
  94                                 $r->[1]++;
  95                                 if ($t > $r->[2]) {
  96                                         $r->[2] = $t;
  97                                         $r->[3] = $by;
  98                                 }
  99                                 $changed++;
 100                         } else {
 101                                 $r = [$tok, 1, $t, $by];
 102                                 unshift @{$self->[1]}, $r;
 103                                 $changed++;
 104                         }
 105                         # prune the number of entries
 106                         pop @{$self->[1]} while (@{$self->[1]} > $maxentries);
 107                 }
 108         }
 109         $self->put if $changed;
 110 }
 111
 112 sub get
 113 {
 114         return undef unless $dbm;
 115         my $key = uc shift;
 116
 117         my $value;
 118         my $r = $dbm->get($key, $value);
 119         return undef if $r;
 120         return json_decode($value);
 121 }
 122
 123 sub put
 124 {
 125         return unless $dbm;
 126         my $self = shift;
 127         my $key = $self->[0];
 128         my $value = json_encode($self);
 129         $dbm->put($key, $value);
 130 }
 131
 132 sub json_decode
 133 {
 134         my $s = shift;
 135     my $ref;
 136         eval { $ref = $json->decode($s) };
 137         if ($ref && !$@) {
 138         return bless $ref, __PACKAGE__;
 139         } else {
 140                 LogDbg('DXUser', "__PACKAGE_::json_decode: on '$s' $@");
 141         }
 142         return undef;
 143 }
 144
 145 sub json_encode
 146 {
 147         my $ref = shift;
 148         unbless($ref);
 149     my $s = $json->encode($ref);
 150         bless $ref, __PACKAGE__;
 151         return $s;
 152 }
 153
 154 1;