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