perl/Spot.pm

   1 #
   2 # the dx spot handler
   3 #
   4 # Copyright (c) - 1998 Dirk Koopman G1TLH
   5 #
   6 # $Id$
   7 #
   8
   9 package Spot;
  10
  11 use IO::File;
  12 use DXVars;
  13 use DXDebug;
  14 use DXUtil;
  15 use DXLog;
  16 use Julian;
  17 use Prefix;
  18 use DXDupe;
  19
  20 use strict;
  21 use vars qw($fp $maxspots $defaultspots $maxdays $dirprefix $duplth $dupage $filterdef);
  22
  23 $fp = undef;
  24 $maxspots = 50;                                 # maximum spots to return
  25 $defaultspots = 10;                             # normal number of spots to return
  26 $maxdays = 3*31;                                # normal maximum no of days to go back
  27 $dirprefix = "spots";
  28 $duplth = 20;                                   # the length of text to use in the deduping
  29 $dupage = 3*3600;               # the length of time to hold spot dups
  30 $filterdef = bless ([
  31                           # tag, sort, field, priv, special parser
  32                           ['freq', 'r', 0, 0, \&decodefreq],
  33                           ['on', 'r', 0, 0, \&decodefreq],
  34                           ['call', 'c', 1],
  35                           ['info', 't', 3],
  36                           ['by', 'c', 4],
  37                           ['call_dxcc', 'n', 5],
  38                           ['by_dxcc', 'n', 6],
  39                           ['origin', 'c', 7, 9],
  40                           ['call_itu', 'n', 8],
  41                           ['call_zone', 'n', 9],
  42                           ['by_itu', 'n', 10],
  43                           ['by_zone', 'n', 11],
  44                           ['channel', 'n', 12, 9],
  45                          ], 'Filter::Cmd');
  46
  47
  48 # create a Spot Object
  49 sub new
  50 {
  51         my $class = shift;
  52         my $self = [ @_ ];
  53         return bless $self, $class;
  54 }
  55
  56 sub decodefreq
  57 {
  58         my $dxchan = shift;
  59         my $l = shift;
  60         my @f = split /,/, $l;
  61         my @out;
  62         my $f;
  63
  64         foreach $f (@f) {
  65                 my ($a, $b);
  66                 if (m{^\d+/\d+$}) {
  67                         push @out, $f;
  68                 } elsif (($a, $b) = $f =~ m{^(\w+)(?:/(\w+))?$}) {
  69                         $b = lc $b if $b;
  70                         my @fr = Bands::get_freq(lc $a, $b);
  71                         if (@fr) {
  72                                 while (@fr) {
  73                                         $a = shift @fr;
  74                                         $b = shift @fr;
  75                                         push @out, "$a/$b";  # add them as ranges
  76                                 }
  77                         } else {
  78                                 return ('dfreq', $dxchan->msg('dfreq1', $f));
  79                         }
  80                 } else {
  81                         return ('dfreq', $dxchan->msg('e20', $f));
  82                 }
  83         }
  84         return (0, join(',', @out));
  85 }
  86
  87 sub init
  88 {
  89         mkdir "$dirprefix", 0777 if !-e "$dirprefix";
  90         $fp = DXLog::new($dirprefix, "dat", 'd');
  91 }
  92
  93 sub prefix
  94 {
  95         return $fp->{prefix};
  96 }
  97
  98 # fix up the full spot data from the basic spot data
  99 sub prepare
 100 {
 101         # $freq, $call, $t, $comment, $spotter = @_
 102         my @out = @_[0..4];      # just up to the spotter
 103
 104         # normalise frequency
 105         $_[0] = sprintf "%.f", $_[0];
 106
 107         # remove ssids if present on spotter
 108         $out[4] =~ s/-\d+$//o;
 109
 110         # remove leading and trailing spaces
 111         $_[3] = unpad($_[3]);
 112
 113         # add the 'dxcc' country on the end for both spotted and spotter, then the cluster call
 114         my @dxcc = Prefix::extract($out[1]);
 115         my $spotted_dxcc = (@dxcc > 0 ) ? $dxcc[1]->dxcc() : 0;
 116         my $spotted_itu = (@dxcc > 0 ) ? $dxcc[1]->itu() : 0;
 117         my $spotted_cq = (@dxcc > 0 ) ? $dxcc[1]->cq() : 0;
 118         push @out, $spotted_dxcc;
 119         @dxcc = Prefix::extract($out[4]);
 120         my $spotter_dxcc = (@dxcc > 0 ) ? $dxcc[1]->dxcc() : 0;
 121         my $spotter_itu = (@dxcc > 0 ) ? $dxcc[1]->itu() : 0;
 122         my $spotter_cq = (@dxcc > 0 ) ? $dxcc[1]->cq() : 0;
 123         push @out, $spotter_dxcc;
 124         push @out, $_[5];
 125         return (@out, $spotted_itu, $spotted_cq, $spotter_itu, $spotter_cq);
 126 }
 127
 128 sub add
 129 {
 130         my $buf = join("\^", @_[0..7]);
 131         $fp->writeunix($_[2], $buf);
 132 }
 133
 134 # search the spot database for records based on the field no and an expression
 135 # this returns a set of references to the spots
 136 #
 137 # the expression is a legal perl 'if' statement with the possible fields indicated
 138 # by $f<n> where :-
 139 #
 140 #   $f0 = frequency
 141 #   $f1 = call
 142 #   $f2 = date in unix format
 143 #   $f3 = comment
 144 #   $f4 = spotter
 145 #   $f5 = spotted dxcc country
 146 #   $f6 = spotter dxcc country
 147 #   $f7 = origin
 148 #
 149 #
 150 # In addition you can specify a range of days, this means that it will start searching
 151 # from <n> days less than today to <m> days less than today
 152 #
 153 # Also you can select a range of entries so normally you would get the 0th (latest) entry
 154 # back to the 5th latest, you can specify a range from the <x>th to the <y>the oldest.
 155 #
 156 # This routine is designed to be called as Spot::search(..)
 157 #
 158
 159 sub search
 160 {
 161         my ($expr, $dayfrom, $dayto, $from, $to, $hint) = @_;
 162         my $eval;
 163         my @out;
 164         my $ref;
 165         my $i;
 166         my $count;
 167         my @today = Julian::unixtoj(time());
 168         my @fromdate;
 169         my @todate;
 170
 171         $dayfrom = 0 if !$dayfrom;
 172         $dayto = $maxdays if !$dayto;
 173         @fromdate = Julian::sub(@today, $dayfrom);
 174         @todate = Julian::sub(@fromdate, $dayto);
 175         $from = 0 unless $from;
 176         $to = $defaultspots unless $to;
 177         $hint = $hint ? "next unless $hint" : "";
 178         $expr = "1" unless $expr;
 179
 180         $to = $from + $maxspots if $to - $from > $maxspots || $to - $from <= 0;
 181
 182         $expr =~ s/\$f(\d)/\$ref->[$1]/g; # swap the letter n for the correct field name
 183         #  $expr =~ s/\$f(\d)/\$spots[$1]/g;               # swap the letter n for the correct field name
 184
 185         dbg("search", "hint='$hint', expr='$expr', spotno=$from-$to, day=$dayfrom-$dayto\n");
 186
 187         # build up eval to execute
 188         $eval = qq(
 189                            while (<\$fh>) {
 190                                    $hint;
 191                                    chomp;
 192                                    push \@spots, [ split '\\^' ];
 193                            }
 194                            my \$c;
 195                            my \$ref;
 196                            for (\$c = \$#spots; \$c >= 0; \$c--) {
 197                                         \$ref = \$spots[\$c];
 198                                         if ($expr) {
 199                                                 \$count++;
 200                                                 next if \$count < \$from; # wait until from
 201                                                 push(\@out, \$ref);
 202                                                 last if \$count >= \$to; # stop after to
 203                                         }
 204                                 }
 205                           );
 206
 207         $fp->close;                                     # close any open files
 208
 209         for ($i = $count = 0; $i < $maxdays; ++$i) {    # look thru $maxdays worth of files only
 210                 my @now = Julian::sub(@fromdate, $i); # but you can pick which $maxdays worth
 211                 last if Julian::cmp(@now, @todate) <= 0;
 212
 213                 my @spots = ();
 214                 my $fh = $fp->open(@now); # get the next file
 215                 if ($fh) {
 216                         my $in;
 217                         eval $eval;                     # do the search on this file
 218                         last if $count >= $to; # stop after to
 219                         return ("Spot search error", $@) if $@;
 220                 }
 221         }
 222
 223         return @out;
 224 }
 225
 226 # change a freq range->regular expression
 227 sub ftor
 228 {
 229         my ($a, $b) = @_;
 230         return undef unless $a < $b;
 231         $b--;
 232         my $d = $b - $a;
 233         my @a = split //, $a;
 234         my @b = split //, $b;
 235         my $out;
 236         while (@b > @a) {
 237                 $out .= shift @b;
 238         }
 239         while (@b) {
 240                 my $aa = shift @a;
 241                 my $bb = shift @b;
 242                 if (@b < (length $d) - 1) {
 243                         $out .= '\\d';
 244                 } elsif ($aa eq $bb) {
 245                         $out .= $aa;
 246                 } elsif ($aa < $bb) {
 247                         $out .= "[$aa-$bb]";
 248                 } else {
 249                         $out .= "[0-$bb$aa-9]";
 250                 }
 251         }
 252         return $out;
 253 }
 254
 255 # format a spot for user output in 'broadcast' mode
 256 sub formatb
 257 {
 258         my $wantgrid = shift;
 259         my $t = ztime($_[2]);
 260         my $ref = DXUser->get_current($_[4]);
 261         my $loc = $ref->qra if $ref && $ref->qra && $wantgrid;
 262         $loc = ' ' . substr($ref->qra, 0, 4) if $loc;
 263         $loc = "" unless $loc;
 264         return sprintf "DX de %-7.7s%11.1f  %-12.12s %-30s %s$loc", "$_[4]:", $_[0], $_[1], $_[3], $t ;
 265 }
 266
 267 # format a spot for user output in list mode
 268 sub formatl
 269 {
 270         my $t = ztime($_[2]);
 271         my $d = cldate($_[2]);
 272         return sprintf "%8.1f  %-11s %s %s  %-28.28s%7s>", $_[0], $_[1], $d, $t, $_[3], "<$_[4]" ;
 273 }
 274
 275 #
 276 # return all the spots from a day's file as an array of references
 277 # the parameter passed is a julian day
 278 sub readfile
 279 {
 280         my @spots;
 281
 282         my $fh = $fp->open(@_);
 283         if ($fh) {
 284                 my $in;
 285                 while (<$fh>) {
 286                         chomp;
 287                         push @spots, [ split '\^' ];
 288                 }
 289         }
 290         return @spots;
 291 }
 292
 293 # enter the spot for dup checking and return true if it is already a dup
 294 sub dup
 295 {
 296         my ($freq, $call, $d, $text) = @_;
 297
 298         # dump if too old
 299         return 2 if $d < $main::systime - $dupage;
 300
 301         $freq = sprintf "%.1f", $freq;       # normalise frequency
 302         chomp $text;
 303         $text = substr($text, 0, $duplth) if length $text > $duplth;
 304         unpad($text);
 305         $text =~ s/[\\\%]\d+//g;
 306         $text =~ s/[^a-zA-Z0-9]//g;
 307         my $dupkey = "X$freq|$call|$d|\L$text";
 308         return DXDupe::check($dupkey, $main::systime+$dupage);
 309 }
 310
 311 sub listdups
 312 {
 313         return DXDupe::listdups('X', $dupage, @_);
 314 }
 315 1;
 316
 317
 318
 319