]> scm.dxcluster.org Git - spider.git/blob - perl/client.pl
added announce
[spider.git] / perl / client.pl
1 #!/usr/bin/perl
2 #
3 # A thing that implements dxcluster 'protocol'
4 #
5 # This is a perl module/program that sits on the end of a dxcluster
6 # 'protocol' connection and deals with anything that might come along.
7 #
8 # this program is called by ax25d and gets raw ax25 text on its input
9 #
10 # Copyright (c) 1998 Dirk Koopman G1TLH
11 #
12 # $Id$
13
14
15 # search local then perl directories
16 BEGIN {
17   unshift @INC, "/spider/perl";   # this IS the right way round!
18   unshift @INC, "/spider/local";
19 }
20
21 use Msg;
22 use DXVars;
23
24 $mode = 2;                      # 1 - \n = \r as EOL, 2 - \n = \n, 0 - transparent
25 $call = "";                     # the callsign being used
26 @stdoutq = ();                  # the queue of stuff to send out to the user
27 $conn = 0;                      # the connection object for the cluster
28 $lastbit = "";                  # the last bit of an incomplete input line
29 $mynl = "\n";                   # standard terminator
30 $lasttime = time;               # lasttime something happened on the interface
31 $outqueue = "";                 # the output queue length
32 $buffered = 1;                  # buffer output
33 $savenl = "";                   # an NL that has been saved from last time
34
35 # cease communications
36 sub cease
37 {
38   my $sendz = shift;
39   if (defined $conn && $sendz) {
40     $conn->send_now("Z$call|bye...\n");
41   }
42   exit(0);      
43 }
44
45 # terminate program from signal
46 sub sig_term
47 {
48   cease(1);
49 }
50
51 sub setmode
52 {
53   if ($mode == 1) {
54     $mynl = "\r";
55   } else {
56         $mynl = "\n";
57   }
58   $/ = $mynl;
59 }
60
61 # handle incoming messages
62 sub rec_socket
63 {
64   my ($con, $msg, $err) = @_;
65   if (defined $err && $err) {
66     cease(1);
67   }
68   if (defined $msg) {
69     my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)\|(.*)$/;
70         
71         if ($sort eq 'D') {
72            my $snl = $mynl;
73            my $newsavenl = "";
74            $snl = "" if $mode == 0;
75            if ($mode && $line =~ />$/) {
76              $newsavenl = $snl;
77                  $snl = ' ';
78            }
79            $line =~ s/\n/\r/og if $mode == 1;
80            #my $p = qq($line$snl);
81            if ($buffered) {
82              if (length $outqueue >= 128) {
83                print $outqueue;
84                    $outqueue = "";
85              }
86              $outqueue .= "$savenl$line$snl";
87                  $lasttime = time;
88            } else {
89              print $savenl, $line, $snl;;
90            }
91            $savenl = $newsavenl;
92         } elsif ($sort eq 'M') {
93           $mode = $line;               # set new mode from cluster
94       setmode();
95         } elsif ($sort eq 'B') {
96           if ($buffered && $outqueue) {
97             print $outqueue;
98                 $outqueue = "";
99           }
100           $buffered = $line;           # set buffered or unbuffered
101     } elsif ($sort eq 'Z') {       # end, disconnect, go, away .....
102           cease(0);
103     }     
104   }
105   $lasttime = time; 
106 }
107
108 sub rec_stdin
109 {
110   my ($fh) = @_;
111   my $buf;
112   my @lines;
113   my $r;
114   my $first;
115   my $dangle = 0;
116   
117   $r = sysread($fh, $buf, 1024);
118 #  print "sys: $r $buf";
119   if ($r > 0) {
120     if ($mode) {
121           $buf =~ s/\r/\n/og if $mode == 1;
122           $dangle = !($buf =~ /\n$/);
123           @lines = split /\n/, $buf;
124           if ($dangle) {                # pull off any dangly bits
125             $buf = pop @lines;
126           } else {
127             $buf = "";
128           }
129           $first = shift @lines;
130           unshift @lines, ($lastbit . $first) if ($first);
131           foreach $first (@lines) {
132             $conn->send_now("D$call|$first");
133           }
134           $lastbit = $buf;
135           $savenl = "";     # reset savenl 'cos we will have done a newline on input
136         } else {
137           $conn->send_now("D$call|$buf");
138         }
139   } elsif ($r == 0) {
140     cease(1);
141   }
142   $lasttime = time;
143 }
144
145 $call = uc shift @ARGV;
146 $call = uc $myalias if !$call; 
147 $connsort = lc shift @ARGV;
148 $connsort = 'local' if !$connsort;
149 $mode = ($connsort =~ /^ax/o) ? 1 : 2;
150 setmode();
151 if ($call eq $mycall) {
152   print "You cannot connect as your cluster callsign ($mycall)", $nl;
153   cease(0);
154 }
155
156 #select STDOUT; $| = 1;
157 STDOUT->autoflush(1);
158
159 $SIG{'INT'} = \&sig_term;
160 $SIG{'TERM'} = \&sig_term;
161 $SIG{'HUP'} = \&sig_term;
162
163 $conn = Msg->connect("$clusteraddr", $clusterport, \&rec_socket);
164 $conn->send_now("A$call|$connsort");
165 Msg->set_event_handler(\*STDIN, "read" => \&rec_stdin);
166
167 for (;;) {
168   my $t;
169   Msg->event_loop(1, 0.010);
170   $t = time;
171   if ($t > $lasttime) {
172     if ($outqueue) {
173           print $outqueue;
174           $outqueue = "";
175         }
176         $lasttime = $t;
177   }
178 }
179