X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2Fclient.pl;h=ff2ca473f82b03451e0f023d7d72d3ee6e9adc5b;hb=c20a2c1e01d707d6c3fa25067df93d491aba8fff;hp=3227195747d5dcfd347cbd800bc40c957ebe71f3;hpb=b060a0a3ee72530aa3f10d453186a662b66d7efe;p=spider.git diff --git a/perl/client.pl b/perl/client.pl index 32271957..ff2ca473 100755 --- a/perl/client.pl +++ b/perl/client.pl @@ -1,4 +1,4 @@ -#!/usr/bin/perl +#!/usr/bin/perl -w # # A thing that implements dxcluster 'protocol' # @@ -26,6 +26,7 @@ # $Id$ # +require 5.004; # search local then perl directories BEGIN { @@ -40,21 +41,31 @@ BEGIN { use Msg; use DXVars; use DXDebug; +use DXUtil; +use Net::Telnet qw(TELOPT_ECHO TELOPT_BINARY); +use IO::File; use IO::Socket; use IPC::Open2; -use FileHandle; -use Carp; # cease communications sub cease { my $sendz = shift; - if ($conn && $sendz) { - $conn->send_now("Z$call|bye...\n"); +# if ($conn && $sendz) { +# $conn->send_now("Z$call|bye..."); +# sleep(1); +# } + $stdout->flush if $stdout; + if ($pid) { + dbg('connect', "killing $pid"); + kill(9, $pid); } - $stdout->flush; - kill(15, $pid) if $pid; + dbgclose(); +# $SIG{__WARN__} = sub {my $a = shift; cluck($a); }; sleep(1); + + # do we need this ? + $conn->disconnect if $conn; exit(0); } @@ -69,6 +80,7 @@ sub sig_chld { $SIG{CHLD} = \&sig_chld; $waitedpid = wait; + dbg('connect', "caught $pid"); } @@ -87,15 +99,17 @@ sub rec_socket { my ($con, $msg, $err) = @_; if (defined $err && $err) { - cease(1); + cease(0); } if (defined $msg) { - my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)\|(.*)$/; + my ($sort, $call, $line) = $msg =~ /^(\w)([^\|]+)\|(.*)$/; if ($sort eq 'D') { my $snl = $mynl; my $newsavenl = ""; $snl = "" if $mode == 0; + $snl = "\r\n" if $mode == 3; + $snl = "\n" if $mode == 2; if ($mode == 2 && $line =~ />$/) { $newsavenl = $snl; $snl = ' '; @@ -103,8 +117,10 @@ sub rec_socket $line =~ s/\n/\r/og if $mode == 1; #my $p = qq($line$snl); if ($buffered) { - if (length $outqueue >= 128) { + if (length $outqueue >= $client_buffer_lth) { print $stdout $outqueue; + pop @echo if @echo > $maxecho; + push @echo, $outqueue; $outqueue = ""; } $outqueue .= "$savenl$line$snl"; @@ -116,15 +132,36 @@ sub rec_socket } elsif ($sort eq 'M') { $mode = $line; # set new mode from cluster setmode(); + } elsif ($sort eq 'E') { + if ($sort eq 'telnet') { + $mode = $line; # set echo mode from cluster + my $term = POSIX::Termios->new; + $term->getattr(fileno($sock)); + $term->setiflag( 0 ); + $term->setoflag( 0 ); + $term->setattr(fileno($sock), &POSIX::TCSANOW ); + } + } elsif ($sort eq 'I') { + ; # ignore echoed I frames } elsif ($sort eq 'B') { if ($buffered && $outqueue) { print $stdout $outqueue; + pop @echo if @echo > $maxecho; + push @echo, $outqueue; $outqueue = ""; } $buffered = $line; # set buffered or unbuffered } elsif ($sort eq 'Z') { # end, disconnect, go, away ..... cease(0); - } + } + + # ****************************************************** + # ****************************************************** + # any other sorts that might happen are silently ignored. + # ****************************************************** + # ****************************************************** + } else { + cease(0); } $lasttime = time; } @@ -144,9 +181,13 @@ sub rec_stdin # $prbuf =~ s/\r/\\r/; # $prbuf =~ s/\n/\\n/; # print "sys: $r ($prbuf)\n"; - if ($r > 0) { + if (!defined $r || $r == 0) { + cease(1); + } elsif ($r > 0) { if ($mode) { - $buf =~ s/\r/\n/og if $mode == 1; + $buf =~ s/\r/\n/g if $mode == 1; + $buf =~ s/[\r\x00]//g if $mode == 2 || $mode == 3; + $dangle = !($buf =~ /\n$/); if ($buf eq "\n") { @lines = (" "); @@ -162,39 +203,48 @@ sub rec_stdin unshift @lines, ($lastbit . $first) if ($first); foreach $first (@lines) { # print "send_now $call $first\n"; - $conn->send_now("D$call|$first"); + next if grep {$_ eq $first } @echo; + $conn->send_later("I$call|$first"); } $lastbit = $buf; $savenl = ""; # reset savenl 'cos we will have done a newline on input } else { - $conn->send_now("D$call|$buf"); + $conn->send_later("I$call|$buf"); } - } elsif ($r == 0) { - cease(1); - } + } $lasttime = time; } +sub optioncb +{ +} + sub doconnect { my ($sort, $line) = @_; dbg('connect', "CONNECT sort: $sort command: $line"); if ($sort eq 'telnet') { # this is a straight network connect - my ($host) = $line =~ /host\s+(\w+)/o; - my ($port) = $line =~ /port\s+(\d+)/o; + my ($host, $port) = split /\s+/, $line; $port = 23 if !$port; - $sock = IO::Socket::INET->new(PeerAddr => "$host", PeerPort => "$port", Proto => 'tcp') - or die "Can't connect to $host port $port $!"; - - } elsif ($sort eq 'ax25') { + $sock = new Net::Telnet (Timeout => $timeout, Port => $port); + $sock->option_callback(\&optioncb); + $sock->output_record_separator(''); + $sock->option_accept(Dont => TELOPT_ECHO, Wont => TELOPT_ECHO); + $sock->open($host) or die "Can't connect to $host port $port $!"; + $sock->binmode(1); + $mode = 3; + } elsif ($sort eq 'ax25' || $sort eq 'prog') { my @args = split /\s+/, $line; - $rfh = new FileHandle; - $wfh = new FileHandle; + $rfh = new IO::File; + $wfh = new IO::File; $pid = open2($rfh, $wfh, "$line") or die "can't do $line $!"; + die "no receive channel $!" unless $rfh; + die "no transmit channel $!" unless $wfh; dbg('connect', "got pid $pid"); $wfh->autoflush(1); + $mode = 1; } else { die "invalid type of connection ($sort)"; } @@ -221,29 +271,43 @@ sub dochat dbg('connect', "CHAT \"$expect\" -> \"$send\""); my $line; - # alarm($timeout); + alarm($timeout); if ($expect) { - if ($csort eq 'telnet') { - $line = <$sock>; - chomp; - } elsif ($csort eq 'ax25') { - local $/ = "\r"; - $line = <$rfh>; - $line =~ s/\r//og; - } - dbg('connect', "received \"$line\""); - if ($abort && $line =~ /$abort/i) { - dbg('connect', "aborted on /$abort/"); - cease(11); + for (;;) { + if ($csort eq 'telnet') { + $line = $sock->get(); + cease(11) unless $line; # the socket has gone away? + if (length $line == 0) { + dbg('connect', "received 0 length line, aborting..."); + cease(11); + } + $line =~ s/\r//g; + chomp; + } elsif ($csort eq 'ax25' || $csort eq 'prog') { + local $/ = "\r"; + $line = <$rfh>; + if (length $line == 0) { + dbg('connect', "received 0 length line, aborting..."); + cease(11); + } + $line =~ s/\r/\n/g; + chomp; + } + dbg('connect', map { "received \"$_\"" } split /\n/, $line); + if ($abort && $line =~ /$abort/i) { + dbg('connect', "aborted on /$abort/"); + cease(11); + } + last if $line =~ /$expect/i; } } - if ($send && (!$expect || $line =~ /$expect/i)) { + if ($send) { if ($csort eq 'telnet') { $sock->print("$send\n"); } elsif ($csort eq 'ax25') { local $\ = "\r"; - $wfh->print("$send\r"); + $wfh->print("$send"); } dbg('connect', "sent \"$send\""); } @@ -252,9 +316,17 @@ sub dochat sub timeout { dbg('connect', "timed out after $timeout seconds"); - cease(10); + cease(0); } +# handle callsign and connection type firtling +sub doclient +{ + my $line = shift; + my @f = split /\s+/, $line; + $call = uc $f[0] if $f[0]; + $csort = $f[1] if $f[1]; +} # # initialisation @@ -262,17 +334,18 @@ sub timeout $mode = 2; # 1 - \n = \r as EOL, 2 - \n = \n, 0 - transparent $call = ""; # the callsign being used -@stdoutq = (); # the queue of stuff to send out to the user $conn = 0; # the connection object for the cluster $lastbit = ""; # the last bit of an incomplete input line $mynl = "\n"; # standard terminator $lasttime = time; # lasttime something happened on the interface -$outqueue = ""; # the output queue length +$outqueue = ""; # the output queue +$client_buffer_lth = 200; # how many characters are buffered up on outqueue $buffered = 1; # buffer output $savenl = ""; # an NL that has been saved from last time -$timeout = 30; # default timeout for connects +$timeout = 60; # default timeout for connects $abort = ""; # the current abort string $cpath = "$root/connect"; # the basic connect directory +$maxecho = 5; # length of max echo queue $pid = 0; # the pid of the child program $csort = ""; # the connection type @@ -283,17 +356,21 @@ $stdout = *STDOUT; $rfh = 0; $wfh = 0; +$waitedpid = 0; # # deal with args # -$call = uc shift @ARGV; -$call = uc $myalias if !$call; -$connsort = lc shift @ARGV; +$call = uc shift @ARGV if @ARGV; +$call = uc $myalias if !$call; +$connsort = lc shift @ARGV if @ARGV; $connsort = 'local' if !$connsort; -$mode = ($connsort =~ /^ax/o) ? 1 : 2; +$loginreq = $call eq 'LOGIN'; + +# we will do this again later 'cos things may have changed +$mode = ($connsort eq 'ax25') ? 1 : 2; setmode(); if ($call eq $mycall) { @@ -305,11 +382,51 @@ $stdout->autoflush(1); $SIG{'INT'} = \&sig_term; $SIG{'TERM'} = \&sig_term; -$SIG{'HUP'} = 'IGNORE'; +$SIG{'HUP'} = \&sig_term; $SIG{'CHLD'} = \&sig_chld; +$SIG{'ALRM'} = \&timeout; dbgadd('connect'); +# do we need to do a login and password job? +if ($loginreq) { + my $user; + my $s; + + $connsort = 'telnet' if $connsort eq 'local'; + setmode(); + + if (-e "$data/issue") { + open(I, "$data/issue") or die; + local $/ = undef; + $issue = ; + close(I); + $issue = s/\n/\r/og if $mode == 1; + local $/ = $nl; + $stdout->print($issue) if $issue; + } + + # allow a login from an existing user. I could create a user but + # I want to check for valid callsigns and I don't have the + # necessary info / regular expression yet + alarm($timeout); + + $stdout->print('login: '); + $stdout->flush(); + local $\ = $mynl; + $s = $stdin->getline(); + chomp $s; + $s =~ s/\s+//og; + $s =~ s/-\d+$//o; # no ssids! + cease(0) unless $s && $s gt ' '; + unless (iscallsign($s)) { + $stdout->print("Sorry, $s is an invalid callsign"); + cease(0); + } + $call = uc $s; + alarm(0); +} + # is this an out going connection? if ($connsort eq "connect") { my $mcall = lc $call; @@ -317,8 +434,8 @@ if ($connsort eq "connect") { open(IN, "$cpath/$mcall") or cease(2); @in = ; close IN; - - # alarm($timeout); + + alarm($timeout); for (@in) { chomp; @@ -327,20 +444,25 @@ if ($connsort eq "connect") { doconnect($1, $2) if /^\s*co\w*\s+(\w+)\s+(.*)$/io; doabort($1) if /^\s*a\w*\s+(.*)/io; dotimeout($1) if /^\s*t\w*\s+(\d+)/io; - dochat($1, $2) if /\s*\'(.*)\'\s+\'(.*)\'/io; + dochat($1, $2) if /^\s*\'(.*)\'\s+\'(.*)\'/io; + if (/^\s*cl\w+\s+(.*)/io) { + doclient($1); + last; + } } - dbg('connect', "Connected to $call, starting normal protocol"); + dbg('connect', "Connected to $call ($csort), starting normal protocol"); dbgsub('connect'); # if we get here we are connected - if ($csort eq 'ax25') { + if ($csort eq 'ax25' || $csort eq 'prog') { # open(STDIN, "<&R"); # open(STDOUT, ">&W"); # close R; # close W; $stdin = $rfh; $stdout = $wfh; + $csort = 'telnet' if $csort eq 'prog'; } elsif ($csort eq 'telnet') { # open(STDIN, "<&$sock"); # open(STDOUT, ">&$sock"); @@ -352,24 +474,36 @@ if ($connsort eq "connect") { $outbound = 1; $connsort = $csort; $stdout->autoflush(1); + $mode = ($connsort eq 'ax25') ? 1 : $mode; close STDIN; close STDOUT; close STDERR; - - - $mode = ($connsort =~ /^ax/o) ? 1 : 2; - setmode(); } setmode(); +# adjust the callsign if it has an SSID, SSID <= 8 are legal > 8 are netrom connections +$call =~ s/-0$//; # strip off -0 as this is equiv to just call on its own +my ($scall, $ssid) = split /-/, $call; +$ssid = undef unless $ssid && $ssid =~ /^\d+$/; +if ($ssid) { + $ssid = 15 if $ssid > 15; + if ($connsort eq 'ax25') { + if ($ssid > 8) { + $ssid = 15 - $ssid; + } + } + $call = "$scall-$ssid"; +} + + $conn = Msg->connect("$clusteraddr", $clusterport, \&rec_socket); if (! $conn) { if (-r "$data/offline") { open IN, "$data/offline" or die; while () { s/\n/\r/og if $mode == 1; - print $stdout; + print $stdout $_; } close IN; } else { @@ -384,7 +518,7 @@ Msg->set_event_handler($stdin, "read" => \&rec_stdin); for (;;) { my $t; - Msg->event_loop(1, 0.010); + Msg->event_loop(1, 1); $t = time; if ($t > $lasttime) { if ($outqueue) { @@ -395,3 +529,4 @@ for (;;) { } } +exit(0);