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