-#!/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 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 {
- # 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 IntMsg;
-use DXVars;
-use DXDebug;
-use DXUtil;
-use Net::Telnet qw(TELOPT_ECHO TELOPT_BINARY);
-use IO::File;
-use IO::Socket;
-use IPC::Open2;
-
-# cease communications
-sub cease
-{
- 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);
-}
-
-# terminate a child
-sub sig_chld
-{
- unless ($^O =~ /^MS/i) {
- $SIG{CHLD} = \&sig_chld;
- $waitedpid = wait;
- dbg('connect', "caught $waitedpid");
- }
-}
-
-
-sub setmode
-{
- if ($mode == 1) {
- $mynl = "\r";
- $out_lineend = "\r";
- } else {
- $mynl = "\n";
- $out_lineend = "\r\n";
- }
- $/ = $mynl;
- $out_lineend = $mynl;
-}
-
-# handle incoming messages
-sub rec_socket
-{
- 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 == 3;
- $snl = "\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;
- pop @echo while (@echo > $maxecho);
- push @echo, $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;
- pop @echo while(@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;
-}
-
-sub rec_stdin
-{
- 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 || $mode == 3;
-
- $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";
- 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_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;
-
- $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 $!";
- if ($port == 23) {
- $sock->telnetmode(1);
- $sock->option_send(Dont => TELOPT_ECHO, Wont => TELOPT_ECHO) if $port == 23;
- } else {
- $sock->telnetmode(0);
- }
- $sock->binmode(0);
- $mode = 3;
- } 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);
- $mode = 1;
- } else {
- 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 dolineend
-{
- my $val = shift;
- $out_lineend = $val;
- $out_lineend =~ s/\\r/\r/g;
- $out_lineend =~ s/\\n/\n/g;
- dbg('connect', "lineend set to $val ");
- $out_lineend = $mynl unless $out_lineend;
-}
-
-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', map { "received \"$_\"" } split /\n/, $line);
- if ($abort && $line =~ /$abort/i) {
- dbg('connect', "aborted on /$abort/");
- cease(11);
- }
- last if $line =~ /$expect/i;
- }
- }
- if ($send) {
- if ($csort eq 'telnet') {
-# local $\ = $out_lineend;
- $sock->print("$send\n");
- } elsif ($csort eq 'ax25') {
- local $\ = $out_lineend;
- $wfh->print("$send");
- }
- dbg('connect', "sent \"$send\"");
- }
-}
-
-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
-$maxecho = 5; # length of max echo queue
-
-$pid = 0; # the pid of the child program
-$csort = ""; # the connection type
-$sock = 0; # connection socket
-$out_lineend = $mynl; # connection lineending (used for outgoing connects)
-
-$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);
-
-unless ($^O =~ /^MS/i) {
- $SIG{'INT'} = \&sig_term;
- $SIG{'TERM'} = \&sig_term;
- $SIG{'HUP'} = \&sig_term;
- $SIG{'CHLD'} = \&sig_chld;
-}
-
-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 = <I>;
- 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 (is_callsign($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 = <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;
- dolineend($1) if /^\s*[Ll]\w*\s+\'((?:\\[rn])+)\'/;
- 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);
- $mode = ($connsort eq 'ax25') ? 1 : $mode;
- close STDIN;
- close STDOUT;
- close STDERR;
-}
-
-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 = IntMsg->connect("$clusteraddr", $clusterport, \&rec_socket);
-if (! $conn) {
- if (-r "$data/offline") {
- open IN, "$data/offline" or die;
- while (<IN>) {
- 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.1);
- $t = time;
- if ($t > $lasttime) {
- if ($outqueue) {
- print $stdout $outqueue;
- $outqueue = "";
- }
- $lasttime = $t;
- }
-}
-
-exit(0);
projects / spider.git / commitdiff