From 4a4022d665224a6ac7b7a539a4c1042aecbc07de Mon Sep 17 00:00:00 2001 From: minima Date: Tue, 10 Jan 2006 22:22:21 +0000 Subject: [PATCH] get some basic XML routines up and running. --- perl/DXProt.pm | 104 ++++++++++++++++++++++++------------------ perl/DXXml.pm | 88 ++++++++++++++++++++++++++++++++++-- perl/DXXml/Dx.pm | 32 +++++++++++++ perl/DXXml/Ping.pm | 32 +++++++++++++ perl/IsoTime.pm | 89 ++++++++++++++++++++++++++++++++++++ perl/Route/Node.pm | 110 +++++++++------------------------------------ perl/cluster.pl | 5 ++- 7 files changed, 324 insertions(+), 136 deletions(-) create mode 100644 perl/DXXml/Dx.pm create mode 100644 perl/DXXml/Ping.pm create mode 100644 perl/IsoTime.pm diff --git a/perl/DXProt.pm b/perl/DXProt.pm index 352a4f6a..d51b9f1a 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -301,7 +301,7 @@ sub start $self->{pingave} = 999; $self->{metric} ||= 100; $self->{lastping} = $main::systime; - + # send initialisation string unless ($self->{outbound}) { $self->sendinit; @@ -335,6 +335,11 @@ sub normal { my ($self, $line) = @_; + if ($line =~ '^<\w+\s') { + DXXml::normal($self, $line); + return; + } + my @field = split /\^/, $line; return unless @field; @@ -1545,48 +1550,7 @@ sub handle_51 if ($flag == 1) { $self->send(pc51($from, $to, '0')); } else { - # it's a reply, look in the ping list for this one - my $ref = $pings{$from}; - if ($ref) { - my $tochan = DXChannel::get($from); - while (@$ref) { - my $r = shift @$ref; - my $dxchan = DXChannel::get($r->{call}); - next unless $dxchan; - my $t = tv_interval($r->{t}, [ gettimeofday ]); - if ($dxchan->is_user) { - my $s = sprintf "%.2f", $t; - my $ave = sprintf "%.2f", $tochan ? ($tochan->{pingave} || $t) : $t; - $dxchan->send($dxchan->msg('pingi', $from, $s, $ave)) - } elsif ($dxchan->is_node) { - if ($tochan) { - my $nopings = $tochan->user->nopings || $obscount; - push @{$tochan->{pingtime}}, $t; - shift @{$tochan->{pingtime}} if @{$tochan->{pingtime}} > 6; - - # cope with a missed ping, this means you must set the pingint large enough - if ($t > $tochan->{pingint} && $t < 2 * $tochan->{pingint} ) { - $t -= $tochan->{pingint}; - } - - # calc smoothed RTT a la TCP - if (@{$tochan->{pingtime}} == 1) { - $tochan->{pingave} = $t; - } else { - $tochan->{pingave} = $tochan->{pingave} + (($t - $tochan->{pingave}) / 6); - } - $tochan->{nopings} = $nopings; # pump up the timer - if (my $ivp = Investigate::get($from, $self->{call})) { - $ivp->handle_ping; - } - } elsif (my $rref = Route::Node::get($r->{call})) { - if (my $ivp = Investigate::get($from, $self->{call})) { - $ivp->handle_ping; - } - } - } - } - } + $self->handle_ping_reply($from); } } else { @@ -1601,6 +1565,56 @@ sub handle_51 } } +sub handle_ping_reply +{ + my $self = shift; + my $from = shift; + my $id = shift; + + # it's a reply, look in the ping list for this one + my $ref = $pings{$from}; + return unless $ref; + + my $tochan = DXChannel::get($from); + while (@$ref) { + my $r = shift @$ref; + my $dxchan = DXChannel::get($r->{call}); + next unless $dxchan; + my $t = tv_interval($r->{t}, [ gettimeofday ]); + if ($dxchan->is_user) { + my $s = sprintf "%.2f", $t; + my $ave = sprintf "%.2f", $tochan ? ($tochan->{pingave} || $t) : $t; + $dxchan->send($dxchan->msg('pingi', $from, $s, $ave)) + } elsif ($dxchan->is_node) { + if ($tochan) { + my $nopings = $tochan->user->nopings || $obscount; + push @{$tochan->{pingtime}}, $t; + shift @{$tochan->{pingtime}} if @{$tochan->{pingtime}} > 6; + + # cope with a missed ping, this means you must set the pingint large enough + if ($t > $tochan->{pingint} && $t < 2 * $tochan->{pingint} ) { + $t -= $tochan->{pingint}; + } + + # calc smoothed RTT a la TCP + if (@{$tochan->{pingtime}} == 1) { + $tochan->{pingave} = $t; + } else { + $tochan->{pingave} = $tochan->{pingave} + (($t - $tochan->{pingave}) / 6); + } + $tochan->{nopings} = $nopings; # pump up the timer + if (my $ivp = Investigate::get($from, $self->{call})) { + $ivp->handle_ping; + } + } elsif (my $rref = Route::Node::get($r->{call})) { + if (my $ivp = Investigate::get($from, $self->{call})) { + $ivp->handle_ping; + } + } + } + } +} + # dunno but route it sub handle_75 { @@ -1711,7 +1725,8 @@ sub process } foreach $dxchan (@dxchan) { - next unless $dxchan->is_node(); + next unless $dxchan->is_node; + next if $dxchan->handle_xml; next if $dxchan == $main::me; # send the pc50 @@ -1725,6 +1740,7 @@ sub process addping($main::mycall, $dxchan->call); $dxchan->{nopings} -= 1; $dxchan->{lastping} = $t; + $dxchan->{lastping} += $dxchan->{pingint} / 2 unless @{$dxchan->{pingtime}}; } } } diff --git a/perl/DXXml.pm b/perl/DXXml.pm index c6c8ee69..968b6148 100644 --- a/perl/DXXml.pm +++ b/perl/DXXml.pm @@ -9,18 +9,34 @@ use strict; package DXXml; +use IsoTime; -use DXChannel; use DXProt; +use DXDebug; +use DXLog; +use DXXml::Ping; +use DXXml::Dx; -use vars qw($VERSION $BRANCH $xs); +use vars qw($VERSION $BRANCH $xs $id); $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0)); $main::build += $VERSION; $main::branch += $BRANCH; -$xs = undef; # the XML::Simple parser instance +$xs = undef; # the XML::Simple parser instance +$id = 0; # the next ID to be used +# generate a new XML sentence structure +sub new +{ + my $pkg = shift; + my $class = ref $pkg || $pkg; + return bless{@_}, $class; +} + +# +# note that this a function not a method +# sub init { return unless $main::do_xml; @@ -34,13 +50,79 @@ sub init undef $@; } +# +# note that this a function not a method +# sub normal { + my $dxchan = shift; + my $line = shift; + + unless ($main::do_xml) { + dbg("xml not enabled, IGNORED") if isdbg('chanerr'); + return; + } + + my ($rootname) = $line =~ '<(\w+) '; + my $pkg = "DXXml::" . ucfirst lc "$rootname"; + + unless (defined *{"${pkg}::"} && $pkg->can('handle_input')) { + dbg("xml sentence $rootname not recognised, IGNORED") if isdbg('chanerr'); + return; + } + + my $xref; + unless ($xref = $pkg->decode_xml($dxchan, $line)) { + dbg("invalid XML ($@), IGNORED") if isdbg('chanerr'); + undef $@; + return; + } + + # mark the handle as accepting xml (but only if they + # have at least one right) + $dxchan->handle_xml(1); + $xref = bless $xref, $pkg; + $xref->{'-xml'} = $line; + $xref->handle_input($dxchan); } +# +# note that this a function not a method +# sub process { } + +sub decode_xml +{ + my $pkg = shift; + my $dxchan = shift; + my $line = shift; + + my $xref; + eval {$xref = $xs->XMLin($line)}; + return $xref; +} + +sub nextid +{ + my $r = $id++; + $id = 0 if $id > 999; + return $r; +} + +sub toxml +{ + my $self = shift; + + $self->{o} ||= $main::mycall; + $self->{t} ||= IsoTime::dayms(); + $self->{id} ||= nextid(); + + my ($name) = ref $self =~ /::(\w+)$/; + my $s = $xs->XMLout($self, RootName =>$name, NumericEscape=>1); + return $self->{'-xml'} = $s; +} 1; diff --git a/perl/DXXml/Dx.pm b/perl/DXXml/Dx.pm new file mode 100644 index 00000000..d8bba23b --- /dev/null +++ b/perl/DXXml/Dx.pm @@ -0,0 +1,32 @@ +# +# XML DX Spot handler +# +# $Id$ +# +# Copyright (c) Dirk Koopman, G1TLH +# + +use strict; + +package DXXml::Dx; + +use DXDebug; +use DXProt; +use IsoTime; + +use vars qw($VERSION $BRANCH @ISA); +$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); +$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0)); +$main::build += $VERSION; +$main::branch += $BRANCH; + +@ISA = qw(DXXml); + +sub handle_input +{ + my $self = shift; + my $dxchan = shift; + +} + +1; diff --git a/perl/DXXml/Ping.pm b/perl/DXXml/Ping.pm new file mode 100644 index 00000000..26dd864e --- /dev/null +++ b/perl/DXXml/Ping.pm @@ -0,0 +1,32 @@ +# +# XML Ping handler +# +# $Id$ +# +# Copyright (c) Dirk Koopman, G1TLH +# + +use strict; + +package DXXml::Ping; + +use DXDebug; +use DXProt; +use IsoTime; + +use vars qw($VERSION $BRANCH @ISA); +$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); +$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0)); +$main::build += $VERSION; +$main::branch += $BRANCH; + +@ISA = qw(DXXml); + +sub handle_input +{ + my $self = shift; + my $dxchan = shift; + +} + +1; diff --git a/perl/IsoTime.pm b/perl/IsoTime.pm new file mode 100644 index 00000000..422f9912 --- /dev/null +++ b/perl/IsoTime.pm @@ -0,0 +1,89 @@ +# +# Utility routines for handling Iso 8601 date time groups +# +# $Id$ +# +# Copyright (c) Dirk Koopman, G1TLH +# + +use strict; + +package IsoTime; + +use Date::Parse; + +use vars qw($VERSION $BRANCH $year $month $day $hour $min $sec @days @ldays); +$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); +$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0)); +$main::build += $VERSION; +$main::branch += $BRANCH; + +@days = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); +@ldays = (31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); + +# is it a leap year? +sub _isleap +{ + my $year = shift; + return ($year % 4 == 0 && ($year % 100 != 0 || $year % 400 == 0)) ? 1 : 0; +} + +sub full +{ + return sprintf "%04d%02d%02dT%02d%02d%02d", $year, $month, $day, $hour, $min, $sec; +} + +sub dayminsec +{ + return sprintf "%02dT%02d%02d%02d", $day, $hour, $min, $sec; +} + +sub daymin +{ + return sprintf "%02dT%02d%02d", $day, $hour, $min; +} + +sub update +{ + my $t = shift || time; + ($sec,$min,$hour,$day,$month,$year) = gmtime($t); + $month++; + $year += 1900; +} + +sub unixtime +{ + my $iso = shift; + + # get the correct month and year if it is a short date + if (my ($d) = $iso =~ /^(\d\d)T\d\d\d\d/) { + if ($d == $day) { + $iso = sprintf("%04d%02d", $year, $month) . $iso; + } else { + my $days = _isleap($year) ? $ldays[$month-1] : $days[$month-1]; + my ($y, $m) = ($year, $month); + if ($d < $day) { + if ($day - $d > $days / 2) { + if ($month == 1) { + $y = $year - 1; + $m = 12; + } else { + $m = $month - 1; + } + } + } else { + if ($d - $day > $days / 2) { + if ($month == 12) { + $y = $year + 1; + $m = 1; + } else { + $m = $month + 1; + } + } + } + $iso = sprintf("%04d%02d", $y, $m) . $iso; + } + } + return str2time($iso); +} +1; diff --git a/perl/Route/Node.pm b/perl/Route/Node.pm index e7b18772..d3b1e955 100644 --- a/perl/Route/Node.pm +++ b/perl/Route/Node.pm @@ -15,8 +15,10 @@ use Route::User; use strict; use vars qw($VERSION $BRANCH); - -main::mkver($VERSION = q$Revision$); +$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); +$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0)); +$main::build += $VERSION; +$main::branch += $BRANCH; use vars qw(%list %valid @ISA $max $filterdef); @ISA = qw(Route); @@ -27,9 +29,9 @@ use vars qw(%list %valid @ISA $max $filterdef); users => '0,Users,parray', usercount => '0,User Count', version => '0,Version', - build => '0,Build', - sw => '0,Software', - np => '0,Using New Prot,yesno', + handle_xml => '0,Using XML,yesno', + lastmsg => '0,Last Route Msg,atime', + lastid => '0,Last Route MsgID', ); $filterdef = $Route::filterdef; @@ -58,7 +60,7 @@ sub max # object with that callsign. The upper layers are expected to do something # sensible with this! # -# called as $parent->add(call, version, flags) +# called as $parent->add(call, dxchan, version, flags) # sub add @@ -66,21 +68,13 @@ sub add my $parent = shift; my $call = uc shift; confess "Route::add trying to add $call to myself" if $call eq $parent->{call}; - my $version = shift; - my $here = shift; - my $self = get($call); if ($self) { $self->_addparent($parent); $parent->_addnode($self); - if ($self->{version} != $version || $self->{flags} != $here) { - $self->{version} = $version; - $self->{flags} = $here; - return $self; - } return undef; } - $self = $parent->new($call, $version, $here); + $self = $parent->new($call, @_); $parent->_addnode($self); return $self; } @@ -149,10 +143,10 @@ sub add_user my $uref = Route::User::get($ucall); my @out; if ($uref) { - push @out, $uref->addparent($self); + @out = $uref->addparent($self); } else { $uref = Route::User->new($ucall, $self->{call}, @_); - push @out, $uref; + @out = $uref; } $self->_adduser($uref); $self->{usercount} = scalar @{$self->{users}}; @@ -204,25 +198,6 @@ sub parents return @{$self->{parent}}; } -sub has_user -{ - my $self = shift; - return $self->_haslist('users', shift); -} - -sub has_node -{ - my $self = shift; - return $self->_haslist('nodes', shift); -} - -sub has_parent -{ - my $self = shift; - return $self->_haslist('parent', shift); -} - - sub rnodes { my $self = shift; @@ -236,39 +211,6 @@ sub rnodes return @out; } -# return the differences in nodes between what we currently have and -# the list proffered. Returns two refs one to a list of nodes to remove and -# the other a list of nodes to add -# -# input is a list of callsigns (not refs) -sub diff_nodes -{ - my $self = shift; - my $in = ref $_[0] ? shift : \@_; - my %del = map {($_, 1)} nodes($self); - my %in = map {($_, 1)} @$in; - - # remove all the calls that are in both lists - for (@$in) { - delete $in{$_} if delete $del{$_}; - } - return ([keys %del], [keys %in]); -} - -# same as above but for users -sub diff_users -{ - my $self = shift; - my $in = ref $_[0] ? shift : \@_; - my %del = map {($_, 1)} users($self); - my %in = map {($_, 1)} @$in; - - # remove all the calls that are in both lists - for (@$in) { - delete $in{$_} if delete $del{$_}; - } - return ([keys %del], [keys %in]); -} sub new { @@ -279,11 +221,10 @@ sub new my $self = $pkg->SUPER::new($call); $self->{parent} = ref $pkg ? [ $pkg->{call} ] : [ ]; - $self->{version} = 0 || shift; - $self->{flags} = 0 || shift; + $self->{version} = shift; + $self->{flags} = shift; $self->{users} = []; $self->{nodes} = []; - $self->{lid} = 0; $list{$call} = $self; @@ -304,22 +245,6 @@ sub get_all return values %list; } -sub newid -{ - my $self = shift; - my $id = shift; - - return 0 if $id == $self->{lid}; - if ($id > $self->{lid}) { - $self->{lid} = $id; - return 1; - } elsif ($self->{lid} - $id > 500) { - $self->{id} = $id; - return 1; - } - return 0; -} - sub _addparent { my $self = shift; @@ -358,6 +283,15 @@ sub _deluser return $self->_dellist('users', @_); } +sub DESTROY +{ + my $self = shift; + my $pkg = ref $self; + my $call = $self->{call} || "Unknown"; + + dbg("destroying $pkg with $call") if isdbg('routelow'); +} + # # generic AUTOLOAD for accessors # diff --git a/perl/cluster.pl b/perl/cluster.pl index e28011ab..0ad54f31 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -101,6 +101,7 @@ use QSL; use RouteDB; use DXXml; use DXSql; +use IsoTime; use Data::Dumper; use IO::File; @@ -134,7 +135,7 @@ $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0)); $main::build += $VERSION; $main::branch += $BRANCH; -$main::build += 3; # fudge (put back for now) +#$main::build += 2; # fudge (put back for now) @@ -511,8 +512,10 @@ for (;;) { if ($timenow != $systime) { reap if $zombies; $systime = $timenow; + IsoTime::update($systime); DXCron::process(); # do cron jobs DXCommandmode::process(); # process ongoing command mode stuff + DXXml::process(); DXProt::process(); # process ongoing ak1a pcxx stuff DXConnect::process(); DXMsg::process(); -- 2.43.0