# chat.pl: chat with a server
# Based on: V2.01.alpha.7 91/06/16
# Randal L. Schwartz (was <[email protected]>)
# multihome additions by [email protected]
# allow for /dev/pts based systems by Joe Doupnik <[email protected]>
# $Id: chat2.pl,v 2.1 1993/06/28 15:11:07 lmjm Exp lmjm $
# $Log: chat2.pl,v $
# Revision 2.1  1993/06/28  15:11:07  lmjm
# Full 2.1 release
#
# Changed for use with log_procedures, ES, 96/01/05

package chat;

use Socket;

$pf_inet = &PF_INET;
$sock_stream = &SOCK_STREAM;
local($name, $aliases, $proto) = getprotobyname( 'tcp' );
$tcp_proto = $proto;

$sockaddr = 'S n a4 x8';
chop($thishost = `hostname`);

# *S = symbol for current I/O, gets assigned *chatsymbol....
$next = "chatsymbol000000"; # next one
$nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++

## $handle = &chat'open_port("server.address",$port_number);
## opens a named or numbered TCP server

sub open_port { ## public
       local($server, $port) = @_;

       local($serveraddr,$serverproc);

       # We may be multi-homed, start with 0, fixup once connexion is made
       $thisaddr = "\0\0\0\0" ;
       $thisproc = pack($sockaddr, 2, 0, $thisaddr);
       *S = ++$next;
       if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) {
               $serveraddr = pack('C4', $1, $2, $3, $4);
       } else {
               local(@x) = gethostbyname($server);
               return undef unless @x;
               $serveraddr = $x[4];
       }
       $serverproc = pack($sockaddr, 2, $port, $serveraddr);
       unless (socket(S, $pf_inet, $sock_stream, $tcp_proto)) {
               ($!) = ($!, close(S)); # close S while saving $!
               return undef;
       }
       unless (bind(S, $thisproc)) {
               ($!) = ($!, close(S)); # close S while saving $!
               return undef;
       }
       unless (connect(S, $serverproc)) {
               ($!) = ($!, close(S)); # close S while saving $!
               return undef;
       }
# We opened with the local address set to ANY, at this stage we know
# which interface we are using.  This is critical if our machine is
# multi-homed, with IP forwarding off, so fix-up.
       local($fam,$lport);
       ($fam,$lport,$thisaddr) = unpack($sockaddr, getsockname(S));
       $thisproc = pack($sockaddr, 2, 0, $thisaddr);
       $pthisaddr=join(".", unpack('C4',$thisaddr));
# end of post-connect fixup
       select((select(S), $| = 1)[0]);
       $next; # return symbol for switcharound
}

## ($host, $port, $handle) = &chat'open_listen([$port_number]);
## opens a TCP port on the current machine, ready to be listened to
## if $port_number is absent or zero, pick a default port number
## process must be uid 0 to listen to a low port number

sub open_listen { ## public

       *S = ++$next;
       local($thisport) = shift || 0;
       local($thisproc_local) = pack($sockaddr, 2, $thisport, $thisaddr);
       local(*NS) = "__" . time;
       unless (socket(NS, $pf_inet, $sock_stream, $tcp_proto)) {
               ($!) = ($!, close(NS));
               return undef;
       }
       unless (bind(NS, $thisproc_local)) {
               ($!) = ($!, close(NS));
               return undef;
       }
       unless (listen(NS, 1)) {
               ($!) = ($!, close(NS));
               return undef;
       }
       select((select(NS), $| = 1)[0]);
       local($family, $port, @myaddr) =
               unpack("S n C C C C x8", getsockname(NS));
       $S{"needs_accept"} = *NS; # so expect will open it
       (@myaddr, $port, $next); # returning this
}

## $handle = &chat'open_proc("command","arg1","arg2",...);
## opens a /bin/sh on a pseudo-tty

