my ($self, $line) = @_;
# disguise regexes
- $line =~ s/\{(.*)\}/'{'. unpack('H*', $1) . '}'/eg;
+ $line =~ s/\{(.*?)\}/'{'. unpack('H*', $1) . '}'/eg;
dbg("sh/dx disguise any regex: '$line'") if isdbg('sh/dx');
# now space out brackets and !
$line =~ s/([\(\!\)])/ $1 /g;
- my @list = split /[\s]+/, $line; # split the line up
+ my @list = split /\s+/, $line; # split the line up
# put back the regexes
@list = map { my $l = $_; $l =~ s/\{([0-9a-fA-F]+)\}/'{' . pack('H*', $1) . '}'/eg; $l } @list;
- dbg("sh/dx after regex return: " . join(' ', @list)) if isdbg('sh/dx');
+ dbg("sh/dx after regex return: '" . join(' ', @list) . "'") if isdbg('sh/dx');
my @out;
my $f;
my @flist;
- dbg("sh/dx \@list: " . join(" ", @list)) if isdbg('sh/dx');
+ dbg("sh/dx list: " . join(" ", @list)) if isdbg('sh/dx');
- while ($f = shift @list) { # next field
- dbg "sh/dx arg: $f list: " . join(',', @list) if isdbg('sh/dx');
+ while (@list) { # next field
+ $f = shift @list;
+ dbg("sh/dx arg: $f list: '" . join(',', @list) . "'") if isdbg('sh/dx');
if ($f && !$from && !$to) {
($from, $to) = $f =~ m|^(\d+)[-/](\d+)$| || (0,0); # is it a from -> to count?
dbg("sh/dx from: $from to: $to") if isdbg('sh/dx');
}
if (lc $f eq 'day' && $list[0]) {
($fromday, $today) = split m|[-/]|, shift(@list);
- dbg "sh/dx got day $fromday/$today" if isdbg('sh/dx');
+ dbg("sh/dx got day $fromday/$today") if isdbg('sh/dx');
next;
}
if (lc $f eq 'exact') {
dbg("sh/dx operator $f") if isdbg('sh/dx');
next;
}
- if (grep {lc $f eq $_} qw(on freq call info spotter by dxcc call_dxcc by_dxcc bydxcc origin call_itu itu call_zone zone byitu by_itu by_zone byzone call_state state bystate by_state ip) ) {
+ if (grep {lc $f eq $_} qw(on freq call info spotter by dxcc call_dxcc by_dxcc bydxcc origin call_itu itu call_zone zone cq bycq byitu by_itu by_zone byzone call_state state bystate by_state ip) ) {
push @flist, $f;
push @flist, shift @list if @list;
dbg("sh/dx function $flist[-2] $flist[-1]") if isdbg('sh/dx');
push @flist, $f;
}
+ dbg("sh/dx: flist = '" . join(',', @flist). "'") if isdbg('sh/dx');
if ($pre) {
# someone (probably me) has forgotten the 'info' keyword
}
my $newline = join(' ', @flist);
- dbg("sh/dx newline: $newline") if isdbg('sh/dx');
+ dbg("sh/dx newline: '$newline'") if isdbg('sh/dx');
my ($r, $filter, $fno, $user, $expr) = $Spot::filterdef->parse($self, 'spots', $newline, 1);
return (0, "sh/dx parse error '$r' " . $filter) if $r;
$user ||= '';
$expr ||= '';
- dbg "sh/dx user: $user expr: $expr from: $from to: $to fromday: $fromday today: $today" if isdbg('sh/dx');
+ dbg("sh/dx user: $user expr: $expr from: $from to: $to fromday: $fromday today: $today") if isdbg('sh/dx');
# now do the search
--- /dev/null
+#
+# A light shim over JSON for DXSpider general purpose serialising
+#
+# Copyright (c) 2020 Dirk Koopman, G1TLH
+#
+
+package DXJSON;
+
+use strict;
+use warnings;
+
+use JSON;
+use Data::Structure::Util qw(unbless);
+use DXDebug;
+use DXUtil;
+
+our @ISA = qw(JSON);
+
+sub new
+{
+ return shift->SUPER::new()->canonical(1);
+}
+
+sub encode
+{
+ my $json = shift;
+ my $ref = shift;
+ my $name = ref $ref;
+
+ unbless($ref) if $name && $name ne 'HASH';
+ my $s;
+
+ eval {$s = $json->SUPER::encode($ref) };
+ if ($s && !$@) {
+ bless $ref, $name if $name && $name ne 'HASH';
+ return $s;
+ }
+ else {
+ $s = dd($ref);
+ dbg "DXJSON::encode '$s' - $@";
+ }
+}
+
+sub decode
+{
+ my $json = shift;
+ my $s = shift;
+ my $name = shift;
+
+ my $ref;
+ eval { $ref = $json->SUPER::decode($s) };
+ if ($ref && !$@) {
+ return bless $ref, $name if $name;
+ return $ref;
+ }
+ else {
+ dbg "DXJSON::decode '$s' - $@";
+ }
+ return undef;
+}
+
+1;
use Data::Structure::Util qw(unbless);
use Time::HiRes qw(gettimeofday tv_interval);
use IO::File;
-use JSON;
+use DXJSON;
use strict;
{
my $mode = shift;
- $json = JSON->new->canonical(1);
+ $json = DXJSON->new->canonical(1);
my $fn = "users";
$filename = localdata("$fn.v3j");
unless (-e $filename || $mode == 2) {
# thaw the user
sub decode
{
- my $s = shift;
- my $ref;
- eval { $ref = $json->decode($s) };
- if ($ref && !$@) {
- return bless $ref, 'DXUser';
- } else {
- LogDbg('DXUser', "DXUser::json_decode: on '$s' $@");
- }
- return undef;
+ return $json->decode(shift, __PACKAGE__);
}
# freeze the user
sub encode
{
- my $ref = shift;
- unbless($ref);
- my $s;
-
- eval {$s = $json->encode($ref) };
- if ($s && !$@) {
- bless $ref, 'DXUser';
- return $s;
- } else {
- LogDbg('DXUser', "DXUser::json_encode $ref->{call}, $@");
- }
+ return $json->encode(shift);
}
use DXDebug;
use Data::Dumper;
use Prefix;
+use DXLog;
+use DXJSON;
use strict;
$filterbasefn = "$main::root/filter";
$in = undef;
+my $json;
+
# initial filter system
sub init
{
-
+ $json = DXJSON->new->indent(1);
}
sub new
if ($ref->{$ar} && exists $ref->{$ar}->{asc}) {
my $s = $ref->{$ar}->{asc}; # an optimisation?
$s =~ s/\$r/\$_[0]/g;
+# $s =~ s/\\\\/\\/g;
$ref->{$ar}->{code} = eval "sub { $s }" ;
if ($@) {
my $sort = $ref->{sort};
if ($fn = getfn($sort, $call, $flag)) {
$in = undef;
my $s = readfilestr($fn);
- my $newin = eval $s;
+ my $newin;
+ if ($s =~ /^\s*{/) {
+ eval {$newin = $json->decode($s, __PACKAGE__)};
+ } else {
+ $newin = eval $s;
+ }
if ($@) {
dbg($@);
unlink($fn);
return undef;
}
+
+# this writes out the filter in a form suitable to be read in by 'read_in'
+# It expects a list of references to filter lines
+sub write
+{
+ my $self = shift;
+ my $sort = $self->{sort};
+ my $name = $self->{name};
+ my $dir = "$filterbasefn/$sort";
+ my $fn = "$dir/$name";
+
+ mkdir $dir, 0775 unless -e $dir;
+ rename $fn, "$fn.o" if -e $fn;
+ my $fh = new IO::File ">$fn";
+ if ($fh) {
+# my $dd = new Data::Dumper([ $self ]);
+# $dd->Indent(1);
+# $dd->Terse(1);
+# $dd->Quotekeys($] < 5.005 ? 1 : 0);
+ # $fh->print($dd->Dumpxs);
+
+ # remove code references, do the encode, then put them back again (they can't be represented anyway)
+ my $key;
+ foreach $key ($self->getfilkeys) {
+ $self->{$key}->{reject}->{code} = undef if exists $self->{$key}->{reject};
+ $self->{$key}->{accept}->{code} = undef if exists $self->{$key}->{accept};
+ }
+ $fh->print($json->encode($self));
+ foreach $key ($self->getfilkeys) {
+ $self->compile($key, 'reject');
+ $self->compile($key, 'accept');
+ }
+ $fh->close;
+ } else {
+ rename "$fn.o", $fn if -e "$fn.o";
+ return "$fn $!";
+ }
+ return undef;
+}
+
sub getfilters
{
my $self = shift;
return ($r, $hops);
}
-# this writes out the filter in a form suitable to be read in by 'read_in'
-# It expects a list of references to filter lines
-sub write
-{
- my $self = shift;
- my $sort = $self->{sort};
- my $name = $self->{name};
- my $dir = "$filterbasefn/$sort";
- my $fn = "$dir/$name";
-
- mkdir $dir, 0775 unless -e $dir;
- rename $fn, "$fn.o" if -e $fn;
- my $fh = new IO::File ">$fn";
- if ($fh) {
- my $dd = new Data::Dumper([ $self ]);
- $dd->Indent(1);
- $dd->Terse(1);
- $dd->Quotekeys($] < 5.005 ? 1 : 0);
- $fh->print($dd->Dumpxs);
- $fh->close;
- } else {
- rename "$fn.o", $fn if -e "$fn.o";
- return "$fn $!";
- }
- return undef;
-}
-
sub print
{
my $self = shift;
}
}
+
+
package Filter::Cmd;
use strict;
use vars qw(@ISA);
@ISA = qw(Filter);
+sub encode_regex
+{
+ my $s = shift;
+ $s =~ s/\{(.*?)\}/'{'. unpack('H*', $1) . '}'/eg if $s;
+ return $s;
+}
+
+sub decode_regex
+{
+ my $r = shift;
+ my ($v) = $r =~ /^\{(.*?)}$/;
+ return pack('H*', $v);
+}
+
+
# the general purpose command processor
# this is called as a subroutine not as a method
sub parse
$line = lc $line;
# disguise regexes
- $line =~ s/\{(.*)\}/'{'. unpack('H*', $1) . '}'/eg;
+
dbg("Filter parse line after regex check: '$line'") if isdbg('filter');
+ $line = encode_regex($line);
# add some spaces for ease of parsing
$line =~ s/([\(\!\)])/ $1 /g;
my @f = split /\s+/, $line;
-
- my $conj = ' && ';
- my $not = "";
+ dbg("filter parse: tokens '" . join("' '", @f) . "'") if isdbg('filter');
+
my $lasttok = '';
while (@f) {
if ($ntoken == 0) {
# do the rest of the filter tokens
if (@f) {
my $tok = shift @f;
- if ($tok eq '(') {
- if ($s) {
- unless ($lasttok eq '(') {
- $s .= $conj ;
- $user .= $conj;
- }
- $conj = "";
- $lasttok = $tok;
- }
- if ($not) {
- $s .= $not;
- $user .= $not;
- $not = "";
- }
- $s .= $tok;
- $user .= $tok;
- $lasttok = $tok;
- next;
- } elsif ($tok eq ')') {
- $conj = ' && ';
- $not ="";
- $s .= $tok;
- $user .= $tok;
- $lasttok = $tok;
- next;
- } elsif ($tok eq 'all') {
+
+ dbg("filter::parse: tok '$tok'") if isdbg('filter');
+
+ if ($tok eq 'all') {
$s .= '1';
$user .= $tok;
last;
- } elsif ($tok eq 'or') {
- $conj = ' || ' if $conj ne ' || ';
- $lasttok = $tok;
- next;
- } elsif ($tok eq 'and') {
- $conj = ' && ' if $conj ne ' && ';
+ } elsif (grep $tok eq $_, qw{and or not ( )}) {
+ $s .= ' && ' if $tok eq 'and';
+ $s .= ' || ' if $tok eq 'or';
+ $s .= ' !' if $tok eq 'not';
+ $s .= $tok if $tok eq '(' or $tok eq ')';
+ $user .= " $tok ";
next;
- } elsif ($tok eq 'not' || $tok eq '!') {
- $not = '! ';
- $lasttok = $tok;
+ } elsif ($tok eq '') {
next;
}
+
if (@f) {
my $val = shift @f;
my @val = split /,/, $val;
- if ($s) {
- unless ($lasttok eq '(') {
- $s .= $conj ;
- $user .= $conj;
- $conj = ' && ';
- }
- }
- if ($not) {
- $s .= $not;
- $user .= $not;
- $not = '';
- }
-
- $user .= "$tok $val";
+ dbg("filter::parse: tok '$tok' val '$val'") if isdbg('filter');
+ $user .= " $tok $val";
my $fref;
my $found;
$v =~ s/\*//g; # remove any trailing *
if (my ($r) = $v =~ /^\{(.*)\}$/) { # we have a regex
dbg("Filter::parse regex b: '\{$r\}'") if isdbg('filter');
- $v = pack('H*', $r);
+ $v = decode_regex($v);
dbg("Filter::parse regex a: '$v'") if isdbg('filter');
return ('regex', $dxchan->msg('e38', $v)) unless (qr{$v});
+ push @t, "\$r->[$fref->[2]]=~m{$v}i";
+ $v = "{$r}"; # put it back together again for humans
+ } else {
+ push @t, "\$r->[$fref->[2]]=~m{$v}i";
}
- push @t, "\$r->[$fref->[2]]=~m{$v}i";
}
$s .= "(" . join(' || ', @t) . ")";
+ dbg("filter parse: s '$s'") if isdbg('filter');
} elsif ($fref->[1] eq 'c') {
my @t;
for (@val) {
push @t, "\$r->[$fref->[2]]=~m{^\U$_}";
}
$s .= "(" . join(' || ', @t) . ")";
+ dbg("filter parse: s '$s'") if isdbg('filter');
} elsif ($fref->[1] eq 'n') {
my @t;
for (@val) {
push @t, "\$r->[$fref->[2]]==$_";
}
$s .= "(" . join(' || ', @t) . ")";
+ dbg("filter parse: s '$s'") if isdbg('filter');
} elsif ($fref->[1] =~ /^n[ciz]$/ ) { # for DXCC, ITU, CQ Zone
my $cmd = $fref->[1];
my @pre = Prefix::to_ciz($cmd, @val);
return ('numpre', $dxchan->msg('e27', $_)) unless @pre;
$s .= "(" . join(' || ', map {"\$r->[$fref->[2]]==$_"} @pre) . ")";
+ dbg("filter parse: s '$s'") if isdbg('filter');
} elsif ($fref->[1] =~ /^ns$/ ) { # for DXCC, ITU, CQ Zone
my $cmd = $fref->[1];
my @pre = Prefix::to_ciz($cmd, @val);
return ('numpre', $dxchan->msg('e27', $_)) unless @pre;
$s .= "(" . "!\$USDB::present || grep \$r->[$fref->[2]] eq \$_, qw(" . join(' ' ,map {uc} @pre) . "))";
+ dbg("filter parse: s '$s'") if isdbg('filter');
} elsif ($fref->[1] eq 'r') {
my @t;
for (@val) {
push @t, "(\$r->[$fref->[2]]>=$1 && \$r->[$fref->[2]]<=$2)";
}
$s .= "(" . join(' || ', @t) . ")";
+ dbg("filter parse: s '$s'") if isdbg('filter');
} else {
confess("invalid filter function $fref->[1]");
}
last;
}
}
- return (1, $dxchan->msg('e20', $tok)) unless $found;
+ return (1, $dxchan->msg('e20', $lasttok)) unless $found;
} else {
- return (1, $dxchan->msg('filter2', $tok));
+ my $s = '{' . decode_regex($tok) . '}' if $tok =~ /^{.*}$/;
+ return (1, $dxchan->msg('filter2', $s));
}
$lasttok = $tok;
}
# tidy up the user string (why I have to stick in an if statement when I have initialised it I have no idea! 5.28 bug?
if ($user) {
+ $user =~ s/\)\s*\(/ and /g;
$user =~ s/\&\&/ and /g;
$user =~ s/\|\|/ or /g;
$user =~ s/\!/ not /g;
$user =~ s/\s+/ /g;
+ $user =~ s/\{(.*?)\}/'{'. pack('H*', $1) . '}'/eg;
+ $user =~ s/^\s+//;
+ dbg("filter parse: user '$user'") if isdbg('filter');
}
+
+ if ($s) {
+ $s =~ s/\)\s*\(/ && /g;
+ dbg("filter parse: s '$s'") if isdbg('filter');
+ }
+
return (0, $filter, $fno, $user, $s);
}
e17 => 'Please don\'t use the words: @_ on here',
e18 => 'Cannot connect to $_[0] ($!)',
e19 => 'Invalid character in line',
- e20 => 'token $_[0] not recognised',
+ e20 => qq{token '$_[0]' not recognised},
e21 => '$_[0] is not numeric',
e22 => '$_[0] is not a callsign',
e23 => '$_[0] is not a range (eg 0/30000)',
use DB_File;
use DXDebug;
use Prefix;
-use JSON;
+use DXJSON;
use Data::Structure::Util qw(unbless);
use vars qw($qslfn $dbm $maxentries);
my $mode = shift;
my $ufn = localdata("$qslfn.v1j");
- $json = JSON->new->canonical(1);
+ $json = DXJSON->new;
Prefix::load() unless Prefix::loaded();
# thaw the user
sub decode
{
- my $s = shift;
- my $ref;
- eval { $ref = $json->decode($s) };
- if ($ref && !$@) {
- return bless $ref, 'QSL';
- }
- return undef;
+ return $json->decode($_[0], __PACKAGE__);
}
# freeze the user
sub encode
{
- my $ref = shift;
- unbless($ref);
- my $s;
-
- eval {$s = $json->encode($ref) };
- if ($s && !$@) {
- bless $ref, 'QSL';
- return $s;
- }
+ return $json->encode($_[0]);
}
1;
use 5.10.1;
+use lib qw {.};
+
use DXDebug;
use DXUtil;
use DXLog;
use DXChannel;
use Math::Round qw(nearest);
use Date::Parse;
-use Time::HiRes qw(clock_gettime CLOCK_REALTIME);
+use Time::HiRes qw(gettimeofday);
use Spot;
-use JSON;
+use DXJSON;
use IO::File;
+use constant {
+ ROrigin => 0,
+ RQrg => 1,
+ RCall => 2,
+ RMode => 3,
+ RStrength => 4,
+ RTime => 5,
+ RUtz => 6,
+ Respot => 7,
+ RQra => 8,
+ RSpotData => 9,
+ };
+
+use constant {
+ SQrg => 0,
+ SCall => 1,
+ STime => 2,
+ SComment => 3,
+ SOrigin => 4,
+ SZone => 11,
+ };
+
+
our @ISA = qw(DXChannel);
our $startup_delay = 5*60; # don't send anything out until this timer has expired
sub init
{
- $json = JSON->new;
+ $json = DXJSON->new;
$spots = {};
if (check_cache()) {
$noinrush = 1;
my @ans;
# my $spots = $self->{spot};
- # save this for them's that need it
- my $rawline = $line;
-
# remove leading and trailing spaces
chomp $line;
$line =~ s/^\s*//;
# per second (limited by the test program's output and network speed, rather than DXSpider's handling).
my $nqrg = nearest(1, $qrg); # normalised to nearest Khz
+# my $nqrg = nearest_even($qrg); # normalised to nearest Khz
my $sp = "$call|$nqrg"; # hopefully the skimmers will be calibrated at least this well!
my $spp = sprintf("$call|%d", $nqrg+1); # but, clearly, my hopes are rudely dashed
my $spm = sprintf("$call|%d", $nqrg-1); # in BOTH directions!
# here we either have an existing spot record buildup on the go, or we need to create the first one
unless ($spot) {
- $spots->{$sp} = $spot = [clock_gettime(CLOCK_REALTIME)];;
+ $spots->{$sp} = $spot = [$main::systime];
dbg("RBN: key: '$sp' call: $call qrg: $qrg NEW" . ($respot ? ' RESPOT' : '')) if isdbg('rbn');
}
# create record and add into the buildup
my $r = [$origin, nearest(.1, $qrg), $call, $mode, $s, $t, $utz, $respot, $u];
- my @s = Spot::prepare($r->[1], $r->[2], $r->[6], '', $r->[0]);
+ my @s = Spot::prepare($r->[RQrg], $r->[RCall], $r->[RUtz], '', $r->[ROrigin]);
if ($s[5] == 666) {
dbg("RBN: ERROR invalid prefix/callsign $call from $origin-# on $qrg, dumped");
return;
my ($want, undef) = $self->{inrbnfilter}->it($s);
return unless $want;
}
- $r->[9] = \@s;
+ $r->[RSpotData] = \@s;
push @{$self->{queue}}, $sp if @$spot == 1; # queue the KEY (not the record)
push @$spot, $r;
# At this point we run the queue to see if anything can be sent onwards to the punter
- my $now = clock_gettime(CLOCK_REALTIME);
+ my $now = $main::systime;
# now run the waiting queue which just contains KEYS ($call|$qrg)
foreach $sp (@{$self->{queue}}) {
$quality = 9 if $quality > 9;
$quality = "Q:$quality";
if (isdbg('progress')) {
- my $s = "RBN: SPOT key: '$sp' = $r->[2] on $r->[1] by $r->[0] \@ $r->[5] $quality";
+ my $s = "RBN: SPOT key: '$sp' = $r->[RCall] on $r->[RQrg] by $r->[ROrigin] \@ $r->[RTime] $quality";
$s .= " route: $self->{call}";
dbg($s);
}
}
}
-sub per_minute
-{
- foreach my $dxchan (DXChannel::get_all()) {
- next unless $dxchan->is_rbn;
- dbg "RBN:STATS minute $dxchan->{call} raw: $dxchan->{noraw} sent: $dxchan->{norbn} delivered: $dxchan->{nospot} users: " . scalar keys %{$dxchan->{nousers}} if isdbg('rbnstats');
- if ($dxchan->{noraw} == 0 && $dxchan->{lasttime} > 60) {
- LogDbg('RBN', "RBN: no input from $dxchan->{call}, disconnecting");
- $dxchan->disconnect;
- }
- $dxchan->{noraw} = $dxchan->{norbn} = $dxchan->{nospot} = 0; $dxchan->{nousers} = {};
- $runtime{$dxchan->{call}} += 60;
- }
-
- # save the spot cache
- write_cache() unless $main::systime + $startup_delay < $main::systime;;
-}
-
-sub per_10_minute
-{
- my $count = 0;
- my $removed = 0;
- while (my ($k,$v) = each %{$spots}) {
- if ($main::systime - $v->[0] > $minspottime*2) {
- delete $spots->{$k};
- ++$removed;
- }
- else {
- ++$count;
- }
- }
- dbg "RBN:STATS spot cache remain: $count removed: $removed"; # if isdbg('rbn');
- foreach my $dxchan (DXChannel::get_all()) {
- next unless $dxchan->is_rbn;
- dbg "RBN:STATS 10-minute $dxchan->{call} raw: $dxchan->{noraw10} sent: $dxchan->{norbn10} delivered: $dxchan->{nospot10} users: " . scalar keys %{$dxchan->{nousers10}};
- $dxchan->{noraw10} = $dxchan->{norbn10} = $dxchan->{nospot10} = 0; $dxchan->{nousers10} = {};
- }
-}
-
-sub per_hour
-{
- foreach my $dxchan (DXChannel::get_all()) {
- next unless $dxchan->is_rbn;
- dbg "RBN:STATS hour $dxchan->{call} raw: $dxchan->{norawhour} sent: $dxchan->{norbnhour} delivered: $dxchan->{nospothour} users: " . scalar keys %{$dxchan->{nousershour}};
- $dxchan->{norawhour} = $dxchan->{norbnhour} = $dxchan->{nospothour} = 0; $dxchan->{nousershour} = {};
- }
-}
-
# we should get the spot record minus the time, so just an array of record (arrays)
sub send_dx_spot
{
++$self->{nousers}->{$call};
++$self->{nousers10}->{$call};
++$self->{nousershour}->{$call};
-
+
+ my $filtered;
+ my $rf = $dxchan->{rbnfilter} || $dxchan->{spotsfilter};
foreach my $r (@$spot) {
# $r = [$origin, $qrg, $call, $mode, $s, $t, $utz, $respot, $qra];
# Spot::prepare($qrg, $call, $utz, $comment, $origin);
- my $comment = sprintf "%-3s %2ddB $quality", $r->[3], $r->[4];
- $respot = 1 if $r->[7];
- $qra = $r->[8] if !$qra && $r->[8] && is_qra($r->[8]);
+ my $comment = sprintf "%-3s %2ddB $quality", $r->[RMode], $r->[RStrength];
+ $respot = 1 if $r->[Respot];
+ $qra = $r->[RQra] if !$qra && $r->[RQra] && is_qra($r->[RQra]);
- my $s = $r->[9]; # the prepared spot
- $s->[3] = $comment; # apply new generated comment
+ my $s = $r->[RSpotData]; # the prepared spot
+ $s->[SComment] = $comment; # apply new generated comment
- ++$zone{$s->[11]}; # save the spotter's zone
- ++$qrg{$s->[0]}; # and the qrg
+ ++$zone{$s->[SZone]}; # save the spotter's zone
+ ++$qrg{$s->[SQrg]}; # and the qrg
- my $want = 0;
- my $rf = $dxchan->{rbnfilter} || $dxchan->{spotsfilter};
- if ($rf) {
- ($want, undef) = $rf->it($s);
- next unless $want;
+ # save the lowest strength one
+ if ($r->[RStrength] < $strength) {
+ $strength = $r->[RStrength];
$saver = $s;
- dbg("RBN: FILTERED call: $s->[1] qrg: $s->[0] origin: $s->[4] dB: $r->[4]") if isdbg 'rbn';
- last;
+ dbg("RBN: STRENGTH spot: $s->[SCall] qrg: $s->[SQrg] origin: $s->[SOrigin] dB: $r->[RStrength] < $strength") if isdbg 'rbnll';
}
- # save the lowest strength one
- if ($r->[4] < $strength) {
- $strength = $r->[4];
- $saver = $s;
- dbg("RBN: STRENGTH call: $s->[1] qrg: $s->[0] origin: $s->[4] dB: $r->[4]") if isdbg 'rbn';
+ if ($rf) {
+ my ($want, undef) = $rf->it($s);
+ dbg("RBN: FILTERING for $call spot: $s->[SCall] qrg: $s->[SQrg] origin: $s->[SOrigin] dB: $r->[RStrength] com: '$s->[SComment]' want: " . ($want ? 'YES':'NO')) if isdbg 'rbnll';
+ next unless $want;
+ $filtered = $s;
+# last;
}
}
+ if ($rf) {
+ $saver = $filtered; # if nothing passed the filter's lips then $saver == $filtered == undef !
+ }
+
if ($saver) {
my $buf;
# create a zone list of spotters
- delete $zone{$saver->[11]}; # remove this spotter's zone (leaving all the other zones)
+ delete $zone{$saver->[SZone]}; # remove this spotter's zone (leaving all the other zones)
my $z = join ',', sort {$a <=> $b} keys %zone;
# determine the most likely qrg and then set it
$fk = $k, $mv = $v if $v > $mv;
++$c;
}
- $saver->[0] = $fk;
- $saver->[3] .= '*' if $c > 1;
- $saver->[3] .= '+' if $respot;
- $saver->[3] .= " Z:$z" if $z;
+ $saver->[SQrg] = $fk;
+ $saver->[SComment] .= '*' if $c > 1;
+ $saver->[SComment] .= '+' if $respot;
+ $saver->[SComment] .= " Z:$z" if $z;
- dbg("RBN: SENDING call: $saver->[1] qrg: $saver->[0] origin: $saver->[4] $saver->[3]") if isdbg 'rbn';
+ dbg("RBN: SENDING to $call spot: $saver->[SCall] qrg: $saver->[SQrg] origin: $saver->[SOrigin] $saver->[SComment]") if isdbg 'rbnll';
if ($dxchan->{ve7cc}) {
- my $call = $saver->[4];
- $saver->[4] .= '-#';
+ my $call = $saver->[SOrigin];
+ $saver->[SOrigin] .= '-#';
$buf = VE7CC::dx_spot($dxchan, @$saver);
- $saver->[4] = $call;
+ $saver->[SOrigin] = $call;
} else {
- my $call = $saver->[4];
- $saver->[4] = substr($call, 0, 6);
- $saver->[4] .= '-#';
+ my $call = $saver->[SOrigin];
+ $saver->[SOrigin] = substr($call, 0, 6);
+ $saver->[SOrigin] .= '-#';
$buf = $dxchan->format_dx_spot(@$saver);
- $saver->[4] = $call;
+ $saver->[SOrigin] = $call;
}
# $buf =~ s/^DX/RB/;
$dxchan->local_send('N', $buf);
++$self->{nospothour};
if ($qra) {
- my $user = DXUser::get_current($saver->[1]) || DXUser->new($saver->[1]);
+ my $user = DXUser::get_current($saver->[SCall]) || DXUser->new($saver->[SCall]);
unless ($user->qra && is_qra($user->qra)) {
$user->qra($qra);
- dbg("RBN: update qra on $saver->[1] to $qra");
+ dbg("RBN: update qra on $saver->[SCall] to $qra");
$user->put;
}
}
}
}
+
+sub per_minute
+{
+ foreach my $dxchan (DXChannel::get_all()) {
+ next unless $dxchan->is_rbn;
+ dbg "RBN:STATS minute $dxchan->{call} raw: $dxchan->{noraw} sent: $dxchan->{norbn} delivered: $dxchan->{nospot} users: " . scalar keys %{$dxchan->{nousers}} if isdbg('rbnstats');
+ if ($dxchan->{noraw} == 0 && $dxchan->{lasttime} > 60) {
+ LogDbg('RBN', "RBN: no input from $dxchan->{call}, disconnecting");
+ $dxchan->disconnect;
+ }
+ $dxchan->{noraw} = $dxchan->{norbn} = $dxchan->{nospot} = 0; $dxchan->{nousers} = {};
+ $runtime{$dxchan->{call}} += 60;
+ }
+
+ # save the spot cache
+ write_cache() unless $main::systime + $startup_delay < $main::systime;;
+}
+
+sub per_10_minute
+{
+ my $count = 0;
+ my $removed = 0;
+ while (my ($k,$v) = each %{$spots}) {
+ if ($main::systime - $v->[0] > $minspottime*2) {
+ delete $spots->{$k};
+ ++$removed;
+ }
+ else {
+ ++$count;
+ }
+ }
+ dbg "RBN:STATS spot cache remain: $count removed: $removed"; # if isdbg('rbn');
+ foreach my $dxchan (DXChannel::get_all()) {
+ next unless $dxchan->is_rbn;
+ dbg "RBN:STATS 10-minute $dxchan->{call} raw: $dxchan->{noraw10} sent: $dxchan->{norbn10} delivered: $dxchan->{nospot10} users: " . scalar keys %{$dxchan->{nousers10}};
+ $dxchan->{noraw10} = $dxchan->{norbn10} = $dxchan->{nospot10} = 0; $dxchan->{nousers10} = {};
+ }
+}
+
+sub per_hour
+{
+ foreach my $dxchan (DXChannel::get_all()) {
+ next unless $dxchan->is_rbn;
+ dbg "RBN:STATS hour $dxchan->{call} raw: $dxchan->{norawhour} sent: $dxchan->{norbnhour} delivered: $dxchan->{nospothour} users: " . scalar keys %{$dxchan->{nousershour}};
+ $dxchan->{norawhour} = $dxchan->{norbnhour} = $dxchan->{nospothour} = 0; $dxchan->{nousershour} = {};
+ }
+}
+
sub finish
{
write_cache();
['call_itu', 'ni', 8],
['itu', 'ni', 8],
['call_zone', 'nz', 9],
+ ['cq', 'nz', 9],
['zone', 'nz', 9],
['by_itu', 'ni', 10],
['byitu', 'ni', 10],
['by_zone', 'nz', 11],
['byzone', 'nz', 11],
+ ['bycq', 'nz', 11],
['call_state', 'ns', 12],
['state', 'ns', 12],
['by_state', 'ns', 13],
dbg("loading user file system ...");
DXUser::init(4); # version 4 == json format
+ Filter::init(); # doesn't do much, but has to be done
+
+
# look for the sysop and the alias user and complain if they aren't there
{
die "\$myalias \& \$mycall are the same ($mycall)!, they must be different (hint: make \$mycall = '${mycall}-2';). Oh and don't forget to rerun create_sysop.pl!" if $mycall eq $myalias;
#
# grepdbg [nn] [-mm] <regular expression>
#
-
# nn - is the day you what to look at: 1 is yesterday, 0 is today
# and is optional if there is only one argument
#
# <regexp> is the regular expression you are searching for,
# a caseless search is done
#
+# If you specify something that likes a filename and that filename
+# has a .pm on the end of it and it exists then rather than doing
+# the regex match it executes the "main::handle()" function passing
+# it one line at a time.
+#
#
require 5.004;
push @list, $arg;
} elsif ($arg =~ /^\d+$/) {
$nolines = $arg;
+ } elsif ($arg =~ /\.pm$/) {
+ if (-e $arg) {
+ my $fn = $arg;
+ $fn =~ s/\.pm$//;
+ eval { require $arg};
+ die "requiring $fn failed $@" if $@;
+ } else {
+ die "$arg not found";
+ }
} else {
$string = $arg;
last;
my $now = $today->sub($entry);
my $fh = $fp->open($now);
my $line;
+ my $do;
+
+ if (main->can('handle')) {
+ $do = \&handle;
+ } else {
+ $do = \&process;
+ }
+
+ begin() if main->can('begin');
if ($fh) {
while (<$fh>) {
- process($_);
+ &$do($_);
}
$fp->close();
}
+ end() if main->can('end');
}
sub process
for (@prev) {
s/([\x00-\x1f\x7f-\xff])/sprintf("\\x%02X", ord($1))/eg;
my ($t, $l) = split /\^/, $_, 2;
- print atime($t), ' ', $l, "\n";
+ print atime($t), ' ', $l, "\n";
+ print '----------------' if $nolines > 1;
}
@prev = ();
}
sub usage
{
- die "usage: grepdbg [nn] [[-nnn] ..] <regexp>\n";
+ die "usage: grepdbg [nn days before] [-nnn lines before] [<regexp>|<perl file name>]\n";
}
exit(0);
projects / spider.git / commitdiff