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