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