]> gb7djk.dxcluster.net Git - spider.git/blob - perl/DXXml.pm
Rework DXCron::spawn for Mojo
[spider.git] / perl / DXXml.pm
1 #
2 # XML handler
3 #
4 #
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($xs $id $max_old_age $max_future_age $dupeage);
25 $xs = undef;                                    # the XML::Simple parser instance
26 $id = 0;                                                # the next ID to be used
27 $max_old_age = 3600;                    # how old a sentence we will accept
28 $max_future_age = 900;                  # how far into the future we will accept
29 $dupeage = 12*60*60;                    # duplicates stored half a day 
30
31
32 # generate a new XML sentence structure 
33 sub new
34 {
35         my $pkg = shift;
36         my $class = ref $pkg || $pkg;
37         my $self = bless{}, $class;
38         while (@_) {
39                 my $key = shift;
40                 my $val = shift;
41                 $self->{$key} = $val if defined $val;
42         }
43         return $self; 
44 }
45
46 #
47 # note that this a function not a method
48 #
49 sub init
50 {
51         return unless $main::do_xml;
52         
53         eval { require XML::Simple };
54         eval { require XML::Parser } unless $@;
55         if ($@) {
56                 LogDbg('err', "do_xml was set to 1 and the XML routines failed to load ($@)");
57                 $main::do_xml = $xs = 0;
58         } else {
59                 $XML::Simple::PREFERRED_PARSER = 'XML::Parser';
60                 import XML::Simple;
61                 $xs = new XML::Simple(ContentKey=>'content', ForceArray=>1);
62         }
63         undef $@;
64 }
65
66 # is XML avaiable and active
67 sub available
68 {
69         return $main::do_xml && $xs;
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 (available()) {
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                         }
160                 }
161         }
162
163
164         # every ten seconds
165         if (!$last10 || $t - $last10 >= 10) {   
166                 $last10 = $t;
167         }
168
169         # every hour
170         if (!$last_hour || $main::systime - 3600 > $last_hour) {
171                 $last_hour = $main::systime;
172         }
173
174 }
175
176 sub decode_xml
177 {
178         my $pkg = shift;
179         my $dxchan = shift;
180         my $line = shift;
181
182         my $xref;
183         eval {$xref = $xs->XMLin($line)};
184         return $xref;
185 }
186
187 sub nextid
188 {
189         my $r = $id++;
190         $id = 0 if $id > 999;
191         return $r;
192 }
193
194 sub toxml
195 {
196         my $self = shift;
197
198         unless (exists $self->{'-xml'}) {
199                 $self->{o} ||= $main::mycall;
200                 $self->{t} ||= IsoTime::hourminsec();
201                 $self->{id} ||= nextid();
202                 
203                 my ($name) = (ref $self) =~ /::(\w+)$/;
204                 $self->{'-xml'} = $xs->XMLout($self, RootName =>lc $name, NumericEscape=>1);
205         }
206         return $self->{'-xml'};
207 }
208
209 sub route
210 {
211         my $self = shift;
212         my $fromdxchan = shift;
213         my $to = shift;
214         my $via = $to;
215         my $dxchan;
216         
217         if (my $u = $self->{u} && $self->{to} eq $main::mycall) {
218                 $via ||= $u if ($dxchan = DXChannel::get($u));
219         }
220         $via ||= $self->{'-via'} || $self->{to};
221
222         unless ($via) {
223                 dbg("XML: no route specified (" . dd($self) . ")") if isdbg('chanerr');
224                 return;
225         }
226         if (ref $fromdxchan && $via && $fromdxchan->call eq $via) {
227                 dbg("XML: Trying to route back to source (" . dd($self) . ")") if isdbg('chanerr');
228                 return;
229         }
230
231         # always send it down the local interface if available
232         $dxchan ||= DXChannel::get($via);
233         if ($dxchan) {
234                 dbg("route: $via -> $dxchan->{call} direct" ) if isdbg('route');
235         } else {
236                 my $cl = Route::get($via);
237                 $dxchan = $cl->dxchan if $cl;
238                 dbg("route: $via -> $dxchan->{call} using normal route" ) if isdbg('route');
239         }
240
241         unless ($dxchan) {
242                 dbg("XML: no route available to $via") if isdbg('chanerr');
243                 return;
244         }
245
246         if ($fromdxchan->call eq $via) {
247                 dbg("XML: Trying to route back to source (" . dd($self) . ")") if isdbg('chanerr');
248                 return;
249         }
250
251         if ($dxchan == $main::me) {
252                 dbg("XML: Trying to route to me (" . dd($self) . ")") if isdbg('chanerr');
253                 return;
254         }
255
256         $self->{o} ||= $main::mycall;
257         $self->{id} ||= nextid();
258         $self->{'-timet'} ||= $main::systime;
259
260         if ($dxchan->handle_xml) {
261                 $dxchan->send($self->toxml);
262         } elsif ($dxchan->is_node) {
263                 my $ref = $self->topcxx($dxchan);
264                 $dxchan->send($ref);
265         } else {
266                 my $ref = $self->tocmd($dxchan);
267                 $dxchan->send($ref);
268         }
269 }
270
271 sub has_xml
272 {
273         return exists $_[0]->{'-xml'};
274 }
275
276 sub has_pcxx
277 {
278         return exists $_[0]->{'-pcxx'};
279 }
280
281 sub has_cmd
282 {
283         return exists $_[0]->{'-cmd'};
284 }
285
286 1;