use DXUtil;
use DXM;
use DXDebug;
+use Carp;
use strict;
dx => '0,DX Spots,yesno',
);
-
# create a new channel object [$obj = DXChannel->new($call, $msg_conn_obj, $user_obj)]
sub alloc
{
foreach $line (@_) {
chomp $line;
- dbg('chan', "-> $sort $call $line\n");
- $conn->send_now("$sort$call|$line");
+ dbg('chan', "-> $sort $call $line\n") if $conn;
+ $conn->send_now("$sort$call|$line") if $conn;
}
$self->{t} = time;
}
foreach $line (@_) {
chomp $line;
- dbg('chan', "-> D $call $line\n");
- $conn->send_later("D$call|$line");
+ dbg('chan', "-> D $call $line\n") if $conn;
+ $conn->send_later("D$call|$line") if $conn;
}
$self->{t} = time;
}
return if $name =~ /::DESTROY$/;
$name =~ s/.*:://o;
- die "Non-existant field '$AUTOLOAD'" if !$valid{$name};
+ confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
@_ ? $self->{$name} = shift : $self->{$name} ;
}
use Exporter;
@ISA = qw(Exporter);
+use Carp;
+use DXDebug;
use strict;
my %cluster = (); # this is where we store the dxcluster database
my %valid = (
- mynode => '0,Parent Node',
+ mynode => '0,Parent Node,showcall',
call => '0,Callsign',
confmode => '0,Conference Mode,yesno',
here => '0,Here?,yesno',
dxchan => '5,Channel ref',
pcversion => '5,Node Version',
list => '5,User List,dolist',
+ users => '0,No of Users',
);
sub alloc
{
- my ($pkg, $call, $confmode, $here, $dxchan) = @_;
+ my ($pkg, $dxchan, $call, $confmode, $here) = @_;
die "$call is already alloced" if $cluster{$call};
my $self = {};
$self->{call} = $call;
return $valid{$ele};
}
+# this expects a reference to a list in a node NOT a ref to a node
sub dolist
{
+ my $self = shift;
+ my $out;
+ my $ref;
+
+ foreach $ref (@{$self}) {
+ my $s = $ref->{call};
+ $s = "($s)" if !$ref->{here};
+ $out .= "$s ";
+ }
+ chop $out;
+ return $out;
+}
+# this expects a reference to a node
+sub showcall
+{
+ my $self = shift;
+ return $self->{call};
+}
+
+sub DESTROY
+{
+ my $self = shift;
+ dbg('cluster', "destroying $self->{call}\n");
}
no strict;
return if $name =~ /::DESTROY$/;
$name =~ s/.*:://o;
- die "Non-existant field '$AUTOLOAD'" if !$valid{$name};
+ confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
@_ ? $self->{$name} = shift : $self->{$name} ;
}
@ISA = qw(DXCluster);
+use DXDebug;
+
use strict;
-my %users = ();
+my $users = 0;
sub new
{
- my ($pkg, $mynode, $call, $confmode, $here, $dxchan) = @_;
- my $self = $pkg->alloc($call, $confmode, $here, $dxchan);
- $self->{mynode} = $mynode;
+ my ($pkg, $dxchan, $node, $call, $confmode, $here) = @_;
- $users{$call} = $self;
+ die "tried to add $call when it already exists" if DXCluster->get($call);
+
+ my $self = $pkg->alloc($dxchan, $call, $confmode, $here);
+ $self->{mynode} = $node;
+ $self->{list}->{$call} = $self; # add this user to the list on this node
+ $users++;
+ dbg('cluster', "allocating user $self->{call}\n");
return $self;
}
sub del
{
my $self = shift;
- $self->delcluster(); # out of the whole cluster table
- delete $users{$self->{call}}; # out of the users table
+ my $call = $self->{call};
+ my $node = $self->{mynode};
+
+ delete $node->{list}->{$call};
+ delete $cluster{$call}; # remove me from the cluster table
+ $users-- if $users > 0;
}
sub count
{
- return %users + 1; # + 1 for ME (naf eh!)
+ return $users; # + 1 for ME (naf eh!)
}
no strict;
@ISA = qw(DXCluster);
+use DXDebug;
+
use strict;
-my %nodes = ();
+my $nodes = 0;
sub new
{
- my ($pkg, $call, $confmode, $here, $pcversion, $dxchan) = @_;
- my $self = $pkg->alloc($call, $confmode, $here, $dxchan);
+ my ($pkg, $dxchan, $call, $confmode, $here, $pcversion) = @_;
+ my $self = $pkg->alloc($dxchan, $call, $confmode, $here);
$self->{version} = $pcversion;
- $nodes{$call} = $self;
+ $self->{list} = { } ;
+ $nodes++;
+ dbg('cluster', "allocating node $self->{call}\n");
return $self;
}
-# get a node
-sub get
-{
- my ($pkg, $call) = @_;
- return $nodes{$call};
-}
-
# get all the nodes
sub get_all
{
my $list;
my @out;
- foreach $list (values(%nodes)) {
+ foreach $list (values(%cluster)) {
push @out, $list if $list->{pcversion};
}
return @out;
sub del
{
my $self = shift;
- my $call = $self->call;
-
- DXUser->delete($call); # delete all the users on this node
- delete $nodes{$call};
+ my $call = $self->{call};
+ my $ref;
+
+ # delete all the listed calls
+ foreach $ref (values %{$self->{list}}) {
+ $ref->del(); # this also takes them out of this list
+ }
+ $nodes-- if $nodes > 0;
+}
+
+sub update_users
+{
+ my $self = shift;
+ if (%{$self->{list}}) {
+ $self->{users} = scalar %{$self->{list}};
+ } else {
+ $self->{users} = shift;
+ }
}
sub count
{
- return %nodes + 1; # + 1 for ME!
+ return $nodes; # + 1 for ME!
}
sub dolist
use DXCluster;
use DXProtVars;
use DXCommandmode;
+use Spot;
+use Date::Parse;
+use DXProtout;
use strict;
+my $me; # the channel id for this cluster
+
+sub init
+{
+ my $user = DXUser->get($main::mycall);
+ $me = DXChannel::alloc('DXProt', $main::mycall, undef, $user);
+ $me->{sort} = 'M'; # M for me
+}
+
#
# obtain a new connection this is derived from dxchannel
#
$self->send_now('B',"0");
# send initialisation string
- $self->send($self->pc38()) if DXNode->get_all();
- $self->send($self->pc18());
+ $self->send(pc38()) if DXNode->get_all();
+ $self->send(pc18());
$self->state('normal');
$self->pc50_t(time);
}
return if $pcno < 10 || $pcno > 51;
SWITCH: {
- if ($pcno == 10) {last SWITCH;}
+ if ($pcno == 10) { # incoming talk
+
+ # is it for me or one of mine?
+ my $call = ($field[5] gt ' ') ? $field[5] : $field[2];
+ if ($call eq $main::mycall || grep $_ eq $call, get_all_user_calls()) {
+
+ # yes, it is
+ my $text = unpad($field[3]);
+ my $ref = DXChannel->get($call);
+ $ref->send("$call de $field[1]: $text") if $ref;
+ } else {
+ route($field[2], $line); # relay it on its way
+ }
+ return;
+ }
+
if ($pcno == 11) { # dx spot
+
+ # if this is a 'nodx' node then ignore it
+ last SWITCH if grep $field[7] =~ /^$_/, @DXProt::nodx_node;
+
+ # convert the date to a unix date
+ my $date = $field[3];
+ my $time = $field[4];
+ $date =~ s/^\s*(\d+)-(\w\w\w)-(19\d\d)$/$1 $2 $3/;
+ $time =~ s/^(\d\d)(\d\d)Z$/$1:$2 +0000/;
+ my $d = str2time("$date $time");
+ return if !$d; # bang out (and don't pass on) if date is invalid
+
+ # strip off the leading & trailing spaces from the comment
+ my $text = unpad($field[5]);
+
+ # store it away
+ Spot::add($field[1], $field[2], $d, $text, $field[6]);
+
+ # format and broadcast it to users
+ my $spotter = $field[6];
+ $spotter =~ s/^(\w+)-\d+/$1/; # strip off the ssid from the spotter
+ $spotter .= ':'; # add a colon
+
+ # send orf to the users
+ my $buf = sprintf "DX de %-7.7s %13.13s %-12.12s %-30.30s %5.5s\a\a", $spotter, $field[1], $field[2], $text, $field[4];
+ broadcast_users($buf);
+
+ last SWITCH;
+ }
+
+ if ($pcno == 12) { # announces
+
+ if ($field[2] eq '*' || $field[2] eq $main::mycall) {
+
+ # strip leading and trailing stuff
+ my $text = unpad($field[3]);
+ my $target = "To Sysops" if $field[4] eq '*';
+ $target = "WX" if $field[6];
+ $target = "To All" if !$target;
+ broadcast_users("$target de $field[1]: $text");
+
+ return if $field[2] eq $main::mycall; # it's routed to me
+ } else {
+ route($field[2], $line);
+ return; # only on a routed one
+ }
last SWITCH;
}
- if ($pcno == 12) {last SWITCH;}
+
if ($pcno == 13) {last SWITCH;}
if ($pcno == 14) {last SWITCH;}
if ($pcno == 15) {last SWITCH;}
- if ($pcno == 16) {last SWITCH;}
- if ($pcno == 17) {last SWITCH;}
- if ($pcno == 18) {last SWITCH;}
- if ($pcno == 19) {last SWITCH;}
+
+ if ($pcno == 16) { # add a user
+ my $node = DXCluster->get($field[1]);
+ last SWITCH if !$node; # ignore if havn't seen a PC19 for this one yet
+ my $i;
+
+ for ($i = 2; $i < $#field-1; $i++) {
+ my ($call, $confmode, $here) = $field[$i] =~ /^(\w+) (-) (\d)/o;
+ next if length $call < 3;
+ next if !$confmode;
+ $call =~ s/^(\w+)-\d+/$1/; # remove ssid
+ next if DXCluster->get($call); # we already have this (loop?)
+
+ $confmode = $confmode eq '*';
+ DXNodeuser->new($self, $node, $call, $confmode, $here);
+ }
+ last SWITCH;
+ }
+
+ if ($pcno == 17) { # remove a user
+ my $ref = DXCluster->get($field[1]);
+ $ref->del() if $ref;
+ last SWITCH;
+ }
+
+ if ($pcno == 18) { # link request
+
+ # send our nodes
+ my $hops = get_hops(19);
+ $self->send($me->pc19(get_all_ak1a()));
+
+ # get all the local users and send them out
+ $self->send($me->pc16(get_all_users()));
+ $self->send(pc20());
+ last SWITCH;
+ }
+
+ if ($pcno == 19) { # incoming cluster list
+ my $i;
+ for ($i = 1; $i < $#field-1; $i += 4) {
+ my $here = $field[$i];
+ my $call = $field[$i+1];
+ my $confmode = $field[$i+2] eq '*';
+ my $ver = $field[$i+3];
+
+ # now check the call over
+ next if DXCluster->get($call); # we already have this
+
+ # check for sane parameters
+ next if $ver < 5000; # only works with version 5 software
+ next if length $call < 3; # min 3 letter callsigns
+ DXNode->new($self, $call, $confmode, $here, $ver);
+ }
+ last SWITCH;
+ }
+
if ($pcno == 20) { # send local configuration
- # set our data (manually 'cos we only have a psuedo channel [at the moment])
- my $hops = $self->get_hops();
- $self->send("PC19^1^$main::mycall^0^$DXProt::myprot_version^$hops^");
+ # send our nodes
+ my $hops = get_hops(19);
+ $self->send($me->pc19(get_all_ak1a()));
# get all the local users and send them out
- my @list;
- for (@list = DXCommandmode::get_all(); @list; ) {
- @list = $self->pc16(@list);
- my $out = shift @list;
- $self->send($out);
- }
- $self->send($self->pc22());
+ $self->send($me->pc16(get_all_users()));
+ $self->send(pc22());
return;
}
+
if ($pcno == 21) { # delete a cluster from the list
-
+ my $ref = DXCluster->get($field[1]);
+ $ref->del() if $ref;
last SWITCH;
}
+
if ($pcno == 22) {last SWITCH;}
if ($pcno == 23) {last SWITCH;}
if ($pcno == 24) {last SWITCH;}
if ($pcno == 47) {last SWITCH;}
if ($pcno == 48) {last SWITCH;}
if ($pcno == 49) {last SWITCH;}
- if ($pcno == 50) {
+
+ if ($pcno == 50) { # keep alive/user list
+ my $ref = DXCluster->get($field[1]);
+ $ref->update_users($field[2]) if $ref;
last SWITCH;
}
+
if ($pcno == 51) { # incoming ping requests/answers
# is it for us?
$self->send($self->pc51($field[2], $field[1], $flag));
} else {
# route down an appropriate thingy
- $self->route($field[1], $line);
+ route($field[1], $line);
}
return;
}
}
# if get here then rebroadcast the thing with its Hop count decremented (if
- # the is one). If it has a hop count and it decrements to zero then don't
+ # there is one). If it has a hop count and it decrements to zero then don't
# rebroadcast it.
#
# NOTE - don't arrive here UNLESS YOU WANT this lump of protocol to be
my $newhops = $hops - 1;
if ($newhops > 0) {
$line =~ s/\^H$hops(\^\~?)$/\^H$newhops$1/; # change the hop count
- DXProt->broadcast($line, $self); # send it to everyone but me
+ broadcast_ak1a($line, $self); # send it to everyone but me
}
}
}
#
sub finish
{
-
+ my $self = shift;
+ broadcast_ak1a($self->pc21('Gone.'));
+ $self->delnode();
}
#
sub adduser
{
-
+ DXNodeuser->add(@_);
}
#
sub deluser
{
-
+ my $self = shift;
+ my $ref = DXCluster->get($self->call);
+ $ref->del() if $ref;
}
#
sub addnode
{
-
+ DXNode->new(@_);
}
#
#
sub delnode
{
-
+ my $self = shift;
+ my $ref = DXCluster->get($self->call);
+ $ref->del() if $ref;
}
#
#
# route a message down an appropriate interface for a callsign
#
-# expects $self to indicate 'from' and is called $self->route(to, pcline);
+# is called route(to, pcline);
#
sub route
{
- my ($self, $call, $line) = @_;
+ my ($call, $line) = @_;
my $cl = DXCluster->get($call);
if ($cl) {
my $dxchan = $cl->{dxchan};
}
# broadcast a message to all clusters [except those mentioned after buffer]
-sub broadcast
+sub broadcast_ak1a
{
- my $pkg = shift; # ignored
my $s = shift; # the line to be rebroadcast
my @except = @_; # to all channels EXCEPT these (dxchannel refs)
- my @chan = DXChannel->get_all();
- my ($chan, $except);
+ my @chan = get_all_ak1a();
+ my $chan;
+
+ foreach $chan (@chan) {
+ $chan->send($s) if !grep $chan, @except; # send it if it isn't the except list
+ }
+}
+
+# broadcast to all users
+sub broadcast_users
+{
+ my $s = shift; # the line to be rebroadcast
+ my @except = @_; # to all channels EXCEPT these (dxchannel refs)
+ my @chan = get_all_users();
+ my $chan;
-L: foreach $chan (@chan) {
- next if !$chan->sort eq 'A'; # only interested in ak1a channels
- foreach $except (@except) {
- next L if $except == $chan; # ignore channels in the 'except' list
- }
- chan->send($s); # send it
+ foreach $chan (@chan) {
+ $chan->send($s) if !grep $chan, @except; # send it if it isn't the except list
}
}
#
# gimme all the ak1a nodes
#
-sub get_all
+sub get_all_ak1a
{
my @list = DXChannel->get_all();
my $ref;
my @out;
foreach $ref (@list) {
- push @out, $ref if $ref->sort eq 'A';
+ push @out, $ref if $ref->is_ak1a;
}
return @out;
}
-#
-# obtain the hops from the list for this callsign and pc no
-#
-
-sub get_hops
+# return a list of all users
+sub get_all_users
{
- my ($self, $pcno) = @_;
- return "H$DXProt::def_hopcount"; # for now
-}
-
-#
-# All the PCxx generation routines
-#
-
-#
-# add one or more users (I am expecting references that have 'call',
-# 'confmode' & 'here' method)
-#
-# NOTE this sends back a list containing the PC string (first element)
-# and the rest of the users not yet processed
-#
-sub pc16
-{
- my $self = shift;
- my @list = @_; # list of users
- my @out = ('PC16', $main::mycall);
- my $i;
-
- for ($i = 0; @list && $i < $DXProt::pc16_max_users; $i++) {
- my $ref = shift @list;
- my $call = $ref->call;
- my $s = sprintf "%s %s %d", $call, $ref->confmode ? '*' : '-', $ref->here;
- push @out, $s;
+ my @list = DXChannel->get_all();
+ my $ref;
+ my @out;
+ foreach $ref (@list) {
+ push @out, $ref if $ref->is_user;
}
- push @out, $self->get_hops();
- my $str = join '^', @out;
- $str .= '^';
- return ($str, @list);
-}
-
-# Request init string
-sub pc18
-{
- return "PC18^wot a load of twaddle^$DXProt::myprot_version^~";
+ return @out;
}
-#
-# add one or more nodes
-#
-# NOTE this sends back a list containing the PC string (first element)
-# and the rest of the nodes not yet processed (as PC16)
-#
-sub pc19
+# return a list of all user callsigns
+sub get_all_user_calls
{
- my $self = shift;
- my @list = @_; # list of users
- my @out = ('PC19', $main::mycall);
- my $i;
-
- for ($i = 0; @list && $i < $DXProt::pc19_max_nodes; $i++) {
- my $ref = shift @list;
- push @out, $ref->here, $ref->call, $ref->confmode, $ref->pcversion;
+ my @list = DXChannel->get_all();
+ my $ref;
+ my @out;
+ foreach $ref (@list) {
+ push @out, $ref->call if $ref->is_user;
}
- push @out, $self->get_hops();
- my $str = join '^', @out;
- $str .= '^';
- return ($str, @list);
-}
-
-# end of Rinit phase
-sub pc20
-{
- return 'PC20^';
-}
-
-# delete a node
-sub pc21
-{
- my ($self, $ref, $reason) = @_;
- my $call = $ref->call;
- my $hops = $self->get_hops();
- return "PC21^$call^$reason^$hops^";
-}
-
-# end of init phase
-sub pc22
-{
- return 'PC22^';
+ return @out;
}
-# send all the DX clusters I reckon are connected
-sub pc38
-{
- my @list = DXNode->get_all();
- my $list;
- my @nodes;
-
- foreach $list (@list) {
- push @nodes, $list->call;
- }
- return "PC38^" . join(',', @nodes) . "^~";
-}
+#
+# obtain the hops from the list for this callsign and pc no
+#
-# periodic update of users, plus keep link alive device (always H99)
-sub pc50
+sub get_hops
{
- my $n = DXNodeuser->count;
- return "PC50^$main::mycall^$n^H99^";
+ my ($pcno) = @_;
+ my $hops = $DXProt::hopcount{$pcno};
+ $hops = $DXProt::def_hopcount if !$hops;
+ return "H$hops";
}
-# generate pings
-sub pc51
+# remove leading and trailing spaces from an input string
+sub unpad
{
- my ($self, $to, $from, $val) = @_;
- return "PC51^$to^$from^$val^";
+ my $s = shift;
+ $s =~ s/^\s+|\s+$//;
+ return $s;
}
1;
__END__
# some variable hop counts based on message type
%hopcount = (
- 11 => 25,
+ 11 => 1,
16 => 10,
17 => 10,
19 => 10,
21 => 10,
);
+# list of nodes we don't accept dx from
+@nodx_node = (
+);
+
+# list of nodes we don't accept announces from
+@noann_node = (
+
+);
+
+# list of node we don't accept wwvs from
+@nowwv_node = (
+
+);
+
+1;
--- /dev/null
+#!/usr/bin/perl
+#
+# This module impliments the outgoing PCxx generation routines
+#
+# These are all the namespace of DXProt and are separated for "clarity"
+#
+# Copyright (c) 1998 Dirk Koopman G1TLH
+#
+# $Id$
+#
+
+package DXProt;
+
+@ISA = qw(DXProt DXChannel);
+
+use DXUtil;
+use DXM;
+
+use strict;
+
+#
+# All the PCxx generation routines
+#
+
+# create a talk string (called $self->pc10(...)
+sub pc10
+{
+ my ($self, $to, $via, $text) = @_;
+ my $user2 = $via ? $to : ' ';
+ my $user1 = $via ? $via : $to;
+ my $mycall = $self->call;
+ $text = unpad($text);
+ $text = ' ' if !$text;
+ return "PC10^$mycall^$user1^$text^*^$user2^$main::mycall^~";
+}
+
+# create a dx message (called $self->pc11(...)
+sub pc11
+{
+ my ($self, $freq, $dxcall, $text) = @_;
+ my $mycall = $self->call;
+ my $hops = get_hops(11);
+ my $t = time;
+ $text = ' ' if !$text;
+ return sprintf "PC11^%.1f^$dxcall^%s^%s^$text^$mycall^$hops^~", $freq, cldate($t), ztime($t);
+}
+
+# create an announce message
+sub pc12
+{
+ my ($self, $text, $tonode, $sysop, $wx) = @_;
+ my $hops = get_hops(12);
+ $sysop = $sysop ? '*' : ' ';
+ $text = ' ' if !$text;
+ $wx = '0' if !$wx;
+ $tonode = '*' if !$tonode;
+ return "PC12^$self->{call}^$tonode^$text^$sysop^$main::mycall^$wx^$hops^~";
+}
+
+#
+# add one or more users (I am expecting references that have 'call',
+# 'confmode' & 'here' method)
+#
+# this will create a list of PC16 with up pc16_max_users in each
+# called $self->pc16(..)
+#
+sub pc16
+{
+ my $self = shift;
+ my @out;
+
+ while (@_) {
+ my $str = "PC16^$self->{call}";
+ my $i;
+
+ for ($i = 0; @_ && $i < $DXProt::pc16_max_users; $i++) {
+ my $ref = shift;
+ $str .= sprintf "^%s %s %d", $ref->call, $ref->confmode ? '*' : '-', $ref->here;
+ }
+ $str .= sprintf "^%s^", get_hops(16);
+ push @out, $str;
+ }
+ return (@out);
+}
+
+# remove a local user
+sub pc17
+{
+ my $self = shift;
+ my $hops = get_hops(17);
+ return "PC17^$self->{call}^$main::mycall^$hops^";
+}
+
+# Request init string
+sub pc18
+{
+ return "PC18^wot a load of twaddle^$DXProt::myprot_version^~";
+}
+
+#
+# add one or more nodes
+#
+sub pc19
+{
+ my $self = shift;
+ my @out;
+
+ while (@_) {
+ my $str = "PC19^$self->{call}";
+ my $i;
+
+ for ($i = 0; @_ && $i < $DXProt::pc19_max_nodes; $i++) {
+ my $ref = shift;
+ $str .= "^$ref->{here}^$ref->{call}^$ref->{confmode}^$ref->{pcversion}";
+ }
+ $str .= sprintf "^%s^", get_hops(19);
+ push @out, $str;
+ }
+ return @out;
+}
+
+# end of Rinit phase
+sub pc20
+{
+ return 'PC20^';
+}
+
+# delete a node
+sub pc21
+{
+ my ($ref, $reason) = @_;
+ my $call = $ref->call;
+ my $hops = get_hops(21);
+ $reason = "Gone." if !$reason;
+ return "PC21^$call^$reason^$hops^";
+}
+
+# end of init phase
+sub pc22
+{
+ return 'PC22^';
+}
+
+# send all the DX clusters I reckon are connected
+sub pc38
+{
+ my @list = DXNode->get_all();
+ my $list;
+ my @nodes;
+
+ foreach $list (@list) {
+ push @nodes, $list->call;
+ }
+ return "PC38^" . join(',', @nodes) . "^~";
+}
+
+# periodic update of users, plus keep link alive device (always H99)
+sub pc50
+{
+ my $n = DXNodeuser->count;
+ return "PC50^$main::mycall^$n^H99^";
+}
+
+# generate pings
+sub pc51
+{
+ my ($self, $to, $from, $val) = @_;
+ return "PC51^$to^$from^$val^";
+}
+1;
+__END__
use MLDBM qw(DB_File);
use Fcntl;
+use Carp;
%u = undef;
$dbm = undef;
return if $name =~ /::DESTROY$/;
$name =~ s/.*:://o;
- die "Non-existant field '$AUTOLOAD'" if !$valid{$name};
+ confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
if (@_) {
$self->{$name} = shift;
$self->put();
--- /dev/null
+#
+# various julian date calculations
+#
+# Copyright (c) - 1998 Dirk Koopman G1TLH
+#
+# $Id$
+#
+
+package Julian;
+
+use FileHandle;
+use DXDebug;
+
+use strict;
+
+my @days = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
+
+# take a unix date and transform it into a julian day (ie (1998, 13) = 13th day of 1998)
+sub unixtoj
+{
+ my ($t) = @_;
+ my ($day, $mon, $year) = (gmtime($t))[3..5];
+ my $jday;
+
+ # set the correct no of days for february
+ if ($year < 100) {
+ $year += ($year < 50) ? 2000 : 1900;
+ }
+ $days[1] = isleap($year) ? 29 : 28;
+ for (my $i = 0, $jday = 0; $i < $mon; $i++) {
+ $jday += $days[$i];
+ }
+ $jday += $day;
+ return ($year, $jday);
+}
+
+# take a julian date and subtract a number of days from it, returning the julian date
+sub sub
+{
+ my ($year, $day, $amount) = @_;
+ my $diny = isleap($year) ? 366 : 365;
+ $day -= $amount;
+ while ($day <= 0) {
+ $day += $diny;
+ $year -= 1;
+ $diny = isleap($year) ? 366 : 365;
+ }
+ return ($year, $day);
+}
+
+sub add
+{
+ my ($year, $day, $amount) = @_;
+ my $diny = isleap($year) ? 366 : 365;
+ $day += $amount;
+ while ($day > $diny) {
+ $day -= $diny;
+ $year += 1;
+ $diny = isleap($year) ? 366 : 365;
+ }
+ return ($year, $day);
+}
+
+sub cmp
+{
+ my ($y1, $d1, $y2, $d2) = @_;
+ return $d1 - $d2 if ($y1 == $y2);
+ return $y1 - $y2;
+}
+
+# is it a leap year?
+sub isleap
+{
+ my $year = shift;
+ return ($year % 4 == 0 && ($year % 100 != 0 || $year % 400 == 0)) ? 1 : 0;
+}
+
+# this section deals with files that are julian date based
+
+# open a data file with prefix $fn/$year/$day.dat and return an object to it
+sub open
+{
+ my ($pkg, $fn, $year, $day, $mode) = @_;
+
+ # if we are writing, check that the directory exists
+ if (defined $mode) {
+ my $dir = "$fn/$year";
+ mkdir($dir, 0777) if ! -e $dir;
+ }
+ my $self = {};
+ $self->{fn} = sprintf "$fn/$year/%03d.dat", $day;
+ $mode = 'r' if !$mode;
+ my $fh = new FileHandle $self->{fn}, $mode;
+ return undef if !$fh;
+ $fh->autoflush(1) if $mode ne 'r'; # make it autoflushing if writable
+ $self->{fh} = $fh;
+ $self->{year} = $year;
+ $self->{day} = $day;
+ dbg("julian", "opening $self->{fn}\n");
+
+ return bless $self, $pkg;
+}
+
+# close the data file
+sub close
+{
+ my $self = shift;
+ undef $self->{fh}; # close the filehandle
+ delete $self->{fh};
+}
+
+sub DESTROY # catch undefs and do what is required further do the tree
+{
+ my $self = shift;
+ dbg("julian", "closing $self->{fn}\n");
+ undef $self->{fh} if defined $self->{fh};
+}
+
+1;
--- /dev/null
+#
+# the dx spot handler
+#
+# Copyright (c) - 1998 Dirk Koopman G1TLH
+#
+# $Id$
+#
+
+package Spot;
+
+use FileHandle;
+use DXVars;
+use DXDebug;
+use Julian;
+
+@ISA = qw(Julian);
+
+use strict;
+
+my $fp;
+my $maxspots = 50; # maximum spots to return
+my $defaultspots = 10; # normal number of spots to return
+my $maxdays = 35; # normal maximum no of days to go back
+my $prefix = "$main::data/spots";
+
+# add a spot to the data file (call as Spot::add)
+sub add
+{
+ my @spot = @_; # $freq, $call, $t, $comment, $spotter = @_
+
+ # sure that the numeric things are numeric now (saves time later)
+ $spot[0] = 0 + $spot[0];
+ $spot[2] = 0 + $spot[2];
+
+ # compare dates to see whether need to open another save file (remember, redefining $fp
+ # automagically closes the output file (if any))
+ my @date = Julian::unixtoj($spot[2]);
+ $fp = Spot->open(@date, ">>") if (!$fp || Julian::cmp(@date, $fp->{year}, $fp->{day}));
+
+ # save it
+ my $fh = $fp->{fh};
+ $fh->print(join("\^", @spot), "\n");
+}
+
+# search the spot database for records based on the field no and an expression
+# this returns a set of references to the spots
+#
+# the expression is a legal perl 'if' statement with the possible fields indicated
+# by $f<n> where :-
+#
+# $f0 = frequency
+# $f1 = call
+# $f2 = date in unix format
+# $f3 = comment
+# $f4 = spotter
+#
+# In addition you can specify a range of days, this means that it will start searching
+# from <n> days less than today to <m> days less than today
+#
+# Also you can select a range of entries so normally you would get the 0th (latest) entry
+# back to the 5th latest, you can specify a range from the <x>th to the <y>the oldest.
+#
+# This routine is designed to be called as Spot::search(..)
+#
+
+sub search
+{
+ my ($expr, $dayfrom, $dayto, $from, $to) = @_;
+ my $eval;
+ my @out;
+ my $ref;
+ my $i;
+ my $count;
+ my @today = Julian::unixtoj(time);
+ my @fromdate;
+ my @todate;
+
+ if ($dayfrom > 0) {
+ @fromdate = Julian::sub(@today, $dayfrom);
+ } else {
+ @fromdate = @today;
+ $dayfrom = 0;
+ }
+ if ($dayto > 0) {
+ @todate = Julian::sub(@fromdate, $dayto);
+ } else {
+ @todate = Julian::sub(@fromdate, $maxdays);
+ }
+ if ($from || $to) {
+ $to = $from + $maxspots if $to - $from > $maxspots || $to - $from <= 0;
+ } else {
+ $from = 0;
+ $to = $defaultspots;
+ }
+
+ $expr =~ s/\$f(\d)/zzzref->[$1]/g; # swap the letter n for the correct field name
+ $expr =~ s/[\@\$\%\{\}]//g; # remove any other funny characters
+ $expr =~ s/\&\w+\(//g; # remove subroutine calls
+ $expr =~ s/eval//g; # remove eval words
+ $expr =~ s/zzzref/\$ref/g; # put back the $ref
+ $expr =~ s|(/.+/)|$1oi|g; # add oi characters to /ccc/
+
+ print "expr=($expr), from=$from, to=$to\n";
+
+ # build up eval to execute
+ $eval = qq(my \$c;
+ for (\$c = \$#spots; \$c >= 0; \$c--) {
+ \$ref = \$spots[\$c];
+ if ($expr) {
+ \$count++;
+ next if \$count < \$from; # wait until from
+ push(\@out, \$ref);
+ last LOOP if \$count >= \$to; # stop after to
+ }
+ });
+
+LOOP:
+ for ($i = 0; $i < 60; ++$i) {
+ my @now = Julian::sub(@fromdate, $i);
+ last if Julian::cmp(@now, @todate) <= 0;
+
+ my @spots = ();
+ my $fp = Spot->open(@now); # get the next file
+ if ($fp) {
+ my $fh = $fp->{fh};
+ my $in;
+ foreach $in (<$fh>) {
+ chomp $in;
+ push @spots, [ split('\^', $in) ];
+ }
+ my $ref;
+ eval $eval; # do the search on this file
+ return ("error", $@) if $@;
+ }
+ }
+
+ return @out;
+}
+
+# open a spot file of the Julian day
+sub open
+{
+ my $pkg = shift;
+ return Julian::open("spot", $prefix, @_);
+}
+
+# close a spot file
+sub close
+{
+ # do nothing, unreferencing or overwriting the $self will close it
+}
+
+1;
$SIG{'TERM'} = \&cease;
$SIG{'HUP'} = 'IGNORE';
+# initialise the protocol engine
+DXProt->init();
+
# this, such as it is, is the main loop!
for (;;) {
my $timenow;
#
use Date::Parse;
-use spot;
+use Spot;
sysopen(IN, "../data/DX.DAT", 0) or die "can't open DX.DAT ($!)";
open(OUT, ">../data/dxcomma") or die "can't open dxcomma ($!)";
-spot->init();
+system("rm -rf $Spot::prefix");
+Spot->init();
while (sysread(IN, $buf, 86)) {
($freq,$call,$date,$time,$comment,$spotter) = unpack 'A10A13A12A6A31A14', $buf;
$d = str2time("$date $time");
$comment =~ s/^\s+//o;
if ($d) {
- spot->new($freq, $call, $d, $comment, $spotter);
+ Spot->new($freq, $call, $d, $comment, $spotter);
} else {
print "$call $freq $date $time\n";
}
use FileHandle;
use DXUtil;
use DXDebug;
-use spot;
+use Spot;
# initialise spots file
STDOUT->autoflush(1);
-print "reading in spot data ..";
-$t = time;
-$count = spot->init();
-$t = time - $t;
-print "done ($t secs)\n";
+#print "reading in spot data ..";
+#$t = time;
+#$count = Spot->init();
+#$t = time - $t;
+#print "done ($t secs)\n";
dbgadd('spot');
$expr = $ARGV[1];
$time = time;
-print "$count database records read in\n";
-
#loada();
for (;;) {
- print "field: ";
- $field = <STDIN>;
- last if $field =~ /^q/i;
print "expr: ";
$expr = <STDIN>;
+ last if $expr =~ /^q/i;
- chomp $field;
chomp $expr;
print "doing field $field with /$expr/\n";
my @dx;
my $ref;
my $count;
+ my $i;
- @spots = spot->search($field, $expr);
-
+ my $t = time;
+ @spots = Spot::search($expr);
+ if ($spots[0] eq "error") {
+ print $spots[1];
+ return;
+ }
foreach $ref (@spots) {
@dx = @$ref;
my $t = ztime($dx[2]);
print "$dx[0] $dx[1] $d $t $dx[4] <$dx[3]>\n";
++$count;
}
- print "$count records found\n";
+ $t = time - $t;
+ print "$count records found, $t secs\n";
+}
+
+sub search
+{
+ my ($expr, $from, $to) = @_;
+ my $eval;
+ my @out;
+ my @spots;
+ my $ref;
+ my $i;
+
+
+ $expr =~ s/\$f(\d)/zzzref->[$1]/g; # swap the letter n for the correct field name
+ $expr =~ s/[\@\$\%\{\}]//g; # remove any other funny characters
+ $expr =~ s/\&\w+\(//g; # remove subroutine calls
+ $expr =~ s/eval//g; # remove eval words
+ $expr =~ s/zzzref/\$ref/g; # put back the $ref
+
+ print "expr = $expr\n";
+
+ # build up eval to execute
+ $eval = qq(my \$c;
+ for (\$c = \$#spots; \$c >= 0; \$c--) {
+ \$ref = \$spots[\$c];
+ if ($expr) {
+ push(\@out, \$ref);
+ }
+ });
+
+ my @today = Julian::unixtoj(time);
+ for ($i = 0; $i < 60; ++$i) {
+ my @now = Julian::sub(@today, $i);
+ my @spots;
+ my $fp = Spot->open(@now);
+ if ($fp) {
+ my $fh = $fp->{fh};
+ my $in;
+ foreach $in (<$fh>) {
+ chomp $in;
+ push @spots, [ split('\^', $in) ];
+ }
+ my $ref;
+ eval $eval;
+ return ("error", $@) if $@;
+ }
+ }
+ # execute it
+ return @out;
}
+
sub loada
{
while (<IN>) {
+++ /dev/null
-#
-# various julian date calculations
-#
-# Copyright (c) - 1998 Dirk Koopman G1TLH
-#
-# $Id$
-#
-
-package julian;
-
-use FileHandle;
-use DXDebug;
-
-use strict;
-
-my @days = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
-
-# take a unix date and transform it into a julian day (ie (1998, 13) = 13th day of 1998)
-sub unixtoj
-{
- my ($pkg, $t) = @_;
- my ($day, $mon, $year) = (gmtime($t))[3..5];
- my $jday;
-
- # set the correct no of days for february
- if ($year < 100) {
- $year += ($year < 50) ? 2000 : 1900;
- }
- $days[1] = isleap($year) ? 29 : 28;
- for (my $i = 0, $jday = 0; $i < $mon; $i++) {
- $jday += $days[$i];
- }
- $jday += $day;
- return ($year, $jday);
-}
-
-# take a julian date and subtract a number of days from it, returning the julian date
-sub sub
-{
- my ($pkg, $year, $day, $amount) = @_;
- my $diny = isleap($year) ? 366 : 365;
- $day -= $amount;
- while ($day <= 0) {
- $day += $diny;
- $year -= 1;
- $diny = isleap($year) ? 366 : 365;
- }
- return ($year, $day);
-}
-
-sub add
-{
- my ($pkg, $year, $day, $amount) = @_;
- my $diny = isleap($year) ? 366 : 365;
- $day += $amount;
- while ($day > $diny) {
- $day -= $diny;
- $year += 1;
- $diny = isleap($year) ? 366 : 365;
- }
- return ($year, $day);
-}
-
-sub cmp
-{
- my ($pkg, $y1, $d1, $y2, $d2) = @_;
- return $d1 - $d2 if ($y1 == $y2);
- return $y1 - $y2;
-}
-
-# is it a leap year?
-sub isleap
-{
- my $year = shift;
- return ($year % 4 == 0 && ($year % 100 != 0 || $year % 400 == 0)) ? 1 : 0;
-}
-
-# open a data file with prefix $fn/$year/$day.dat and return an object to it
-sub open
-{
- my ($name, $pkg, $fn, $year, $day, $mode) = @_;
-
- # if we are writing, check that the directory exists
- if (defined $mode) {
- my $dir = "$fn/$year";
- mkdir($dir, 0777) if ! -e $dir;
- }
- my $self = {};
- $self->{fn} = sprintf "$fn/$year/%03d.dat", $day;
- $mode = 'r' if !$mode;
- my $fh = new FileHandle $self->{fn}, $mode;
- return undef if !$fh;
- $fh->autoflush(1) if $mode ne 'r'; # make it autoflushing if writable
- $self->{fh} = $fh;
- $self->{year} = $year;
- $self->{day} = $day;
- dbg("julian", "opening $self->{fn}\n");
-
- return bless $self, $pkg;
-}
-
-# close the data file
-sub close
-{
- my $self = shift;
- undef $self->{fh}; # close the filehandle
- delete $self->{fh};
-}
-
-sub DESTROY # catch undefs and do what is required further do the tree
-{
- my $self = shift;
- dbg("julian", "closing $self->{fn}\n");
- undef $self->{fh} if defined $self->{fh};
-}
-
-1;
+++ /dev/null
-#
-# the dx spot handler
-#
-# Copyright (c) - 1998 Dirk Koopman G1TLH
-#
-# $Id$
-#
-
-package spot;
-
-use FileHandle;
-use DXVars;
-use DXDebug;
-use julian;
-
-@ISA = qw(julian);
-
-use strict;
-
-my $fp;
-my $maxdays = 60; # maximum no of days to store spots in the table
-my $prefix = "$main::data/spots";
-my @table = (); # the list of spots (held in reverse order)
-
-# read in n days worth of dx spots into memory
-sub init
-{
- my @today = julian->unixtoj(time); # get the julian date now
- my @first = julian->sub(@today, $maxdays); # get the date $maxdays ago
- my $count;
-
- mkdir($prefix, 0777) if ! -e $prefix; # create the base directory if required
- for (my $i = 0; $i < $maxdays; ++$i) {
- my $ref = spot->open(@first);
- if ($ref) {
- my $fh = $ref->{fh};
- my @out = ();
- while (<$fh>) {
- chomp;
- my @ent = split /\^/;
-
- push @spot::table, \@ent; # stick this ref to anon list on the FRONT of the table
-
- ++$count;
- }
- }
- @first = julian->add(@first, 1);
- }
- return $count;
-}
-
-# create a new spot on the front of the list, add it to the data file
-sub new
-{
- my $pkg = shift;
- my @spot = @_; # $freq, $call, $t, $comment, $spotter = @_
-
- # sure that the numeric things are numeric now (saves time later)
- $spot[0] = 0 + $spot[0];
- $spot[2] = 0 + $spot[2];
-
- # save it on the front of the list
- unshift @spot::table, \@spot;
-
- # compare dates to see whether need to open a other save file
- my @date = julian->unixtoj($spot[2]);
- $fp = spot->open(@date, ">>") if (!$fp || julian->cmp(@date, $fp->{year}, $fp->{day}));
- my $fh = $fp->{fh};
- $fh->print(join("\^", @spot), "\n");
-}
-
-# purge all the spots older than $maxdays - this is fairly approximate
-# this should be done periodically from some cron task
-sub purge
-{
- my $old = time - ($maxdays * 86400);
- my $ref;
-
- while (@spot::table) {
- my $ref = pop @spot::table;
- if (${$ref}[2] > $old) {
- push @spot::table, $ref; # put it back
- last; # and leave
- }
- }
-}
-
-# search the spot database for records based on the field no and an expression
-# this returns a set of references to the spots
-#
-# for string fields supply a pattern to match
-# for numeric fields supply a range of the format 'n > x && n < y' (the n will
-# changed to the correct field name) [ n is literally the letter 'n' ]
-#
-sub search
-{
- my ($pkg, $field, $expr, $from, $to) = @_;
- my $eval;
- my @out;
- my $ref;
- my $i;
-
- dbg('spot', "input expr = $expr\n");
- if ($field == 0 || $field == 2) { # numeric fields
- $expr =~ s/n/\$ref->[$field]/g; # swap the letter n for the correct field name
- } else {
- $expr = qq(\$ref->[$field] =~ /$expr/oi); # alpha expressions
- }
- dbg('spot', "expr now = $expr\n");
-
- # build up eval to execute
- $eval = qq(foreach \$ref (\@spot::table) {
- next if \$i < \$from;
- if ($expr) {
- unshift(\@out, \$ref);
- \$i++;
- last if \$to && \$i >= \$to;
- }
- });
- dbg('spot', "eval = $eval\n");
- eval $eval; # execute it
- return @out;
-}
-
-# open a spot file of the julian day
-sub open
-{
- my $pkg = shift;
- return julian->open("spot", $prefix, @_);
-}
-
-# close a spot file
-sub close
-{
- # do nothing, unreferencing or overwriting the $self will close it
-}
-
-1;
projects / spider.git / commitdiff