perl/winclient.pl

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