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