sub open_proc { ## public
       local(@cmd) = @_;

       *S = ++$next;
       local(*TTY) = "__TTY" . time;
       local($pty,$tty) = &_getpty(S,TTY);
       die "Cannot find a new pty" unless defined $pty;
       $pid = fork;
       die "Cannot fork: $!" unless defined $pid;
       unless ($pid) {
               close STDIN; close STDOUT; close STDERR;
               setpgrp(0,$$);
               if (open(DEVTTY, "/dev/tty")) {
                   ioctl(DEVTTY,0x20007471,0);         # XXX s/b &TIOCNOTTY
                   close DEVTTY;
               }
               open(STDIN,"<&TTY");
               open(STDOUT,">&TTY");
               open(STDERR,">&STDOUT");
               die "Oops" unless fileno(STDERR) == 2;  # sanity
               close(S);
               exec @cmd;
               die "Cannot exec @cmd: $!";
       }
       close(TTY);
       $next; # return symbol for switcharound
}

# &chat'read([$handle,] $buf, $ntoread )
# blocking read. returns no. of bytes read and puts data in $buf.
# If called with ntoread < 0 then just do the accept and return 0.
sub read { ## public
       if ($_[0] =~ /$nextpat/) {
               *S = shift;
       }
       *chatreadbuf = shift;
       $chatreadn = shift;

       if (defined $S{"needs_accept"}) { # is it a listen socket?
               local(*NS) = $S{"needs_accept"};
               delete $S{"needs_accept"};
               $S{"needs_close"} = *NS;
               unless(accept(S,NS)) {
                       ($!) = ($!, close(S), close(NS));
                       return undef;
               }
               select((select(S), $| = 1)[0]);
       }
       if( $chatreadn > 0 ){
               return sysread(S, $chatreadbuf, $chatreadn );
       }
}

# $S is the read-ahead buffer

## $return = &chat'expect([$handle,] $timeout_time,
##      $pat1, $body1, $pat2, $body2, ... )
## $handle is from previous &chat'open_*().
## $timeout_time is the time (either relative to the current time, or
## absolute, ala time(2)) at which a timeout event occurs.
## $pat1, $pat2, and so on are regexs which are matched against the input
## stream.  If a match is found, the entire matched string is consumed,
## and the corresponding body eval string is evaled.
##
## Each pat is a regular-expression (probably enclosed in single-quotes
## in the invocation).  ^ and $ will work, respecting the current value of $*.
## If pat is 'TIMEOUT', the body is executed if the timeout is exceeded.
## If pat is 'EOF', the body is executed if the process exits before
## the other patterns are seen.
##
## Pats are scanned in the order given, so later pats can contain
## general defaults that won't be examined unless the earlier pats
## have failed.
##
## The result of eval'ing body is returned as the result of
## the invocation.  Recursive invocations are not thought
## through, and may work only accidentally. :-)
##
## undef is returned if either a timeout or an eof occurs and no
## corresponding body has been defined.
## I/O errors of any sort are treated as eof.

$nextsubname = "expectloop000000"; # used for subroutines

