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 Carp;
  42
  43 $timeout = 30;         # default timeout for each stage of the connect
  44 $abort = '';           # default connection abort string
  45 $path = "$root/connect";    # the basic connect directory
  46 $client = "$root/perl/client.pl";   # default client
  47
  48 $connected = 0;        # we have successfully connected or started an interface program
  49
  50 exit(1) if !$ARGV[0];       # bang out if no callsign
  51 open(IN, "$path/$ARGV[0]") or exit(2);
  52
  53 while (<IN>) {
  54   chomp;
  55   next if /^\s*#/o;
  56   next if /^\s*$/o;
  57   doconnect($1, $2) if /^\s*co\w*\s+(.*)$/io;
  58   doclient($1) if /^\s*cl\w*\s+(.*)$/io;
  59   doabort($1) if /^\s*a\w*\s+(.*)/io;
  60   dotimeout($1) if /^\s*t\w*\s+(\d+)/io;
  61   dochat($1, $2) if /\s*\'(.*)\'\s+\'(.*)'/io;
  62 }
  63
  64 sub doconnect
  65 {
  66   my ($sort, $name) = @_;
  67   print "connect $sort $name\n";
  68 }
  69
  70 sub doabort
  71 {
  72   my $string = shift;
  73   print "abort $string\n";
  74 }
  75
  76 sub dotimeout
  77 {
  78   my $val = shift;
  79   print "timeout $val\n";
  80 }
  81
  82 sub dochat
  83 {
  84   my ($expect, $send) = @_;
  85   print "chat '$expect' '$send'\n";
  86 }
  87
  88 sub doclient
  89 {
  90   my $cl = shift;
  91   print "client $cl\n";
  92 }