perl/DXXml.pm

   1 #
   2 # XML handler
   3 #
   4 # $Id$
   5 #
   6 # Copyright (c) Dirk Koopman, G1TLH
   7 #
   8
   9 use strict;
  10
  11 package DXXml;
  12 use IsoTime;
  13
  14 use DXProt;
  15 use DXDebug;
  16 use DXLog;
  17 use DXUtil;
  18 use DXXml::Ping;
  19 use DXXml::Dx;
  20 use DXXml::IM;
  21
  22 use vars qw($VERSION $BRANCH $xs $id $max_old_age $max_future_age $dupeage);
  23 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
  24 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
  25 $main::build += $VERSION;
  26 $main::branch += $BRANCH;
  27
  28 $xs = undef;                                    # the XML::Simple parser instance
  29 $id = 0;                                                # the next ID to be used
  30 $max_old_age = 3600;                    # how old a sentence we will accept
  31 $max_future_age = 900;                  # how far into the future we will accept
  32 $dupeage = 12*60*60;                    # duplicates stored half a day
  33
  34
  35 # generate a new XML sentence structure
  36 sub new
  37 {
  38         my $pkg = shift;
  39         my $class = ref $pkg || $pkg;
  40         return bless{@_}, $class;
  41 }
  42
  43 #
  44 # note that this a function not a method
  45 #
  46 sub init
  47 {
  48         return unless $main::do_xml;
  49
  50         eval { require XML::Simple };
  51         eval { require XML::Parser } unless $@;
  52         if ($@) {
  53                 LogDbg('err', "do_xml was set to 1 and the XML routines failed to load ($@)");
  54                 $main::do_xml = 0;
  55         } else {
  56                 $XML::Simple::PREFERRED_PARSER = 'XML::Parser';
  57                 import XML::Simple;
  58                 $DXProt::handle_xml = 1;
  59                 $xs = new XML::Simple(Cache=>[]);
  60         }
  61         undef $@;
  62 }
  63
  64 #
  65 # note that this a function not a method
  66 #
  67 sub normal
  68 {
  69         my $dxchan = shift;
  70         my $line = shift;
  71
  72         unless ($main::do_xml) {
  73                 dbg("xml not enabled, IGNORED") if isdbg('chanerr');
  74                 return;
  75         }
  76
  77         my ($rootname) = $line =~ '<(\w+) ';
  78         my $pkg = "DXXml::" . ucfirst lc "$rootname";
  79
  80         unless (defined *{"${pkg}::"} && $pkg->can('handle_input')) {
  81                 dbg("xml sentence $rootname not recognised, IGNORED") if isdbg('chanerr');
  82                 return;
  83         }
  84
  85         my $xref;
  86         unless ($xref = $pkg->decode_xml($dxchan, $line))  {
  87                 dbg("invalid XML ($@), IGNORED") if isdbg('chanerr');
  88                 undef $@;
  89                 return;
  90         }
  91
  92         # do some basic checks
  93         my ($o, $t, $id);
  94         unless (exists $xref->{o} && is_callsign($o = $xref->{o})) {
  95                 dbg("Invalid origin, not a callsign") if isdbg('chanerr');
  96                 return;
  97         }
  98         unless (exists $xref->{t} && ($t = IsoTime::unixtime($xref->{t}))) {
  99                 dbg("Invalid, non-existant or zero time") if isdbg('chanerr');
 100                 return;
 101         }
 102         unless ($t < $main::systime - $max_old_age || $t > $main::systime + $max_future_age) {
 103                 dbg("Too old or too far in the future") if isdbg('chanerr');
 104                 return;
 105         }
 106         unless (exists $xref->{id} && ($id = $xref->{id}) >= 0 && $id <= 9999) {
 107                 dbg("Invalid or non-existant id") if isdbg('chanerr');
 108                 return;
 109         }
 110
 111         # mark the handle as accepting xml (but only if they
 112         # have at least one right)
 113         $dxchan->handle_xml(1);
 114
 115         # now check that we have not seen this before
 116         # this is based on the tuple (o (origin), t (time, normalised to time_t), id)
 117         $xref->{'-timet'} = $t;
 118         return if DXDupe::check("xml,$o,$t,$id", $dupeage);
 119
 120         $xref = bless $xref, $pkg;
 121         $xref->{'-xml'} = $line;
 122         $xref->handle_input($dxchan);
 123 }
 124
 125 #
 126 # note that this a function not a method
 127 #
 128
 129 my $last10;
 130 my $last_hour;
 131
 132 sub process
 133 {
 134         my $t = time;
 135         my @dxchan = DXChannel::get_all();
 136         my $dxchan;
 137
 138         foreach $dxchan (@dxchan) {
 139                 next unless $dxchan->is_node;
 140                 next unless $dxchan->handle_xml;
 141                 next if $dxchan == $main::me;
 142
 143                 # send a ping out on this channel
 144                 if ($dxchan->{pingint} && $t >= $dxchan->{pingint} + $dxchan->{lastping}) {
 145                         if ($dxchan->{nopings} <= 0) {
 146                                 $dxchan->disconnect;
 147                         } else {
 148                                 DXXml::Ping::add($main::me, $dxchan->call);
 149                                 $dxchan->{nopings} -= 1;
 150                                 $dxchan->{lastping} = $t;
 151                                 $dxchan->{lastping} += $dxchan->{pingint} / 2 unless @{$dxchan->{pingtime}};
 152                         }
 153                 }
 154         }
 155
 156
 157         # every ten seconds
 158         if (!$last10 || $t - $last10 >= 10) {
 159                 $last10 = $t;
 160         }
 161
 162         # every hour
 163         if (!$last_hour || $main::systime - 3600 > $last_hour) {
 164                 $last_hour = $main::systime;
 165         }
 166
 167 }
 168
 169 sub decode_xml
 170 {
 171         my $pkg = shift;
 172         my $dxchan = shift;
 173         my $line = shift;
 174
 175         my $xref;
 176         eval {$xref = $xs->XMLin($line)};
 177         return $xref;
 178 }
 179
 180 sub nextid
 181 {
 182         my $r = $id++;
 183         $id = 0 if $id > 999;
 184         return $r;
 185 }
 186
 187 sub toxml
 188 {
 189         my $self = shift;
 190
 191         unless (exists $self->{'-xml'}) {
 192                 $self->{o} ||= $main::mycall;
 193                 $self->{t} ||= IsoTime::dayminsec();
 194                 $self->{id} ||= nextid();
 195
 196                 my ($name) = (ref $self) =~ /::(\w+)$/;
 197                 $self->{'-xml'} = $xs->XMLout($self, RootName =>lc $name, NumericEscape=>1);
 198         }
 199         return $self->{'-xml'};
 200 }
 201
 202 sub route
 203 {
 204         my $self = shift;
 205         my $fromdxchan = shift;
 206         my $to = shift;
 207         my $via = $to || $self->{'-via'} || $self->{to};
 208
 209         unless ($via) {
 210                 dbg("XML: no route specified (" . $self->toxml . ")") if isdbg('chanerr');
 211                 return;
 212         }
 213         if (ref $fromdxchan && $via && $fromdxchan->call eq $via) {
 214                 dbg("XML: Trying to route back to source (" . $self->toxml . ")") if isdbg('chanerr');
 215                 return;
 216         }
 217
 218         # always send it down the local interface if available
 219         my $dxchan = DXChannel::get($via);
 220         if ($dxchan) {
 221                 dbg("route: $via -> $dxchan->{call} direct" ) if isdbg('route');
 222         } else {
 223                 my $cl = Route::get($via);
 224                 $dxchan = $cl->dxchan if $cl;
 225                 dbg("route: $via -> $dxchan->{call} using normal route" ) if isdbg('route');
 226         }
 227
 228         # try the backstop method
 229         unless ($dxchan) {
 230                 my $rcall = RouteDB::get($via);
 231                 if ($rcall) {
 232                         $dxchan = DXChannel::get($rcall);
 233                         dbg("route: $via -> $rcall using RouteDB" ) if isdbg('route') && $dxchan;
 234                 }
 235         }
 236
 237         unless ($dxchan) {
 238                 dbg("XML: no route available to $via") if isdbg('chanerr');
 239                 return;
 240         }
 241
 242         if ($fromdxchan->call eq $via) {
 243                 dbg("XML: Trying to route back to source (" . $self->toxml . ")") if isdbg('chanerr');
 244                 return;
 245         }
 246
 247         if ($dxchan == $main::me) {
 248                 dbg("XML: Trying to route to me (" . $self->toxml . ")") if isdbg('chanerr');
 249                 return;
 250         }
 251
 252         if ($dxchan->handle_xml) {
 253                 $dxchan->send($self->toxml);
 254         } else {
 255                 $self->{o} ||= $main::mycall;
 256                 $self->{id} ||= nextid();
 257                 $self->{'-timet'} ||= $main::systime;
 258                 $dxchan->send($self->topcxx);
 259         }
 260 }
 261
 262 sub has_xml
 263 {
 264         return exists $_[0]->{'-xml'};
 265 }
 266
 267 sub has_pcxx
 268 {
 269         return exists $_[0]->{'-pcxx'};
 270 }
 271
 272 sub has_cmd
 273 {
 274         return exists $_[0]->{'-cmd'};
 275 }
 276
 277 1;