]> scm.dxcluster.org Git - spider.git/blob - perl/winclient.pl
fix modules search path in update_sysop.pl
[spider.git] / 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