]> dxcluster.org Git - spider.git/blob - perl/QSL.pm
fixed duplicate spot, always make clean ending
[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 sub init
23 {
24         my $mode = shift;
25         my $ufn = "$main::root/data/$qslfn.v1";
26
27         Prefix::load() unless Prefix::loaded();
28         
29         eval {
30                 require Storable;
31         };
32         
33         if ($@) {
34                 dbg("Storable appears to be missing");
35                 dbg("In order to use the QSL feature you must");
36                 dbg("load Storable from CPAN");
37                 return undef;
38         }
39         import Storable qw(nfreeze freeze thaw);
40         my %u;
41         undef $dbm;
42         if ($mode) {
43                 $dbm = tie (%u, 'DB_File', $ufn, O_CREAT|O_RDWR, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)";
44         } else {
45                 $dbm = tie (%u, 'DB_File', $ufn, O_RDONLY, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)";
46         }
47         return $dbm;
48 }
49
50 sub finish
51 {
52         undef $dbm;
53 }
54
55 sub new
56 {
57         my ($pkg, $call) = @_;
58         return bless [uc $call, []], $pkg;
59 }
60
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)\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 eq 'HC' || $man =~ /^HOM/ || $man =~ /^DIR/) {
83                         $tok = 'HOME CALL';
84                 } elsif ($man =~ /^QRZ/) {
85                         $tok = 'QRZ.com';
86                 } else {
87                         next;
88                 }
89                 if ($tok) {
90                         my ($r) = grep {$_->[0] eq $tok} @{$self->[1]};
91                         if ($r) {
92                                 $r->[1]++;
93                                 if ($t > $r->[2]) {
94                                         $r->[2] = $t;
95                                         $r->[3] = $by;
96                                 }
97                                 $changed++;
98                         } else {
99                                 $r = [$tok, 1, $t, $by];
100                                 unshift @{$self->[1]}, $r;
101                                 $changed++;
102                         }
103                         # prune the number of entries
104                         pop @{$self->[1]} while (@{$self->[1]} > $maxentries);
105                 }
106         }
107         $self->put if $changed;
108 }
109
110 sub get
111 {
112         return undef unless $dbm;
113         my $key = uc shift;
114         my $value;
115         
116         my $r = $dbm->get($key, $value);
117         return undef if $r;
118         my $v;
119         eval { $v = thaw($value) };
120         if ($@) {
121                 LogDbg("Error thawing DXQSL key '$key' (now deleted): $@");
122                 eval {$dbm->del($key)};
123                 return undef;
124         }
125         return $v;
126 }
127
128
129 sub put
130 {
131         return unless $dbm;
132         my $self = shift;
133         my $key = $self->[0];
134         my $value = nfreeze($self);
135         $dbm->put($key, $value);
136 }
137
138 sub active
139 {
140         return $dbm;
141 }
142
143 1;