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 # $Id$
  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 FileHandle;
  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', "CONNECT sort: $sort command: $line");
  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('connect', "got pid $pid");
 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('connect', "abort $string");
 115         $abort = $string;
 116 }
 117
 118 sub dotimeout
 119 {
 120         my $val = shift;
 121         dbg('connect', "timeout set to $val");
 122         alarm($timeout = $val);
 123 }
 124
 125 sub dochat
 126 {
 127         my ($expect, $send) = @_;
 128         dbg('connect', "CHAT \"$expect\" -> \"$send\"");
 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('connect', "received \"$line\"");
 143                 if ($abort && $line =~ /$abort/i) {
 144                         dbg('connect', "aborted on /$abort/");
 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('connect', "sent \"$send\"");
 156         }
 157 }
 158
 159 sub doclient
 160 {
 161         my ($cl, $args) = @_;
 162         dbg('connect', "client: $cl args: $args");
 163     my @args = split /\s+/, $args;
 164
 165 #       if (!defined ($pid = fork())) {
 166 #               dbg('connect', "can't fork");
 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('connect', "client can't get here");
 186                         exit(13);
 187                 }
 188 #    }
 189 }
 190
 191 sub timeout
 192 {
 193         dbg('connect', "timed out after $timeout seconds");
 194         exit(10);
 195 }
 196
 197 sub term
 198 {
 199         dbg('connect', "caught INT or TERM signal");
 200         kill $pid if $pid;
 201         sleep(2);
 202         exit(12);
 203 }
 204
 205 sub reap
 206 {
 207     my $wpid = wait;
 208         dbg('connect', "pid $wpid has died");
 209 }