# This is little chat. It is based on the chat2 that I did for mirror

# This is little chat. It is based on the chat2 that I did for mirror
# which in turn was based on the Randal Schwartz version.
# This version can only have one outgoing open at a time. This
# avoids returning string filehandles which were a source of memory leaks.
#
# 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.3 1994/02/03 13:45:35 lmjm Exp lmjm $
# $Log: chat2.pl,v $
# Revision 2.3 1994/02/03 13:45:35 lmjm
# Correct chat'read ([email protected])
#
# Revision 2.2 1993/12/14 11:09:03 lmjm
# Only include sys/socket.ph if not already there.
# Allow for system 5.
#
# Revision 2.1 1993/06/28 15:11:07 lmjm
# Full 2.1 release
#

package chat;

unless( defined &'PF_INET ){
eval "sub ATT { 0; } sub INTEL { 0; }";
do 'sys/socket.ph';
}

if( defined( &main'PF_INET ) ){
$pf_inet = &main'PF_INET;
$sock_stream = &main'SOCK_STREAM;
local($name, $aliases, $proto) = getprotobyname( 'tcp' );
$tcp_proto = $proto;
}
else {
# XXX hardwired $PF_INET, $SOCK_STREAM, 'tcp'
# but who the heck would change these anyway? (:-)
$pf_inet = 2;
$sock_stream = 1;
$tcp_proto = 6;
}

$sockaddr = 'S n a4 x8';
chop( $thishost = `(hostname || uname -n || uuname -l) 2>/dev/null` );

## &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);

if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) {
$serveraddr = pack('C4', $1, $2, $3, $4);
} else {
local(@x) = gethostbyname($server);
if( ! @x ){
return undef;
}
$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);
# end of post-connect fixup
select((select(S), $| = 1)[0]);
return 1;
}

## $return = &chat'expect($timeout_time,
## $pat1, $body1, $pat2, $body2, ... )
## $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
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;

# 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/) {
\$S = \$';
package $caller;
$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";
}
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();
}

## &chat'print(@data)
sub print { ## public
print S @_;
if( $chat'debug ){
print STDERR "printed:";
print STDERR @_;
}
}

## &chat'close()
sub close { ## public
close(S);
}

# &chat'read(*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
local(*chatreadbuf) = shift;
$chatreadn = shift;

if( $chatreadn > 0 ){
return sysread(S, $chatreadbuf, $chatreadn );
}
}

1;