]> scm.dxcluster.org Git - spider.git/blob - perl/ExtMsg.pm
8a5e4612926b9b5da6a8212f6404090f62c78fab
[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', $msg) unless $conn->{state} eq 'C';
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->{msg});
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', $msg) unless $conn->{state} eq 'C';
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                                         $conn->to_connected($msg, 'A', $conn->{csort});
94                                 } else {
95                                         $conn->send_now("Sorry $msg is an invalid callsign");
96                                         $conn->disconnect;
97                                 }
98                         } elsif ($conn->{state} eq 'WC') {
99                                 if (exists $conn->{cmd} && @{$conn->{cmd}}) {
100                                         $conn->_docmd($msg);
101                                         if ($conn->{state} eq 'WC' && exists $conn->{cmd} &&  @{$conn->{cmd}} == 0) {
102                                                 $conn->to_connected($conn->{call}, 'O', $conn->{csort});
103                                         }
104                                 }
105                         }
106                 }
107         }
108 }
109
110 sub to_connected
111 {
112         my ($conn, $call, $dir, $sort) = @_;
113         $conn->{state} = 'C';
114         $conn->conns($call);
115         delete $conn->{cmd};
116         $conn->{timeout}->del if $conn->{timeout};
117         delete $conn->{timeout};
118         &{$conn->{rproc}}($conn, "$dir$call|$sort");
119         $conn->_send_file("$main::data/connected");
120 }
121
122 sub new_client {
123         my $server_conn = shift;
124     my $sock = $server_conn->{sock}->accept();
125         if ($sock) {
126                 my $conn = $server_conn->new($server_conn->{rproc});
127                 $conn->{sock} = $sock;
128                 Msg::blocking($sock, 0);
129                 $conn->{blocking} = 0;
130                 
131                 my ($rproc, $eproc) = &{$server_conn->{rproc}} ($conn, $conn->{peerhost} = $sock->peerhost(), $conn->{peerport} = $sock->peerport());
132                 dbg('connll', "accept $conn->{cnum} from $conn->{peerhost} $conn->{peerport}");
133                 if ($eproc) {
134                         $conn->{eproc} = $eproc;
135                         Msg::set_event_handler ($sock, "error" => $eproc);
136                 }
137                 if ($rproc) {
138                         $conn->{rproc} = $rproc;
139                         my $callback = sub {$conn->_rcv};
140                         Msg::set_event_handler ($sock, "read" => $callback);
141                         # send login prompt
142                         $conn->{state} = 'WL';
143                         #               $conn->send_raw("\xff\xfe\x01\xff\xfc\x01\ff\fd\x22");
144                         #               $conn->send_raw("\xff\xfa\x22\x01\x01\xff\xf0");
145                         #               $conn->send_raw("\xFF\xFC\x01");
146                         $conn->_send_file("$main::data/issue");
147                         $conn->send_raw("login: ");
148                         $conn->_dotimeout(60);
149                 } else { 
150                         &{$conn->{eproc}}() if $conn->{eproc};
151                         $conn->disconnect();
152                 }
153         } else {
154                 dbg('err', "ExtMsg: error on accept ($!)");
155         }
156 }
157
158 sub start_connect
159 {
160         my $call = shift;
161         my $fn = shift;
162         my $conn = ExtMsg->new(\&main::new_channel); 
163         $conn->conns($call);
164         
165         my $f = new IO::File $fn;
166         push @{$conn->{cmd}}, <$f>;
167         $f->close;
168         $conn->{state} = 'WC';
169         $conn->_dotimeout($deftimeout);
170         $conn->_docmd;
171 }
172
173 sub _docmd
174 {
175         my $conn = shift;
176         my $msg = shift;
177         my $cmd;
178
179         while ($cmd = shift @{$conn->{cmd}}) {
180                 chomp $cmd;
181                 next if $cmd =~ /^\s*\#/o;
182                 next if $cmd =~ /^\s*$/o;
183                 $conn->_doabort($1) if $cmd =~ /^\s*a\w*\s+(.*)/i;
184                 $conn->_dotimeout($1) if $cmd =~ /^\s*t\w*\s+(\d+)/i;
185                 $conn->_dolineend($1) if $cmd =~ /^\s*[Ll]\w*\s+\'((?:\\[rn])+)\'/i;
186                 if ($cmd =~ /^\s*co\w*\s+(\w+)\s+(.*)$/i) {
187                         unless ($conn->_doconnect($1, $2)) {
188                                 $conn->disconnect;
189                                 @{$conn->{cmd}} = [];    # empty any further commands
190                                 last;
191                         }  
192                 }
193                 if ($cmd =~ /^\s*\'.*\'\s+\'.*\'/i) {
194                         $conn->_dochat($cmd, $msg);
195                         last;
196                 }
197                 if ($cmd =~ /^\s*cl\w+\s+(.*)/i) {
198                         $conn->_doclient($1);
199                         last;
200                 }
201                 last if $conn->{state} eq 'E';
202         }
203 }
204
205 sub _doconnect
206 {
207         my ($conn, $sort, $line) = @_;
208         my $r;
209
210         $sort = lc $sort;
211         dbg('connect', "CONNECT sort: $sort command: $line");
212         if ($sort eq 'telnet') {
213                 # this is a straight network connect
214                 my ($host, $port) = split /\s+/, $line;
215                 $port = 23 if !$port;
216                 $r = $conn->connect($host, $port);
217                 if ($r) {
218                         dbg('connect', "Connected to $host $port");
219                 } else {
220                         dbg('connect', "***Connect Failed to $host $port $!");
221                 }
222         } elsif ($sort eq 'agw') {
223                 # turn it into an AGW object
224                 bless $conn, 'AGWMsg';
225                 $r = $conn->connect($line);
226         } elsif ($sort eq 'ax25' || $sort eq 'prog') {
227                 local $^F = 10000;              # make sure it ain't closed on exec
228                 my ($a, $b) = IO::Socket->socketpair(AF_UNIX, SOCK_STREAM, PF_UNSPEC);
229                 if ($a && $b) {
230                         $r = 1;
231                         $a->autoflush(1);
232                         $b->autoflush(1);
233                         my $pid = fork;
234                         if (defined $pid) {
235                                 if ($pid) {
236                                         close $b;
237                                         $conn->{sock} = $a;
238                                         $conn->{csort} = $sort;
239                                         $conn->{lineend} = "\cM" if $sort eq 'ax25';
240                                         $conn->{pid} = $pid;
241                                         if ($conn->{rproc}) {
242                                                 my $callback = sub {$conn->_rcv};
243                                                 Msg::set_event_handler ($a, read => $callback);
244                                         }
245                                         dbg('connect', "started pid: $conn->{pid} as $line");
246                                 } else {
247                                         $^W = 0;
248                                         dbgclose();
249                                         STDIN->close;
250                                         STDOUT->close;
251                                         STDOUT->close;
252                                         *STDIN = IO::File->new_from_fd($b, 'r') or die;
253                                         *STDOUT = IO::File->new_from_fd($b, 'w') or die;
254                                         *STDERR = IO::File->new_from_fd($b, 'w') or die;
255                                         close $a;
256                                         unless ($main::is_win) {
257 #                                               $SIG{HUP} = 'IGNORE';
258                                                 $SIG{HUP} = $SIG{CHLD} = $SIG{TERM} = $SIG{INT} = 'DEFAULT';
259                                                 alarm(0);
260                                         }
261                                         exec "$line" or dbg('err', "exec '$line' failed $!");
262                                 } 
263                         } else {
264                                 dbg('err', "cannot fork");      
265                                 $r = undef;
266                         }
267                 } else {
268                         dbg('err', "no socket pair $!");
269                 }
270         } else {
271                 dbg('err', "invalid type of connection ($sort)");
272         }
273         $conn->disconnect unless $r;
274         return $r;
275 }
276
277 sub _doabort
278 {
279         my $conn = shift;
280         my $string = shift;
281         dbg('connect', "abort $string");
282         $conn->{abort} = $string;
283 }
284
285 sub _dotimeout
286 {
287         my $conn = shift;
288         my $val = shift;
289         dbg('connect', "timeout set to $val");
290         $conn->{timeout}->del if $conn->{timeout};
291         $conn->{timeval} = $val;
292         $conn->{timeout} = Timer->new($val, sub{ &_timedout($conn) });
293 }
294
295 sub _dolineend
296 {
297         my $conn = shift;
298         my $val = shift;
299         dbg('connect', "lineend set to $val ");
300         $val =~ s/\\r/\r/g;
301         $val =~ s/\\n/\n/g;
302         $conn->{lineend} = $val;
303 }
304
305 sub _dochat
306 {
307         my $conn = shift;
308         my $cmd = shift;
309         my $line = shift;
310                 
311         if ($line) {
312                 my ($expect, $send) = $cmd =~ /^\s*\'(.*)\'\s+\'(.*)\'/;
313                 if ($expect) {
314                         dbg('connect', "expecting: \"$expect\" received: \"$line\"");
315                         if ($conn->{abort} && $line =~ /\Q$conn->{abort}/i) {
316                                 dbg('connect', "aborted on /$conn->{abort}/");
317                                 $conn->disconnect;
318                                 delete $conn->{cmd};
319                                 return;
320                         }
321                         if ($line =~ /\Q$expect/i) {
322                                 if (length $send) {
323                                         dbg('connect', "got: \"$expect\" sending: \"$send\"");
324                                         $conn->send_later("D$conn->{call}|$send");
325                                 }
326                                 delete $conn->{msg}; # get rid any input if a match
327                                 return;
328                         }
329                 }
330         }
331         $conn->{state} = 'WC';
332         unshift @{$conn->{cmd}}, $cmd;
333 }
334
335 sub _timedout
336 {
337         my $conn = shift;
338         dbg('connect', "timed out after $conn->{timeval} seconds");
339         $conn->disconnect;
340 }
341
342 # handle callsign and connection type firtling
343 sub _doclient
344 {
345         my $conn = shift;
346         my $line = shift;
347         my @f = split /\s+/, $line;
348         my $call = uc $f[0] if $f[0];
349         $conn->conns($call);
350         $conn->{csort} = $f[1] if $f[1];
351         $conn->{state} = 'C';
352         &{$conn->{rproc}}($conn, "O$call|$conn->{csort}");
353         delete $conn->{cmd};
354         $conn->{timeout}->del if $conn->{timeout};
355 }
356
357 sub _send_file
358 {
359         my $conn = shift;
360         my $fn = shift;
361         
362         if (-e $fn) {
363                 my $f = new IO::File $fn;
364                 if ($f) {
365                         while (<$f>) {
366                                 chomp;
367                                 my $l = $_;
368                                 dbg('connll', "connect $conn->{cnum}: $l");
369                                 $conn->send_raw($l . $conn->{lineend});
370                         }
371                         $f->close;
372                 }
373         }
374 }