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 use Config;
  33
  34 #
  35 # deal with args
  36 #
  37
  38 my $call = uc shift @ARGV if @ARGV;
  39 $call = uc $myalias if !$call;
  40 my ($scall, $ssid) = split /-/, $call;
  41 $ssid = undef unless $ssid && $ssid =~ /^\d+$/;
  42 if ($ssid) {
  43         $ssid = 15 if $ssid > 15;
  44         $call = "$scall-$ssid";
  45 }
  46 if ($call eq $mycall) {
  47         print "You cannot connect as your cluster callsign ($mycall)\n";
  48         exit(0);
  49 }
  50
  51 # connect to server
  52 my $handle = IO::Socket::INET->new(Proto     => "tcp",
  53                                                                    PeerAddr  => $clusteraddr,
  54                                                                    PeerPort  => $clusterport);
  55 unless ($handle) {
  56         if (-r "$data/offline") {
  57                 open IN, "$data/offline" or die;
  58                 while (<IN>) {
  59                         print $_;
  60                 }
  61                 close IN;
  62         } else {
  63                 print "Sorry, the cluster $mycall is currently off-line\n";
  64         }
  65         exit(0);
  66 }
  67
  68 STDOUT->autoflush(1);
  69 $handle->autoflush(1);
  70 print $handle "A$call|local\n";
  71
  72 # Fork or thread one in / one out .....
  73 my $childpid;
  74 my $t;
  75 if ($Config{usethreads}) {
  76         require Thread;
  77 #       print "Using Thread Method\n";
  78         $t = Thread->new(\&dostdin);
  79         donetwork();
  80         $t->join;
  81         kill(-1, $$);
  82 } else {
  83 #       print "Using Fork Method\n";
  84         die "can't fork: $!" unless defined($childpid = fork());
  85         if ($childpid) {
  86                 donetwork();
  87                 kill 'TERM', $childpid;
  88         } else {
  89                 dostdin();
  90         }
  91 }
  92 exit 0;
  93
  94
  95 sub donetwork
  96 {
  97         my ($lastend, $end) = ("\n", "\n");
  98
  99     while (defined (my $msg = <$handle>)) {
 100                 my ($sort, $call, $line) = $msg =~ /^(\w)([^\|]+)\|(.*)$/;
 101                 next unless defined $sort;
 102                 $line =~ s/\%([0-9A-F][0-9A-F])/chr(hex($1))/eg;
 103                 if ($sort eq 'Z') {
 104                         return;
 105                 } elsif ($sort eq 'E' || $sort eq 'B') {
 106                         ;
 107                 } else {
 108                         # newline ends all lines except a prompt
 109                         $lastend = $end;
 110                         $end = "\n";
 111                         if ($line =~ /^$call de $mycall\s+\d+-\w\w\w-\d+\s+\d+Z >$/o) {
 112                                 $end = ' ';
 113                         }
 114                         my $begin = ($lastend eq "\n") ? '' : "\n";
 115                         print $begin . $line . $end;
 116                 }
 117     }
 118 }
 119
 120 sub dostdin
 121 {
 122     while (defined (my $line = <STDIN>)) {
 123         print $handle "I$call|$line\n";
 124                 if ($t && ($line =~ /^b/i || $line =~ /^q/i)) {
 125                         return;
 126                 }
 127     }
 128 }
 129
 130
 131