]> scm.dxcluster.org Git - spider.git/blob - perl/connect.pl
remove typo in dxprothandle
[spider.git] / perl / connect.pl
1 #!/usr/bin/perl
2 #
3 # connect to an external entity
4 #
5 # This is the routine that is called by the cluster to manage
6 # an outgoing connection to the point where it is 'connected'.
7 # From there the client program is forked and execed over the top of
8 # this program and that connects back to the cluster as though
9 # it were an incoming connection.
10 #
11 # Essentially this porgram does the same as chat in that there
12 # are 'expect', 'send' pairs of strings. The 'expect' string is 
13 # a pattern. You can include timeout and abort string statements
14 # at any time.
15 #
16 # Commands are:-
17 #
18 # connect <type> <destination>|<program>
19 # timeout <secs>
20 # abort <regexp>
21 # client <client name> <parameters>
22 # '<regexp>' '<send string>'
23 #
24 # Copyright (c) Dirk Koopman G1TLH
25 #
26 #
27 #
28
29 # search local then perl directories
30 BEGIN {
31         # root of directory tree for this system
32         $root = "/spider"; 
33         $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
34         
35         unshift @INC, "$root/perl";     # this IS the right way round!
36         unshift @INC, "$root/local";
37 }
38
39 use DXVars;
40 use IO::Socket;
41 use IO::File;
42 use Open2;
43 use DXDebug;
44 use POSIX qw(dup);
45 use Carp;
46
47 $timeout = 30;                                  # default timeout for each stage of the connect
48 $abort = '';                                    # default connection abort string
49 $path = "$root/connect";                # the basic connect directory
50 $client = "$root/perl/client.pl"; # default client
51
52 $connected = 0;                                 # we have successfully connected or started an interface program
53 $pid = 0;                       # the pid of the child program
54 $csort = "";                    # the connection type
55 $sock = 0;                      # connection socket
56
57 sub timeout;
58 sub term;
59 sub reap;
60
61 $SIG{ALRM} = \&timeout;
62 $SIG{TERM} = \&term;
63 $SIG{INT} = \&term;
64 $SIG{REAP} = \&reap;
65 $SIG{HUP} = 'IGNORE';
66
67 exit(1) if !$ARGV[0];                   # bang out if no callsign
68 open(IN, "$path/$ARGV[0]") or exit(2);
69 @in = <IN>;
70 close IN;
71 STDOUT->autoflush(1);
72 dbgadd('connect');
73
74 alarm($timeout);
75
76 for (@in) {
77         chomp;
78         next if /^\s*\#/o;
79         next if /^\s*$/o;
80         doconnect($1, $2) if /^\s*co\w*\s+(\w+)\s+(.*)$/io;
81         doclient($1) if /^\s*cl\w*\s+(\w+)\s+(.*)$/io;
82         doabort($1) if /^\s*a\w*\s+(.*)/io;
83         dotimeout($1) if /^\s*t\w*\s+(\d+)/io;
84         dochat($1, $2) if /\s*\'(.*)\'\s+\'(.*)\'/io;          
85 }
86
87 sub doconnect
88 {
89         my ($sort, $line) = @_;
90         dbg("CONNECT sort: $sort command: $line") if isdbg('connect');
91         if ($sort eq 'net') {
92                 # this is a straight network connect
93                 my ($host) = $line =~ /host\s+(\w+)/o;
94                 my ($port) = $line =~ /port\s+(\d+)/o;
95                 $port = 23 if !$port;
96                 
97                 $sock = IO::Socket::INET->new(PeerAddr => "$host", PeerPort => "$port", Proto => 'tcp')
98                         or die "Can't connect to $host port $port $!";
99                 
100         } elsif ($sort eq 'ax25') {
101                 my @args = split /\s+/, $line;
102                 $pid = open2(\*R, \*W, "$line") or die "can't do $line $!";
103                 dbg("got pid $pid") if isdbg('connect');
104                 W->autoflush(1);
105         } else {
106                 die "can't get here";
107         }
108         $csort = $sort;
109 }
110
111 sub doabort
112 {
113         my $string = shift;
114         dbg("abort $string") if isdbg('connect');
115         $abort = $string;
116 }
117
118 sub dotimeout
119 {
120         my $val = shift;
121         dbg("timeout set to $val") if isdbg('connect');
122         alarm($timeout = $val);
123 }
124
125 sub dochat
126 {
127         my ($expect, $send) = @_;
128         dbg("CHAT \"$expect\" -> \"$send\"") if isdbg('connect');
129     my $line;
130
131         alarm($timeout);
132         
133     if ($expect) {
134                 if ($csort eq 'net') {
135                         $line = <$sock>;
136                         chomp;
137                 } elsif ($csort eq 'ax25') {
138                         local $/ = "\r";
139                         $line = <R>;
140                         $line =~ s/\r//og;
141                 }
142                 dbg("received \"$line\"") if isdbg('connect');
143                 if ($abort && $line =~ /$abort/i) {
144                         dbg("aborted on /$abort/") if isdbg('connect');
145                         exit(11);
146                 }
147         }
148         if ($send && (!$expect || $line =~ /$expect/i)) {
149                 if ($csort eq 'net') {
150                         $sock->print("$send\n");
151                 } elsif ($csort eq 'ax25') {
152                         local $\ = "\r";
153                         W->print("$send\r");
154                 }
155                 dbg("sent \"$send\"") if isdbg('connect');
156         }
157 }
158
159 sub doclient
160 {
161         my ($cl, $args) = @_;
162         dbg("client: $cl args: $args") if isdbg('connect');
163     my @args = split /\s+/, $args;
164
165 #       if (!defined ($pid = fork())) {
166 #               dbg("can't fork") if isdbg('connect');
167 #               exit(13);
168 #       }
169 #       if ($pid) {
170 #               sleep(1);
171 #               exit(0);
172 #       } else {
173                 
174                 close(STDIN);
175                 close(STDOUT);
176                 if ($csort eq 'net') {
177                         open STDIN, "<&$sock";
178                         open STDOUT, ">&$sock";
179                         exec $cl, @args;
180                 } elsif ($csort eq 'ax25') {
181                         open STDIN, "<&R";
182                         open STDOUT, ">&W";
183                         exec $cl, @args;
184                 } else {
185                         dbg("client can't get here") if isdbg('connect');
186                         exit(13);
187                 }
188 #    }
189 }
190
191 sub timeout
192 {
193         dbg("timed out after $timeout seconds") if isdbg('connect');
194         exit(10);
195 }
196
197 sub term
198 {
199         dbg("caught INT or TERM signal") if isdbg('connect');
200         kill $pid if $pid;
201         sleep(2);
202         exit(12);
203 }
204
205 sub reap
206 {
207     my $wpid = wait;
208         dbg("pid $wpid has died") if isdbg('connect');
209 }