X-Git-Url: http://www.dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2Fclient.pl;h=c39bda4c0fbde42c8b1e3890a85773e22be5c960;hb=97d5445b1e468d9228367640421b2f90ac021224;hp=2a41c221320fbef8120d2af0598a69f6da5be6be;hpb=78ed3f6025103ec1c47c90725e37b417647d83c8;p=spider.git diff --git a/perl/client.pl b/perl/client.pl index 2a41c221..c39bda4c 100755 --- a/perl/client.pl +++ b/perl/client.pl @@ -26,189 +26,472 @@ # $Id$ # +require 5.004; # search local then perl directories BEGIN { - # 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"; + # 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 = 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 -$buffered = 1; # buffer output -$savenl = ""; # an NL that has been saved from last time +use DXDebug; +use DXUser; +use IO::File; +use IO::Socket; +use IPC::Open2; +use Net::Telnet qw(TELOPT_ECHO); +use Carp; # 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...\n"); + } + $stdout->flush if $stdout; + if ($pid) { + dbg('connect', "killing $pid"); + kill(9, $pid); + } + sleep(1); + 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; + $SIG{CHLD} = \&sig_chld; + $waitedpid = wait; + dbg('connect', "caught $pid"); } sub setmode { - if ($mode == 1) { - $mynl = "\r"; - } else { - $mynl = "\n"; - } - $/ = $mynl; + 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') { - my $snl = $mynl; - my $newsavenl = ""; - $snl = "" if $mode == 0; - if ($mode && $line =~ />$/) { - $newsavenl = $snl; - $snl = ' '; - } - $line =~ s/\n/\r/og if $mode == 1; - #my $p = qq($line$snl); - if ($buffered) { - if (length $outqueue >= 128) { - print $outqueue; - $outqueue = ""; - } - $outqueue .= "$savenl$line$snl"; - $lasttime = time; - } else { - print $savenl, $line, $snl;; - } - $savenl = $newsavenl; - } elsif ($sort eq 'M') { - $mode = $line; # set new mode from cluster - setmode(); - } elsif ($sort eq 'B') { - if ($buffered && $outqueue) { - print $outqueue; - $outqueue = ""; - } - $buffered = $line; # set buffered or unbuffered - } elsif ($sort eq 'Z') { # end, disconnect, go, away ..... - cease(0); - } - } - $lasttime = time; + my ($con, $msg, $err) = @_; + if (defined $err && $err) { + cease(1); + } + if (defined $msg) { + my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)\|(.*)$/; + + if ($sort eq 'D') { + my $snl = $mynl; + my $newsavenl = ""; + $snl = "" if $mode == 0; + 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 >= 128) { + 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->setflag( &POSIX::ISIG ); + $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); + } + } + $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/og 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; - $savenl = ""; # reset savenl 'cos we will have done a newline on input + 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 ($r > 0) { + if ($mode) { + $buf =~ s/\r/\n/og if $mode == 1; + $buf =~ s/\r\n/\n/og 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"); + } + } 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, $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(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 $!"; + dbg('connect', "got pid $pid"); + $wfh->autoflush(1); } else { - $conn->send_now("D$call|$buf"); + die "invalid type of connection ($sort)"; + } + $csort = $sort; +} + +sub doabort +{ + my $string = shift; + dbg('connect', "abort $string"); + $abort = $string; +} + +sub dotimeout +{ + my $val = shift; + dbg('connect', "timeout set to $val"); + $timeout = $val; +} + +sub dochat +{ + my ($expect, $send) = @_; + dbg('connect', "CHAT \"$expect\" -> \"$send\""); + my $line; + + alarm($timeout); + + if ($expect) { + for (;;) { + if ($csort eq 'telnet') { + $line = $sock->get(); + $line =~ s/\r\n/\n/og; + chomp; + } elsif ($csort eq 'ax25' || $csort eq 'prog') { + local $/ = "\r"; + $line = <$rfh>; + $line =~ s/\r//og; + } + 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\""); } - } elsif ($r == 0) { - cease(1); - } - $lasttime = time; } +sub timeout +{ + dbg('connect', "timed out after $timeout seconds"); + cease(0); +} + + +# +# initialisation +# + +$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 +$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; + + +# +# deal with args +# + $call = uc shift @ARGV; -$call = uc $myalias if !$call; +$call = uc $myalias if !$call; $connsort = lc shift @ARGV; $connsort = 'local' if !$connsort; -$mode = ($connsort =~ /^ax/o) ? 1 : 2; -# is this an out going connection? -if ($ARGV[0] eq "connect") { - shift @ARGV; # lose the keyword - -} +$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 "You cannot connect as your cluster callsign ($mycall)", $nl; - cease(0); + print $stdout "You cannot connect as your cluster callsign ($mycall)", $nl; + cease(0); } -#select STDOUT; $| = 1; -STDOUT->autoflush(1); +$stdout->autoflush(1); $SIG{'INT'} = \&sig_term; $SIG{'TERM'} = \&sig_term; -$SIG{'HUP'} = \&sig_term; +$SIG{'HUP'} = 'IGNORE'; $SIG{'CHLD'} = \&sig_chld; +dbgadd('connect'); + +# do we need to do a login and password job? +if ($loginreq) { + my $user; + my $s; + + 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; + } + + + DXUser->init($userfn); + + # 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 + for ($state = 0; $state < 2; ) { + alarm($timeout); + + if ($state == 0) { + $stdout->print('login: '); + $stdout->flush(); + local $\ = $nl; + $s = $stdin->getline(); + chomp $s; + $s =~ s/\s+//og; + $s =~ s/-\d+$//o; # no ssids! + cease(0) unless $s gt ' '; + $call = uc $s; + $user = DXUser->get($call); + $state = 1; + } elsif ($state == 1) { + $stdout->print('password: '); + $stdout->flush(); + local $\ = $nl; + $s = $stdin->getline(); + chomp $s; + $state = 2; + if (!$user || ($user->passwd && $user->passwd ne $s)) { + $stdout->print("sorry...$nl"); + 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]; +} + +# 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 $sort 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(); + $conn = Msg->connect("$clusteraddr", $clusterport, \&rec_socket); -$conn->send_now("A$call|$connsort"); -Msg->set_event_handler(\*STDIN, "read" => \&rec_stdin); +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, 0.010); - $t = time; - if ($t > $lasttime) { - if ($outqueue) { - print $outqueue; - $outqueue = ""; + my $t; + Msg->event_loop(1, 0.010); + $t = time; + if ($t > $lasttime) { + if ($outqueue) { + print $stdout $outqueue; + $outqueue = ""; + } + $lasttime = $t; } - $lasttime = $t; - } } +exit(0);