]> www.dxcluster.org Git - spider.git/blob - perl/QSL.pm
add a 'not found' message if sh/dx shows nothing
[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);
18 $qslfn = 'qsl';
19 $dbm = undef;
20
21 localdata_mv("$qslfn.v1");
22
23 sub init
24 {
25         my $mode = shift;
26         my $ufn = localdata("$qslfn.v1");
27
28         Prefix::load() unless Prefix::loaded();
29         
30         eval {
31                 require Storable;
32         };
33         
34         if ($@) {
35                 dbg("Storable appears to be missing");
36                 dbg("In order to use the QSL feature you must");
37                 dbg("load Storable from CPAN");
38                 return undef;
39         }
40         import Storable qw(nfreeze freeze thaw);
41         my %u;
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 # called $self->update(comment, time, spotter)
62 # $self has the callsign as the first argument in an array of array references
63 # the format of each entry is [manager, times found, last time, last reporter]
64 sub update
65 {
66         return unless $dbm;
67         my $self = shift;
68         my $line = shift;
69         my $t = shift;
70         my $by = shift;
71         my $changed;
72                         
73         foreach my $man (split /\b/, uc $line) {
74                 my $tok;
75                 
76                 if (is_callsign($man)) {
77                         my @pre = Prefix::extract($man);
78                         $tok = $man if @pre && $pre[0] ne 'Q';
79                 } elsif ($man =~ /^BUR/) {
80                         $tok = 'BUREAU';
81                 } elsif ($man eq 'HC' || $man =~ /^HOM/ || $man =~ /^DIR/) {
82                         $tok = 'HOME CALL';
83                 } elsif ($man =~ /^QRZ/) {
84                         $tok = 'QRZ.com';
85                 }
86                 if ($tok) {
87                         my ($r) = grep {$_->[0] eq $tok} @{$self->[1]};
88                         if ($r) {
89                                 $r->[1]++;
90                                 if ($t > $r->[2]) {
91                                         $r->[2] = $t;
92                                         $r->[3] = $by;
93                                 }
94                                 $changed++;
95                         } else {
96                                 $r = [$tok, 1, $t, $by];
97                                 unshift @{$self->[1]}, $r;
98                                 $changed++;
99                         }
100                 }
101         }
102         $self->put if $changed;
103 }
104
105 sub get
106 {
107         return undef unless $dbm;
108         my $key = uc shift;
109         my $value;
110         
111         my $r = $dbm->get($key, $value);
112         return undef if $r;
113         return thaw($value);
114 }
115
116 sub put
117 {
118         return unless $dbm;
119         my $self = shift;
120         my $key = $self->[0];
121         my $value = nfreeze($self);
122         $dbm->put($key, $value);
123 }
124
125 1;