]> scm.dxcluster.org Git - spider.git/blob - perl/winclient.pl
*** empty log message ***
[spider.git] / 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                 if ($sort eq 'Z') {
79                         kill 'TERM', $childpid;
80                         exit(0);
81                 } elsif ($sort eq 'E' || $sort eq 'B') {
82                         ;
83                 } else {
84                         # newline ends all lines except a prompt
85                         $lastend = $end;
86                         $end = "\n";
87                         if ($line =~ /^$call de $mycall\s+\d+-\w\w\w-\d+\s+\d+Z >$/o) {
88                                 $end = ' ';
89                         }
90                         my $begin = ($lastend eq "\n") ? '' : "\n";
91                         print $begin . $line . $end;
92                 }
93     }
94     kill 'TERM', $childpid;
95 } else {
96         $handle->autoflush(1);
97         print $handle "A$call|local\n";
98     while (defined (my $line = <STDIN>)) {
99         print $handle "I$call|$line\n";
100     }
101 }
102
103 exit 0;
104