sub expect { ## public
       if ($_[0] =~ /$nextpat/) {
               *S = shift;
       }
       local($endtime) = shift;

       local($timeout,$eof) = (1,1);
       local($caller) = caller;
       local($rmask, $nfound, $timeleft, $thisbuf);
       local($cases, $pattern, $action, $subname);
       $endtime += time if $endtime < 600_000_000;

       if (defined $S{"needs_accept"}) { # is it a listen socket?
               local(*NS) = $S{"needs_accept"};
               delete $S{"needs_accept"};
               $S{"needs_close"} = *NS;
               unless(accept(S,NS)) {
                       ($!) = ($!, close(S), close(NS));
                       return undef;
               }
               select((select(S), $| = 1)[0]);
       }

       # now see whether we need to create a new sub:

       unless ($subname = $expect_subname{$caller,@_}) {
               # nope.  make a new one:
               $expect_subname{$caller,@_} = $subname = $nextsubname++;

               $cases .= <<"EDQ"; # header is funny to make everything elsif's
sub $subname {
       LOOP: {
               if (0) { ; }
EDQ
               while (@_) {
                       ($pattern,$action) = splice(@_,0,2);
                       if ($pattern =~ /^eof$/i) {
                               $cases .= <<"EDQ";
               elsif (\$eof) {
                       package $caller;
                       $action;
               }
EDQ
                               $eof = 0;
                       } elsif ($pattern =~ /^timeout$/i) {
                       $cases .= <<"EDQ";
               elsif (\$timeout) {
                       package $caller;
                       $action;
               }
EDQ
                               $timeout = 0;
                       } else {
                               $pattern =~ s#/#\\/#g;
                       $cases .= <<"EDQ";
               elsif (\$S =~ /$pattern/) {
                       \$main'charbuf=\$S;
                       \$S = \$';
                       $action;
               }
EDQ
                       }
               }
               $cases .= <<"EDQ" if $eof;
               elsif (\$eof) {
                       undef;
               }
EDQ
               $cases .= <<"EDQ" if $timeout;
               elsif (\$timeout) {
                       undef;
               }
EDQ
               $cases .= <<'ESQ';
               else {
                       $rmask = "";
                       vec($rmask,fileno(S),1) = 1;
                       ($nfound, $rmask) =
                               select($rmask, undef, undef, $endtime - time);
                       if ($nfound) {
                               $nread = sysread(S, $thisbuf, 1024);
                               if( $chat'debug ){
                                       print STDERR "sysread $nread ";
                                       print STDERR ">>$thisbuf<<\n";
                               }
# ES changes start
                               if( $chat'log_user ){
                                       print STDOUT "$thisbuf";
                               }
                               if( $chat'do_logfile && ($chat'log_user || $chat'global_logging)){
                                       print LOGFILE "$thisbuf";
                               }
                               if( $chat'log_to_stack ){
                                       push(@chat'log_array,$thisbuf);
                               }
# ES changes end
                               if ($nread > 0) {
                                       $S .= $thisbuf;
                               } else {
                                       $eof++, redo LOOP; # any error is also eof
                               }
                       } else {
                               $timeout++, redo LOOP; # timeout
                       }
                       redo LOOP;
               }
       }
}
ESQ
               eval $cases; die "$cases:\n$@" if $@;
       }
       $eof = $timeout = 0;
       do $subname();
}

# ES changes start

sub _transform_array {
# changes every \r to \n in the input array
local (@To) = @_;
local(@New,$var);
@New = ();
foreach $var (@To) {
 $_ = $var;
 s/\r/\n/g;
 push (@New,$_);
};
return(@New);
};

# ES changes end


## &chat'print([$handle,] @data)
## $handle is from previous &chat'open().
## like print $handle @data

sub print { ## public
       if ($_[0] =~ /$nextpat/) {
               *S = shift;
       }
# ES changes start
       @print_var = @_;
       print S @print_var;
       if( $chat'log_to_stack ){
               push(@chat'log_array,@print_var);
       }
       @print_var = &_transform_array(@print_var);
       if( $chat'debug ){
               print STDERR "printed:";
               print STDERR @print_var;
       }
       if( $chat'log_user ){
               print STDOUT @print_var;
       }
       if( $chat'do_logfile && ($chat'log_user || $chat'global_logging)){
               print LOGFILE @print_var;
       }
# ES changes end
}

## &chat'close([$handle,])
## $handle is from previous &chat'open().
## like close $handle

sub close { ## public
       if ($_[0] =~ /$nextpat/) {
               *S = shift;
       }
       close(S);
       if (defined $S{"needs_close"}) { # is it a listen socket?
               local(*NS) = $S{"needs_close"};
               delete $S{"needs_close"};
               close(NS);
       }
}

## @ready_handles = &chat'select($timeout, @handles)
## select()'s the handles with a timeout value of $timeout seconds.
## Returns an array of handles that are ready for I/O.
## Both user handles and chat handles are supported (but beware of
## stdio's buffering for user handles).

sub select { ## public
       local($timeout) = shift;
       local(@handles) = @_;
       local(%handlename) = ();
       local(%ready) = ();
       local($caller) = caller;
       local($rmask) = "";
       for (@handles) {
               if (/$nextpat/o) { # one of ours... see if ready
                       local(*SYM) = $_;
                       if (length($SYM)) {
                               $timeout = 0; # we have a winner
                               $ready{$_}++;
                       }
                       $handlename{fileno($_)} = $_;
               } else {
                       $handlename{fileno(/'/ ? $_ : "$caller\'$_")} = $_;
               }
       }
       for (sort keys %handlename) {
               vec($rmask, $_, 1) = 1;
       }
       select($rmask, undef, undef, $timeout);
       for (sort keys %handlename) {
               $ready{$handlename{$_}}++ if vec($rmask,$_,1);
       }
       sort keys %ready;
}

# ($pty,$tty) = $chat'_getpty(PTY,TTY):
# internal procedure to get the next available pty.
# opens pty on handle PTY, and matching tty on handle TTY.
# returns undef if can't find a pty.
# Modify "/dev/pty" to "/dev/pts" for Dell Unix v2.2 (aka SVR4.04). Joe Doupnik.

sub _getpty { ## private
       local($_PTY,$_TTY) = @_;
       $_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
       $_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
       local($pty, $tty, $kind);
       if( -e "/dev/pts000" ){         ## mods by Joe Doupnik Dec 1992
               $kind = "pts";          ## SVR4 Streams
       } else {
               $kind = "pty";          ## BSD Clist stuff
       }
       for $bank (112..127) {
               next unless -e sprintf("/dev/$kind%c0", $bank);
               for $unit (48..57) {
                       $pty = sprintf("/dev/$kind%c%c", $bank, $unit);
                       open($_PTY,"+>$pty") || next;
                       select((select($_PTY), $| = 1)[0]);
                       ($tty = $pty) =~ s/pty/tty/;
                       open($_TTY,"+>$tty") || next;
                       select((select($_TTY), $| = 1)[0]);
                       system "stty nl>$tty";
                       return ($pty,$tty);
               }
       }
       undef;
}

# ES changes start
$log_user = 1;
$global_logging = 0;
$do_logfile = 0;
$log_to_stack = 0;
@log_array = ();

# &log_screen(NEWVAL)
# sets $chat'log_user to NEWVAL

sub log_screen {
       ($log_user) = @_;
}

sub log_file {
# log_file() means stop logging into the logfile
# log_file($filename) means appending to the file
# anything written to the screen by the chat package
# log_file("-a $filename") means appending to the file anything
# without regarding the settings of log_screen

       local($invocation_string) = @_;
       if ($invocation_string eq "") {
# log_file without an argument means stop logging;
         $do_logfile = 0;
         close(LOGFILE) if $do_logfile;
         exit;
       };
       if ($invocation_string =~ /^-a (.*)/) {
               $logfilename = $1;
               $global_logging = 1;
       } else {
               $logfilename = $invocation_string;
               $global_logging = 0;
       };
       open (LOGFILE, ">>$logfilename");
       $do_logfile = 1;
};

sub log_stack_on {
# log_stack_on will push anything that is read and written to the argument
# use it like &chat'log_stack_on(*my_stack) to push data on the
# @my_stack variable of the calling routine.
# Only one log_stack_on command can be done properly at a time.
 local(*stackarray) = @_;
 @log_array = @stackarray;
 $log_to_stack = 1;
};

sub log_stack_off {
# log_stack_off will stop logging to the argument and will return the
# collected values.
# Use it like &chat'log_stack_off(*my_stack).
# Your variable will be filled after the call of this routine.
 local(*stackarray) = @_;
 @stackarray = @log_array;
 $log_to_stack = 0;
};

1;

You are viewing proxied material from ftp.icm.edu.pl. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.