X-Git-Url: http://gb7djk.dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2Fclient.pl;h=66c7b0927337d88443097fb62b2c1daa1cc5dce9;hb=502f900651a46b96008028945616a3b610d6cc7a;hp=f7912ad791139d13532759e0971642d7f0ff768a;hpb=60c0ea1747bc8ad95e531d29025f7bcee4fd10c1;p=spider.git diff --git a/perl/client.pl b/perl/client.pl index f7912ad7..66c7b092 100755 --- a/perl/client.pl +++ b/perl/client.pl @@ -1,122 +1,529 @@ -#!/usr/bin/perl +#!/usr/bin/perl -w # # A thing that implements dxcluster 'protocol' # # This is a perl module/program that sits on the end of a dxcluster # 'protocol' connection and deals with anything that might come along. # -# this program is called by ax25d and gets raw ax25 text on its input +# this program is called by ax25d or inetd and gets raw ax25 text on its input +# It can also be launched into the ether by the cluster program itself for outgoing +# connections +# +# Calling syntax is:- +# +# client.pl [callsign] [telnet|ax25|local] [[connect] [program name and args ...]] +# +# if the callsign isn't given then the sysop callsign in DXVars.pm is assumed +# +# if there is no connection type then 'local' is assumed +# +# if there is a 'connect' keyword then it will try to launch the following program +# and any arguments and connect the stdin & stdout of both the program and the +# client together. # # Copyright (c) 1998 Dirk Koopman G1TLH # # $Id$ # +require 5.004; + +# search local then perl directories BEGIN { - unshift @INC, "/spider/local"; - unshift @INC, "/spider/perl"; + # root of directory tree for this system + $root = "/spider"; + $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'}; + + unshift @INC, "$root/perl"; # this IS the right way round! + unshift @INC, "$root/local"; } use Msg; use DXVars; - -$mode = 1; # 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 -$nl = "\r"; +use DXDebug; +use DXUtil; +use Net::Telnet qw(TELOPT_ECHO); +use IO::File; +use IO::Socket; +use IPC::Open2; # cease communications sub cease { - my $sendz = shift; - if (defined $conn && $sendz) { - $conn->send_now("Z$call|bye...\n"); - } - exit(0); + my $sendz = shift; +# if ($conn && $sendz) { +# $conn->send_now("Z$call|bye..."); +# sleep(1); +# } + $stdout->flush if $stdout; + if ($pid) { + dbg('connect', "killing $pid"); + kill(9, $pid); + } + dbgclose(); +# $SIG{__WARN__} = sub {my $a = shift; cluck($a); }; + sleep(1); + + # do we need this ? + $conn->disconnect if $conn; + exit(0); } # terminate program from signal sub sig_term { - cease(1); + cease(1); +} + +# terminate a child +sub sig_chld +{ + $SIG{CHLD} = \&sig_chld; + $waitedpid = wait; + dbg('connect', "caught $pid"); +} + + +sub setmode +{ + if ($mode == 1) { + $mynl = "\r"; + } else { + $mynl = "\n"; + } + $/ = $mynl; } # handle incoming messages sub rec_socket { - my ($con, $msg, $err) = @_; - if (defined $err && $err) { - cease(1); - } - if (defined $msg) { - my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)|(.*)$/; - - if ($sort eq 'D') { - $nl = "" if $mode == 0; - $line =~ s/\n/\r/o if $mode == 1; - print $line, $nl; - } elsif ($sort eq 'M') { - $mode = $line; # set new mode from cluster - } elsif ($sort eq 'Z') { # end, disconnect, go, away ..... - cease(0); - } - } + my ($con, $msg, $err) = @_; + if (defined $err && $err) { + cease(0); + } + if (defined $msg) { + my ($sort, $call, $line) = $msg =~ /^(\w)([^\|]+)\|(.*)$/; + + if ($sort eq 'D') { + my $snl = $mynl; + my $newsavenl = ""; + $snl = "" if $mode == 0; + $snl = "\r\n" if $mode == 2; + if ($mode == 2 && $line =~ />$/) { + $newsavenl = $snl; + $snl = ' '; + } + $line =~ s/\n/\r/og if $mode == 1; + #my $p = qq($line$snl); + if ($buffered) { + if (length $outqueue >= $client_buffer_lth) { + print $stdout $outqueue; + $outqueue = ""; + } + $outqueue .= "$savenl$line$snl"; + $lasttime = time; + } else { + print $stdout $savenl, $line, $snl;; + } + $savenl = $newsavenl; + } 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; + $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; } sub rec_stdin { - my ($fh) = @_; - my $buf; - my @lines; - my $r; - my $first; - my $dangle = 0; - - $r = sysread($fh, $buf, 1024); -# print "sys: $r $buf"; - if ($r > 0) { - if ($mode) { - $buf =~ s/\r/\n/o if $mode == 1; - $dangle = !($buf =~ /\n$/); - @lines = split /\n/, $buf; - if ($dangle) { # pull off any dangly bits - $buf = pop @lines; - } else { - $buf = ""; - } - $first = shift @lines; - unshift @lines, ($lastbit . $first) if ($first); - foreach $first (@lines) { - $conn->send_now("D$call|$first"); - } - $lastbit = $buf; + my ($fh) = @_; + my $buf; + my @lines; + my $r; + my $first; + my $dangle = 0; + + $r = sysread($fh, $buf, 1024); + # my $prbuf; + # $prbuf = $buf; + # $prbuf =~ s/\r/\\r/; + # $prbuf =~ s/\n/\\n/; + # print "sys: $r ($prbuf)\n"; + if (!defined $r || $r == 0) { + cease(1); + } elsif ($r > 0) { + if ($mode) { + $buf =~ s/\r/\n/g if $mode == 1; + $buf =~ s/[\r\x00]//g if $mode == 2; + + $dangle = !($buf =~ /\n$/); + if ($buf eq "\n") { + @lines = (" "); + } else { + @lines = split /\n/, $buf; + } + if ($dangle) { # pull off any dangly bits + $buf = pop @lines; + } else { + $buf = ""; + } + $first = shift @lines; + unshift @lines, ($lastbit . $first) if ($first); + foreach $first (@lines) { + # print "send_now $call $first\n"; + $conn->send_later("I$call|$first"); + } + $lastbit = $buf; + $savenl = ""; # reset savenl 'cos we will have done a newline on input + } else { + $conn->send_later("I$call|$buf"); + } + } + $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, $port) = split /\s+/, $line; + $port = 23 if !$port; + +# if ($port == 23) { + + $sock = new Net::Telnet (Timeout => $timeout, Port => $port); + $sock->option_callback(\&optioncb); + $sock->output_record_separator(''); +# $sock->option_log('option_log'); +# $sock->dump_log('dump'); + $sock->option_accept(Dont => TELOPT_ECHO, Wont => TELOPT_ECHO); + $sock->open($host) or die "Can't connect to $host port $port $!"; +# } else { +# $sock = IO::Socket::INET->new(PeerAddr => "$host:$port", Proto => 'tcp') +# or die "Can't connect to $host port $port $!"; +# } + } elsif ($sort eq 'ax25' || $sort eq 'prog') { + my @args = split /\s+/, $line; + $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); } else { - $conn->send_now("D$call|$buf"); + die "invalid type of connection ($sort)"; } - } elsif ($r == 0) { - cease(1); - } + $csort = $sort; +} + +sub doabort +{ + my $string = shift; + dbg('connect', "abort $string"); + $abort = $string; } -$call = uc $ARGV[0]; -die "client.pl []\r\n" if (!$call); -$mode = $ARGV[1] if (@ARGV > 1); +sub dotimeout +{ + my $val = shift; + dbg('connect', "timeout set to $val"); + $timeout = $val; +} -if ($mode != 1) { - $nl = "\n"; - $\ = $nl; +sub dochat +{ + my ($expect, $send) = @_; + dbg('connect', "CHAT \"$expect\" -> \"$send\""); + my $line; + + alarm($timeout); + + if ($expect) { + 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', "received \"$line\""); + if ($abort && $line =~ /$abort/i) { + dbg('connect', "aborted on /$abort/"); + cease(11); + } + last if $line =~ /$expect/i; + } + } + if ($send) { + if ($csort eq 'telnet') { + $sock->print("$send\n"); + } elsif ($csort eq 'ax25') { + local $\ = "\r"; + $wfh->print("$send"); + } + dbg('connect', "sent \"$send\""); + } } -select STDOUT; $| = 1; +sub timeout +{ + dbg('connect', "timed out after $timeout seconds"); + 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 +# + +$mode = 2; # 1 - \n = \r as EOL, 2 - \n = \n, 0 - transparent +$call = ""; # the callsign being used +$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 +$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 = 60; # default timeout for connects +$abort = ""; # the current abort string +$cpath = "$root/connect"; # the basic connect directory + +$pid = 0; # the pid of the child program +$csort = ""; # the connection type +$sock = 0; # connection socket + +$stdin = *STDIN; +$stdout = *STDOUT; +$rfh = 0; +$wfh = 0; + +$waitedpid = 0; + +# +# deal with args +# + +$call = uc shift @ARGV if @ARGV; +$call = uc $myalias if !$call; +$connsort = lc shift @ARGV if @ARGV; +$connsort = 'local' if !$connsort; + +$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) { + print $stdout "You cannot connect as your cluster callsign ($mycall)", $nl; + cease(0); +} + +$stdout->autoflush(1); $SIG{'INT'} = \&sig_term; $SIG{'TERM'} = \&sig_term; -#$SIG{'HUP'} = \&sig_term; +$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; + + open(IN, "$cpath/$mcall") or cease(2); + @in = ; + close IN; + + alarm($timeout); + + for (@in) { + chomp; + next if /^\s*\#/o; + next if /^\s*$/o; + 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; + if (/^\s*cl\w+\s+(.*)/io) { + doclient($1); + last; + } + } + + dbg('connect', "Connected to $call ($csort), starting normal protocol"); + dbgsub('connect'); + + # if we get here we are connected + 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"); + # close $sock; + $stdin = $sock; + $stdout = $sock; + } + alarm(0); + $outbound = 1; + $connsort = $csort; + $stdout->autoflush(1); + close STDIN; + close STDOUT; + close STDERR; +} + +$mode = ($connsort eq 'ax25') ? 1 : 2; +setmode(); + +# adjust the callsign if it has an SSID, SSID <= 8 are legal > 8 are netrom connections +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); -$conn->send_now("A$call|start"); -Msg->set_event_handler(\*STDIN, "read" => \&rec_stdin); -Msg->event_loop(); +if (! $conn) { + if (-r "$data/offline") { + open IN, "$data/offline" or die; + while () { + s/\n/\r/og if $mode == 1; + print $stdout $_; + } + close IN; + } else { + print $stdout "Sorry, the cluster $mycall is currently off-line", $mynl; + } + cease(0); +} + +$let = $outbound ? 'O' : 'A'; +$conn->send_now("$let$call|$connsort"); +Msg->set_event_handler($stdin, "read" => \&rec_stdin); + +for (;;) { + my $t; + Msg->event_loop(1, 1); + $t = time; + if ($t > $lasttime) { + if ($outqueue) { + print $stdout $outqueue; + $outqueue = ""; + } + $lasttime = $t; + } +} +exit(0);