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