perl/winclient.pl

   1 #!/usr/bin/perl -w
   2 # The rudimentary beginnings of a Spider client which is known to run on ActiveState
   3 # Perl under Win32
   4 #
   5 # It's very scrappy, but it *does* do enough to allow SysOp console access. It also
   6 # means that since it's perl, Dirk might pretty it up a bit :-)
   7 #
   8 # $Id$
   9 #
  10 # Iain Philipps, G0RDI  03-Mar-01
  11 #
  12
  13 require 5.004;
  14
  15 use strict;
  16
  17 # search local then perl directories
  18 BEGIN {
  19         use vars qw($root $myalias $mycall $clusteraddr $clusterport $data);
  20
  21         # root of directory tree for this system
  22         $root = "/spider";
  23         $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
  24
  25         unshift @INC, "$root/perl";     # this IS the right way round!
  26         unshift @INC, "$root/local";
  27 }
  28
  29 use IO::Socket;
  30 use DXVars;
  31 use IO::File;
  32
  33 #
  34 # deal with args
  35 #
  36
  37 my $call = uc shift @ARGV if @ARGV;
  38 $call = uc $myalias if !$call;
  39 my ($scall, $ssid) = split /-/, $call;
  40 $ssid = undef unless $ssid && $ssid =~ /^\d+$/;
  41 if ($ssid) {
  42         $ssid = 15 if $ssid > 15;
  43         $call = "$scall-$ssid";
  44 }
  45 if ($call eq $mycall) {
  46         print "You cannot connect as your cluster callsign ($mycall)\n";
  47         exit(0);
  48 }
  49
  50 # connect to server
  51 my $handle = IO::Socket::INET->new(Proto     => "tcp",
  52                                                                    PeerAddr  => $clusteraddr,
  53                                                                    PeerPort  => $clusterport);
  54 unless ($handle) {
  55         if (-r "$data/offline") {
  56                 open IN, "$data/offline" or die;
  57                 while (<IN>) {
  58                         print $_;
  59                 }
  60                 close IN;
  61         } else {
  62                 print "Sorry, the cluster $mycall is currently off-line\n";
  63         }
  64         exit(0);
  65 }
  66
  67 # Fork one in / one out .....
  68 my $childpid;
  69 die "can't fork: $!" unless defined($childpid = fork());
  70
  71 # the communication .....
  72 if ($childpid) {
  73         my ($lastend, $end) = ("\n", "\n");
  74
  75         STDOUT->autoflush(1);
  76     while (defined (my $msg = <$handle>)) {
  77                 my ($sort, $call, $line) = $msg =~ /^(\w)([^\|]+)\|(.*)$/;
  78                 next unless defined $sort;
  79                 $line =~ s/\%([0-9A-F][0-9A-F])/chr(hex($1))/eg;
  80                 if ($sort eq 'Z') {
  81                         kill 'TERM', $childpid;
  82                         exit(0);
  83                 } elsif ($sort eq 'E' || $sort eq 'B') {
  84                         ;
  85                 } else {
  86                         # newline ends all lines except a prompt
  87                         $lastend = $end;
  88                         $end = "\n";
  89                         if ($line =~ /^$call de $mycall\s+\d+-\w\w\w-\d+\s+\d+Z >$/o) {
  90                                 $end = ' ';
  91                         }
  92                         my $begin = ($lastend eq "\n") ? '' : "\n";
  93                         print $begin . $line . $end;
  94                 }
  95     }
  96     kill 'TERM', $childpid;
  97 } else {
  98         $handle->autoflush(1);
  99         print $handle "A$call|local\n";
 100     while (defined (my $line = <STDIN>)) {
 101         print $handle "I$call|$line\n";
 102     }
 103 }
 104
 105 exit 0;
 106