]> www.dxcluster.org Git - spider.git/blob - perl/QSL.pm
use WCY::r if recent enough and available
[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($VERSION $BRANCH);
18 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
19 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
20 $main::build += $VERSION;
21 $main::branch += $BRANCH;
22
23 use vars qw($qslfn $dbm);
24 $qslfn = 'qsl';
25 $dbm = undef;
26
27 sub init
28 {
29         my $mode = shift;
30         my $ufn = "$main::root/data/$qslfn.v1";
31
32         Prefix::load() unless Prefix::loaded();
33         
34         eval {
35                 require Storable;
36         };
37         
38         if ($@) {
39                 dbg("Storable appears to be missing");
40                 dbg("In order to use the QSL feature you must");
41                 dbg("load Storable from CPAN");
42                 return undef;
43         }
44         import Storable qw(nfreeze freeze thaw);
45         my %u;
46         if ($mode) {
47                 $dbm = tie (%u, 'DB_File', $ufn, O_CREAT|O_RDWR, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)";
48         } else {
49                 $dbm = tie (%u, 'DB_File', $ufn, O_RDONLY, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)";
50         }
51         return $dbm;
52 }
53
54 sub finish
55 {
56         undef $dbm;
57 }
58
59 sub new
60 {
61         my ($pkg, $call) = @_;
62         return bless [uc $call, []], $pkg;
63 }
64
65 # the format of each entry is [manager, times found, last time]
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         foreach my $man (split /\b/, uc $line) {
76                 my $tok;
77                 
78                 if (is_callsign($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 eq 'HC' || $man =~ /^HOM/ || $man =~ /^DIR/) {
84                         $tok = 'HOME CALL';
85                 } elsif ($man =~ /^QRZ/) {
86                         $tok = 'QRZ.com';
87                 }
88                 if ($tok) {
89                         my ($r) = grep {$_->[0] eq $tok} @{$self->[1]};
90                         if ($r) {
91                                 $r->[1]++;
92                                 if ($t > $r->[2]) {
93                                         $r->[2] = $t;
94                                         $r->[3] = $by;
95                                 }
96                                 $changed++;
97                         } else {
98                                 $r = [$tok, 1, $t, $by];
99                                 unshift @{$self->[1]}, $r;
100                                 $changed++;
101                         }
102                 }
103         }
104         $self->put if $changed;
105 }
106
107 sub get
108 {
109         return undef unless $dbm;
110         my $key = uc shift;
111         my $value;
112         
113         my $r = $dbm->get($key, $value);
114         return undef if $r;
115         return thaw($value);
116 }
117
118 sub put
119 {
120         return unless $dbm;
121         my $self = shift;
122         my $key = $self->[0];
123         my $value = nfreeze($self);
124         $dbm->put($key, $value);
125 }
126
127 1;