]> scm.dxcluster.org Git - spider.git/blob - perl/ExtMsg.pm
7b33b6e2780d43e19d663d63f0fe4bdf59a0b14f
[spider.git] / perl / ExtMsg.pm
1 #
2 # This class is the internal subclass that deals with the external port
3 # communications for Msg.pm
4 #
5 # This is where the cluster handles direct connections coming both in
6 # and out
7 #
8 # $Id$
9 #
10 # Copyright (c) 2001 - Dirk Koopman G1TLH
11 #
12
13 package ExtMsg;
14
15 use strict;
16 use Msg;
17 use DXVars;
18 use DXUtil;
19 use DXDebug;
20 use IO::File;
21 use IO::Socket;
22 use IPC::Open3;
23
24 use vars qw(@ISA $deftimeout);
25
26 @ISA = qw(Msg);
27 $deftimeout = 60;
28
29 sub enqueue
30 {
31         my ($conn, $msg) = @_;
32         unless ($msg =~ /^[ABZ]/) {
33                 if ($msg =~ /^E[-\w]+\|([01])/ && $conn->{csort} eq 'telnet') {
34                         $conn->{echo} = $1;
35                         if ($1) {
36 #                               $conn->send_raw("\xFF\xFC\x01");
37                         } else {
38 #                               $conn->send_raw("\xFF\xFB\x01");
39                         }
40                 } else {
41                         $msg =~ s/^[-\w]+\|//;
42                         push (@{$conn->{outqueue}}, $msg . $conn->{lineend});
43                 }
44         }
45 }
46
47 sub send_raw
48 {
49         my ($conn, $msg) = @_;
50     my $sock = $conn->{sock};
51     return unless defined($sock);
52         push (@{$conn->{outqueue}}, $msg);
53         dbg("connect $conn->{cnum}: $msg") if $conn->{state} ne 'C' && isdbg('connect');
54     Msg::set_event_handler ($sock, "write" => sub {$conn->_send(0)});
55 }
56
57 sub dequeue
58 {
59         my $conn = shift;
60         my $msg;
61
62         if ($conn->{csort} eq 'ax25' && exists $conn->{msg}) {
63                 $conn->{msg} =~ s/\cM/\cJ/g;
64         }
65         if ($conn->{state} eq 'WC') {
66                 if (exists $conn->{cmd}) {
67                         if (@{$conn->{cmd}}) {
68                                 dbg("connect $conn->{cnum}: $conn->{msg}") if isdbg('connect');
69                                 $conn->_docmd($conn->{msg});
70                         } 
71                 }
72                 if ($conn->{state} eq 'WC' && exists $conn->{cmd} && @{$conn->{cmd}} == 0) {
73                         $conn->to_connected($conn->{call}, 'O', $conn->{csort});
74                 }
75         } elsif ($conn->{msg} =~ /\cJ/) {
76                 my @lines =  $conn->{msg} =~ /([^\cM\cJ]*)\cM?\cJ/g;
77                 if ($conn->{msg} =~ /\cJ$/) {
78                         delete $conn->{msg};
79                 } else {
80                         $conn->{msg} = pop @lines;
81                 }
82                 while (defined ($msg = shift @lines)) {
83                         dbg("connect $conn->{cnum}: $msg") if $conn->{state} ne 'C' && isdbg('connect');
84                 
85                         $msg =~ s/\xff\xfa.*\xff\xf0|\xff[\xf0-\xfe].//g; # remove telnet options
86                         $msg =~ s/[\x00-\x08\x0a-\x19\x1b-\x1f\x80-\x9f]/./g;         # immutable CSI sequence + control characters
87                         
88                         if ($conn->{state} eq 'C') {
89                                 &{$conn->{rproc}}($conn, "I$conn->{call}|$msg");
90                         } elsif ($conn->{state} eq 'WL' ) {
91                                 $msg = uc $msg;
92                                 if (is_callsign($msg)) {
93                                         my $sort = $conn->{csort};
94                                         $sort = 'local' if $conn->{peerhost} eq "127.0.0.1";
95                                         $conn->to_connected($msg, 'A', $sort);
96                                 } else {
97                                         $conn->send_now("Sorry $msg is an invalid callsign");
98                                         $conn->disconnect;
99                                 }
100                         } elsif ($conn->{state} eq 'WC') {
101                                 if (exists $conn->{cmd} && @{$conn->{cmd}}) {
102                                         $conn->_docmd($msg);
103                                         if ($conn->{state} eq 'WC' && exists $conn->{cmd} &&  @{$conn->{cmd}} == 0) {
104                                                 $conn->to_connected($conn->{call}, 'O', $conn->{csort});
105                                         }
106                                 }
107                         }
108                 }
109         }
110 }
111
112 sub to_connected
113 {
114         my ($conn, $call, $dir, $sort) = @_;
115         $conn->{state} = 'C';
116         $conn->conns($call);
117         delete $conn->{cmd};
118         $conn->{timeout}->del if $conn->{timeout};
119         delete $conn->{timeout};
120         &{$conn->{rproc}}($conn, "$dir$call|$sort");
121         $conn->_send_file("$main::data/connected") unless $conn->{outgoing};
122 }
123
124 sub new_client {
125         my $server_conn = shift;
126     my $sock = $server_conn->{sock}->accept();
127         if ($sock) {
128                 my $conn = $server_conn->new($server_conn->{rproc});
129                 $conn->{sock} = $sock;
130                 Msg::blocking($sock, 0);
131                 $conn->{blocking} = 0;
132                 eval {$conn->{peerhost} = $sock->peerhost};
133                 if ($@) {
134                         dbg($@) if isdbg('connll');
135                         $conn->disconnect;
136                 } else {
137                         eval {$conn->{peerport} = $sock->peerport};
138                         $conn->{peerport} = 0 if $@;
139                         my ($rproc, $eproc) = &{$server_conn->{rproc}} ($conn, $conn->{peerhost}, $conn->{peerport});
140                         dbg("accept $conn->{cnum} from $conn->{peerhost} $conn->{peerport}") if isdbg('connll');
141                         if ($eproc) {
142                                 $conn->{eproc} = $eproc;
143                                 Msg::set_event_handler ($sock, "error" => $eproc);
144                         }
145                         if ($rproc) {
146                                 $conn->{rproc} = $rproc;
147                                 my $callback = sub {$conn->_rcv};
148                                 Msg::set_event_handler ($sock, "read" => $callback);
149                                 # send login prompt
150                                 $conn->{state} = 'WL';
151                                 #               $conn->send_raw("\xff\xfe\x01\xff\xfc\x01\ff\fd\x22");
152                                 #               $conn->send_raw("\xff\xfa\x22\x01\x01\xff\xf0");
153                                 #               $conn->send_raw("\xFF\xFC\x01");
154                                 $conn->_send_file("$main::data/issue");
155                                 $conn->send_raw("login: ");
156                                 $conn->_dotimeout(60);
157                         } else { 
158                                 &{$conn->{eproc}}() if $conn->{eproc};
159                                 $conn->disconnect();
160                         }
161                 }
162         } else {
163                 dbg("ExtMsg: error on accept ($!)") if isdbg('err');
164         }
165 }
166
167 sub start_connect
168 {
169         my $call = shift;
170         my $fn = shift;
171         my $conn = ExtMsg->new(\&main::new_channel); 
172         $conn->{outgoing} = 1;
173         $conn->conns($call);
174         
175         my $f = new IO::File $fn;
176         push @{$conn->{cmd}}, <$f>;
177         $f->close;
178         $conn->{state} = 'WC';
179         $conn->_dotimeout($deftimeout);
180         $conn->_docmd;
181 }
182
183 sub _docmd
184 {
185         my $conn = shift;
186         my $msg = shift;
187         my $cmd;
188
189         while ($cmd = shift @{$conn->{cmd}}) {
190                 chomp $cmd;
191                 next if $cmd =~ /^\s*\#/o;
192                 next if $cmd =~ /^\s*$/o;
193                 $conn->_doabort($1) if $cmd =~ /^\s*a\w*\s+(.*)/i;
194                 $conn->_dotimeout($1) if $cmd =~ /^\s*t\w*\s+(\d+)/i;
195                 $conn->_dolineend($1) if $cmd =~ /^\s*[Ll]\w*\s+\'((?:\\[rn])+)\'/i;
196                 if ($cmd =~ /^\s*co\w*\s+(\w+)\s+(.*)$/i) {
197                         unless ($conn->_doconnect($1, $2)) {
198                                 $conn->disconnect;
199                                 @{$conn->{cmd}} = [];    # empty any further commands
200                                 last;
201                         }  
202                 }
203                 if ($cmd =~ /^\s*\'.*\'\s+\'.*\'/i) {
204                         $conn->_dochat($cmd, $msg);
205                         last;
206                 }
207                 if ($cmd =~ /^\s*cl\w+\s+(.*)/i) {
208                         $conn->_doclient($1);
209                         last;
210                 }
211                 last if $conn->{state} eq 'E';
212         }
213 }
214
215 sub _doconnect
216 {
217         my ($conn, $sort, $line) = @_;
218         my $r;
219
220         $sort = lc $sort;
221         dbg("CONNECT $conn->{cnum} sort: $sort command: $line") if isdbg('connect');
222         if ($sort eq 'telnet') {
223                 # this is a straight network connect
224                 my ($host, $port) = split /\s+/, $line;
225                 $port = 23 if !$port;
226                 $r = $conn->connect($host, $port);
227                 if ($r) {
228                         dbg("Connected $conn->{cnum} to $host $port") if isdbg('connect');
229                 } else {
230                         dbg("***Connect $conn->{cnum} Failed to $host $port $!") if isdbg('connect');
231                 }
232         } elsif ($sort eq 'agw') {
233                 # turn it into an AGW object
234                 bless $conn, 'AGWMsg';
235                 $r = $conn->connect($line);
236         } elsif ($sort eq 'ax25' || $sort eq 'prog') {
237                 local $^F = 10000;              # make sure it ain't closed on exec
238                 my ($a, $b) = IO::Socket->socketpair(AF_UNIX, SOCK_STREAM, PF_UNSPEC);
239                 if ($a && $b) {
240                         $r = 1;
241                         $a->autoflush(1);
242                         $b->autoflush(1);
243                         my $pid = fork;
244                         if (defined $pid) {
245                                 if ($pid) {
246                                         close $b;
247                                         $conn->{sock} = $a;
248                                         $conn->{csort} = $sort;
249                                         $conn->{lineend} = "\cM" if $sort eq 'ax25';
250                                         $conn->{pid} = $pid;
251                                         if ($conn->{rproc}) {
252                                                 my $callback = sub {$conn->_rcv};
253                                                 Msg::set_event_handler ($a, read => $callback);
254                                         }
255                                         dbg("connect $conn->{cnum}: started pid: $conn->{pid} as $line") if isdbg('connect');
256                                 } else {
257                                         $^W = 0;
258                                         dbgclose();
259                                         STDIN->close;
260                                         STDOUT->close;
261                                         STDOUT->close;
262                                         *STDIN = IO::File->new_from_fd($b, 'r') or die;
263                                         *STDOUT = IO::File->new_from_fd($b, 'w') or die;
264                                         *STDERR = IO::File->new_from_fd($b, 'w') or die;
265                                         close $a;
266                                         unless ($main::is_win) {
267 #                                               $SIG{HUP} = 'IGNORE';
268                                                 $SIG{HUP} = $SIG{CHLD} = $SIG{TERM} = $SIG{INT} = 'DEFAULT';
269                                                 alarm(0);
270                                         }
271                                         exec "$line" or dbg("exec '$line' failed $!");
272                                 } 
273                         } else {
274                                 dbg("cannot fork");
275                                 $r = undef;
276                         }
277                 } else {
278                         dbg("no socket pair $!");
279                 }
280         } else {
281                 dbg("invalid type of connection ($sort)");
282         }
283         $conn->disconnect unless $r;
284         return $r;
285 }
286
287 sub _doabort
288 {
289         my $conn = shift;
290         my $string = shift;
291         dbg("connect $conn->{cnum}: abort $string") if isdbg('connect');
292         $conn->{abort} = $string;
293 }
294
295 sub _dotimeout
296 {
297         my $conn = shift;
298         my $val = shift;
299         dbg("connect $conn->{cnum}: timeout set to $val") if isdbg('connect');
300         $conn->{timeout}->del if $conn->{timeout};
301         $conn->{timeval} = $val;
302         $conn->{timeout} = Timer->new($val, sub{ &_timedout($conn) });
303 }
304
305 sub _dolineend
306 {
307         my $conn = shift;
308         my $val = shift;
309         dbg("connect $conn->{cnum}: lineend set to $val ") if isdbg('connect');
310         $val =~ s/\\r/\r/g;
311         $val =~ s/\\n/\n/g;
312         $conn->{lineend} = $val;
313 }
314
315 sub _dochat
316 {
317         my $conn = shift;
318         my $cmd = shift;
319         my $line = shift;
320                 
321         if ($line) {
322                 my ($expect, $send) = $cmd =~ /^\s*\'(.*)\'\s+\'(.*)\'/;
323                 if ($expect) {
324                         dbg("connect $conn->{cnum}: expecting: \"$expect\" received: \"$line\"") if isdbg('connect');
325                         if ($conn->{abort} && $line =~ /\Q$conn->{abort}/i) {
326                                 dbg("connect $conn->{cnum}: aborted on /$conn->{abort}/") if isdbg('connect');
327                                 $conn->disconnect;
328                                 delete $conn->{cmd};
329                                 return;
330                         }
331                         if ($line =~ /\Q$expect/i) {
332                                 if (length $send) {
333                                         dbg("connect $conn->{cnum}: got: \"$expect\" sending: \"$send\"") if isdbg('connect');
334                                         $conn->send_later("D$conn->{call}|$send");
335                                 }
336                                 delete $conn->{msg}; # get rid any input if a match
337                                 return;
338                         }
339                 }
340         }
341         $conn->{state} = 'WC';
342         unshift @{$conn->{cmd}}, $cmd;
343 }
344
345 sub _timedout
346 {
347         my $conn = shift;
348         dbg("connect $conn->{cnum}: timed out after $conn->{timeval} seconds") if isdbg('connect');
349         $conn->disconnect;
350 }
351
352 # handle callsign and connection type firtling
353 sub _doclient
354 {
355         my $conn = shift;
356         my $line = shift;
357         my @f = split /\s+/, $line;
358         my $call = uc $f[0] if $f[0];
359         $conn->conns($call);
360         $conn->{csort} = $f[1] if $f[1];
361         $conn->{state} = 'C';
362         &{$conn->{rproc}}($conn, "O$call|$conn->{csort}");
363         delete $conn->{cmd};
364         $conn->{timeout}->del if $conn->{timeout};
365 }
366
367 sub _send_file
368 {
369         my $conn = shift;
370         my $fn = shift;
371         
372         if (-e $fn) {
373                 my $f = new IO::File $fn;
374                 if ($f) {
375                         while (<$f>) {
376                                 chomp;
377                                 my $l = $_;
378                                 dbg("connect $conn->{cnum}: $l") if isdbg('connll');
379                                 $conn->send_raw($l . $conn->{lineend});
380                         }
381                         $f->close;
382                 }
383         }
384 }