#! /usr/local/bin/perl -wc
#
#V  Wire.pm V7.0 27 Aug 1999 with gethostbyname subject to timeout; withdraw init()
#   Wire.pm V6.8 11 Feb 1998 with LOCALPORT
#   Wire.pm V6.7 24 Dec 1997 use $default_bufsiz as last resort in append
#   Wire.pm V6.6 10 Dec 1997 allowing \n\r\n to terminate readpara
#   Wire.pm V6.5 24 Nov 1997 check sysread() for undef as well as negative
#   Wire.pm V6.4 21 Nov 1997 with BUFSIZ option on open
#   Wire.pm V6.3 17 Nov 1997 with INADDR_ANY instead of primary address
#   Wire.pm V6.2 22 Oct 1997 with embedded closure timeout subroutine
#   Wire.pm V6.1 14 Oct 1997 with Socket.pm and barewords
#   Wire.pm V6.0 10 Oct 1997 with $class for bless
#   Wire.pm V5.3 18 Jul 1997 $wire->append not append($wire) allows overriding
#   Wire.pm V5.2 18 Oct 1996 with timeout()
#   Wire.pm V5.1 10 Oct 1996 with SunOS/Solaris SOCK_ values
#   Wire.pm V5.0  5 Jun 1996 correct bug in readcrnl
#   Wire.pm V4.9 13 May 1996 with `hostname` optional in init(), not BEGIN
#   Wire.pm V4.8 24 Apr 1996 with `hostname` done in BEGIN
#   Wire.pm V4.7  3 Apr 1996 correction to TIMEOUT||0
#   Wire.pm V4.6 22 Mar 1996 initializing $wire->{ BUFFER }
#   Wire.pm V4.5 19 Mar 1996 with readpara
#   Wire.pm V4.4  8 Mar 1996 with $nwire->{TIMEOUT}||0
#   Wire.pm V4.3 11 Sep 1995 with readcrnl and append timeout argument
#   Wire.pm V4.2 20 Mar 1995 using socket.ph
#   Wire.pm V4.0 28 Feb 1995 with ADDR, INHDL/OUTHDL, LOCALADDR, etc
#   Wire.pm V3.0 22 Nov 1994 for Perl 5.000
#   descended from wire.pl V2.5 26 Aug 1994 (for Perl 4.036)
#   Jim Richardson, University of Sydney
#   jimr@maths.usyd.edu.au or http://www.maths.usyd.edu.au:8000/jimr.html

package Wire;

#   Wire, sb.
#    [OE. wi'r; referred to the base *wi- of L. viere to plait, weave]
#    ... a telegraphic message, a telegram.  1854.
#		-- Shorter Oxford English Dictionary, 3rd Ed., 1944/56.

#   This package is similar in aim to Randal L. Schwartz's chat2.pl: it
#   provides access to TCP ports.  However the calling sequences are the other
#   way up: you call wire subroutines when you want them, and manipulate the
#   buffers they provide with your own code, whereas with chat2::expect you
#   provide code fragments which it runs for you.
#
#   Wire also attempts to handle errors and timeouts gracefully, returning
#   a message to the caller by return status and/or calling a user-supplied
#   callback routine.

#   To open a wire connection, call one of
#
#	$wire = Wire->open( [ HOST => $host | ADDR => $addr ], PORT => $port
#	    [, UDP => 1 ] [, LOCALADDR => $rawaddr ] [, LOCALPORT => $lport ]
#	    [, BUFSIZ => $bufsiz ] [, TIMEOUT => $nsecs ]
#	    [, CALLBACK => \&sub ] )
#
#	$wire = Wire->open( FILE => $path  [, BUFSIZ => $bufsiz ]
#	    [, CALLBACK => \&sub ]  )
#
#	$wire = Wire->open( [ INHDL => handle1 and/or OUTHDL => handle2 ]
#	    [, BUFSIZ => $bufsiz ] [, TIMEOUT => $nsecs ]
#	    [, CALLBACK => \&sub ] )
#
#   The first form opens a socket to a host by name (HOST, which may be a
#   DNS name or in the form "nnn.nnn.nnn.nnn") or by IP address (ADDR,
#   taking a packed argument in C4 format).  UDP is used if specified as
#   an option; otherwise TCP is used.
#
#   The default for LOCALADDR is INADDR_ANY, i.e. choose the right address.
#   This should usually be sufficient, but on a multi-address machine it may be
#   useful to specify explicitly which local address is desired.  If so, then
#   give the packed address of a local interface.  The default for LOCALPORT
#   is zero, so the system will allocate a port.
#
#   The second form opens a file by name; it allows the usual Perl conventions
#   of > for output, | for pipe, etc.  
#
#   The third form allows an existing pair of filehandles, such as STDIN and
#   STDOUT, to be treated as a wire.  If only one is specified, the wire is
#   read- or write-only.
#
#   In each case the value for BUFSIZ overrides the default buffer size of
#   1024 bytes.  CALLBACK may also be specified: this is a reference to a
#   subroutine to call back on error, passing an error message as first
#   argument and the wire itself as (rarely used) second argument.
#
#   The available methods (returning boolean status except where shown) are
#
#	$bufref = $wire->bufref
#	$wire->append( [ $maxsiz ] [, $timeout )
#	$wire->copy( OUTHANDLE )
#	$line = $wire->readline
#	$line = $wire->readcrnl
#	$para = $wire->readpara
#	$wire->print( print_data_arguments )
#	$handle = $wire->handle( $want_outhdl )
#	$peer = $wire->peer
#	$oldtmo = $wire->timeout( [ $newtmo ] )
#	$errmsg = $wire->errmsg
#	@stats = $wire->stats		# for input only
#	$wire->close

#   Apart from the object Wire and its methods, the package exports a routine
#
#	sockbind( $hdl, $use_udp, $local_addr, $port )
#
#   for creating and binding a socket: see below for details.  This may be used
#   by other packages based on Wire which open their own connections.

    require Exporter;
    @ISA = Exporter;
    @EXPORT = qw( sockbind );


BEGIN
{
    $modname = Wire;
    $filehandle = 'fh000000';

    $sockaddr = 'S n a4 x8';

    $tcp_proto = ( getprotobyname( 'tcp' ) )[2];
    $udp_proto = ( getprotobyname( 'udp' ) )[2];

    $default_bufsiz = 1024;
}

    use Socket qw( AF_INET PF_INET SOCK_STREAM SOCK_DGRAM INADDR_ANY );
    use Valparams;

sub open
{
    my $class = shift;
    my $nwire = valparams( { @_ },
	qw( HOST ADDR PORT UDP LOCALADDR LOCALPORT
	    FILE INHDL OUTHDL
	    TIMEOUT BUFSIZ CALLBACK ) );

    #  Open a wire, as described above

    my ( $hdl, $host, $hostaddr, $port, $timeout, $file, $inhdl, $outhdl );

    if( ( $host = $nwire->{ HOST } and
	    ! clash( $nwire, HOST, ADDR, FILE, INHDL, OUTHDL ) || return undef ) or
	( $hostaddr = $nwire->{ ADDR } and
	    ! clash( $nwire, ADDR, FILE, INHDL, OUTHDL ) || return undef ) )
    {
	#  Open a socket

	err_on_wire( $nwire, 'Wire: must specify PORT with HOST or ADDR' ),
	    return undef unless $port = $nwire->{ PORT };

	$hdl = $nwire->{ INHDL } = $nwire->{ OUTHDL } =
	    "${modname}::" . ++$filehandle;

	#  The connect may time out by itself after some interval, but we
	#  use alarm in case that's too long.  gethostbyname does not seem
	#  to time out, so we subject it to alarm also.

	my ( $prevsig, $tmoerrmsg );

	#  The || 0 here avoids an uninitialized value warning if TIMEOUT is
	#  not specified (suggested by Harlan Harris):

	if( ( $timeout = $nwire->{ TIMEOUT } || 0 ) > 0 )
	{
	    $prevsig = $SIG{ ALRM };

	    $tmoerrmsg =
	"alarm timeout after $nwire->{TIMEOUT} seconds doing hostname lookup on $host";

	    $SIG{ ALRM } = sub
	    {
		$SIG{ ALRM } = $prevsig;
		err_on_wire( $nwire, $tmoerrmsg );

		#  If the callback routine returns to this point, connect
		#  may return the error "interrupted system call".
	    };

	    alarm( $timeout );
	}

	if( $hostaddr )
	{
	    $host = join( '.', unpack( C4, $hostaddr ) );
	}
	elsif( $host =~ m!^(\d+)\.(\d+)\.(\d+)\.(\d+)$! )
	{
	    $hostaddr = pack( C4, $1, $2, $3, $4 );
	}
	elsif( ! ( $hostaddr = ( gethostbyname( $host ) )[4] ) )
	{
	    #  gethostbyname does not set $!

	    alarm( 0 ), $SIG{ ALRM } = $prevsig if $timeout > 0;

	    err_on_wire( $nwire, "nameserver did not find $host" );
	    return undef;
	}

	$nwire->{ PEER } = "$host:$port";

	$tmoerrmsg =
	    "alarm timeout after $nwire->{TIMEOUT} seconds opening $nwire->{PEER}";

	unless( sockbind( $hdl, $nwire ->{ UDP }, $nwire->{ LOCALADDR },
			  $nwire->{ LOCALPORT } || 0 )
		&& connect( $hdl, pack( $sockaddr, AF_INET, $port, $hostaddr ) ) )
	{
	    if( $timeout > 0 )
	    {
		alarm( 0 );
		$SIG{ ALRM } = $prevsig;
	    }
	    err_on_wire( $nwire, "failed to open $host:$port (\l$!)" )
		unless $! eq 'Interrupted system call' &&
		    $nwire->{ ERRMSG } =~ m!^alarm timeout after!; # only report once
	    close $hdl;
	    return undef;
	}

	alarm( 0 ), $SIG{ ALRM } = $prevsig if $timeout > 0;

	#  Turn off output buffering

	select( ( select( $hdl ), $| = 1 )[0] );

    }
    elsif( $file = $nwire->{ FILE } )
    {
	#  Open a file

	return undef if clash( $nwire, FILE, PORT, TIMEOUT, INHDL, OUTHDL );

	$hdl = $nwire->{ INHDL } = $nwire->{ OUTHDL } =
	    "${modname}::" . ++$filehandle;

	unless( open( $hdl, $file ) )
	{
	    err_on_wire( $nwire, "failed to open $file (\l$!)" );
	    return undef;
	}

	$nwire->{ PEER } = $file;

    }
    elsif( $inhdl = $nwire->{ INHDL },
	   $outhdl = $nwire->{ OUTHDL } or $inhdl )
    {
	#  Use an existing filehandle or filehandles

	if( $inhdl )
	{
	    return undef if clash( $nwire, INHDL, PORT );

	    #  Qualify handle with caller_package:: if not done already

	    ( $nwire->{ INHDL } = $inhdl ) =~ s!^([^:]+)$! (caller)[0] . "::$1" !e;

	    $nwire->{ PEER } = "<$inhdl";
	}

	if( $outhdl )
	{
	    return undef if clash( $nwire, OUTHDL, PORT );

	    $outhdl =~ s!^([^:]+)$! (caller)[0] . "::$1" !e;

	    $nwire->{ PEER } .= ' , ' if $inhdl;
	    $nwire->{ PEER } .= ">$outhdl";

	    #  Turn off output buffering

	    select( ( select( $nwire->{ OUTHDL } = $outhdl ), $| = 1 )[0] );
	}
    }
    else
    {
	err_on_wire( $nwire, 'Wire: must specify HOST|ADDR+PORT, FILE, or INHDL|OUTHDL' );
	return undef;
    }

    $nwire->{ BUFSIZ } ||= $default_bufsiz;

    $nwire->{ BUFFER } = '';	# to avoid "unitialized" warnings

    $nwire->{ NBYTES } = $nwire->{ NREADS } = 0;

    bless $nwire, $class;
}

sub clash
{
    #  Internal check for compatibility of options to open()

    my $nwire = shift;
    my $opt = shift;

    foreach $badopt( @_ )
    {
	if( $nwire->{ $badopt } )
	{
	    err_on_wire( $nwire, "Wire: may not specify $badopt with $opt" );
	    return 1;
	}
    }

    undef;
}

sub sockbind
{
    my ( $hdl, $use_udp, $local_addr, $port ) = @_;

    #  Create a socket $hdl (via UDP if $use_udp is true but otherwise via
    #  TCP), then bind it to $port (zero for a new port) on local raw address
    #  $local_addr which takes the form pack( C4, a,b,c,d ) for IP address
    #  a.b.c.d.  If $local_addr is undefined then INADDR_ANY will be supplied,
    #  allowing the correct interface to be chosen automatically.
    #
    #  Return true on success; on failure set $! and return false.
    #
    #  This routine may be called from outside the package.

    #  perl5 does not allow embedding the following array expression
    #  in the socket call:

    my ( $type, $proto ) = $use_udp ?
	( SOCK_DGRAM, $udp_proto ) : ( SOCK_STREAM, $tcp_proto );

    socket( $hdl, PF_INET, $type, $proto )
    &&
    bind( $hdl,
	  pack( $sockaddr, AF_INET, $port, $local_addr || INADDR_ANY )
    )    
}

sub bufref
{
    my ( $wire ) = @_;

    #  Return a reference to $wire's buffer so the caller can manipulate it
    #  directly

    \( $wire->{ BUFFER } );
}

sub append
{
    my ( $wire, $maxsiz, $tmo ) = @_;

    #  Read input from $wire, of greater than zero but not more than
    #  $maxsiz bytes (default $bufsiz if omitted); and append this input
    #  to the buffer associated with $wire; return undef on end-of-file;
    #  call back and return undef on timeout or error; otherwise return 1.
    #  $tmo is the timeout period in seconds, unless absent, in which case
    #  the timeout specified at open is used.

    return undef if $wire->{ SAWEOF };

    $maxsiz ||= $wire->{ BUFSIZ } || $default_bufsiz;
    $tmo ||= $wire->{ TIMEOUT };

    my $mask = '';
    vec( $mask, fileno( $wire->{ INHDL } ), 1 ) = 1;

    unless( select( $mask, undef, undef, $tmo ) )
    {
	err_on_wire( $wire,
"timeout after $tmo seconds ($wire->{NBYTES} bytes) appending from $wire->{PEER}" );
	#  or might it have been some other error?
	return undef;
    }

    my $nbyt = sysread( $wire->{ INHDL }, $wire->{ BUFFER }, $maxsiz,
	length( $wire->{ BUFFER } ) );

    if( ! defined( $nbyt ) || $nbyt < 0 )
    {
	err_on_wire( $wire, "failure appending $wire->{PEER} (\l$!)" );
	return undef;
    }
    elsif( $nbyt == 0 )
    {
	#  End of file

	$wire->{ SAWEOF } = 1;
	return undef;
    }

    $wire->{ NBYTES } += $nbyt;
    $wire->{ NREADS }++;

    1;
}

sub copy
{
    my ( $wire, $out ) = @_;

    #  Copy from $wire, to any file handle $out, starting with $wire's
    #  associated buffer, and continuing to end-of-file.  Call back
    #  if there is an error on $wire, and die if there is an error
    #  (presumably the programmer's) on $out, but otherwise return
    #  undef in all cases.

    #  Qualify handle with caller_package:: if not done already

    $out =~ s!^([^:]+)$! (caller)[0] . "::$1" !e;

    my $brf = \( $wire->{ BUFFER } );

    ( print( $out $$brf ) || die "Error copying to $out (\l$!)" ), undef $$brf
	while defined( $$brf ) || $wire->append;

    undef;
}

sub readline
{
    my ( $wire ) = @_;

    #  Read and return a newline-delimited line, or the rest of the wire
    #  if there are no more newlines.  Return an empty string '' on
    #  end-of-file.

    my $frag;

    for(;;)	# until would give trouble with scope of $1
    {
	return $1 if $wire->{ BUFFER } =~ s!^([^\n]*\n)!!;
	$frag = $wire->{ BUFFER }, undef $wire->{ BUFFER }, return $frag
	    unless $wire->append;
    }
}

sub readcrnl
{
    my ( $wire ) = @_;

    #  Read and return a line delimited by a newline, optionally preceded
    #  by a carriage-return which is removed if present, or the rest of the
    #  wire if there are no more newlines.  Return an empty string '' on
    #  end-of-file.

    my $lorf;

    for(;;)	# until would give trouble with scope of $1
    {
	$lorf = $1, last if $wire->{ BUFFER } =~ s!^([^\n]*\n)!!;
	$lorf = $wire->{ BUFFER }, undef $wire->{ BUFFER }, return $lorf
	    unless $wire->append;
    }

    #  For a line (rather than a fragment) remove the penultimate \r if
    #  present

    $lorf =~ s!\r\n!\n!;

    $lorf;
}

sub readpara
{
    my ( $wire ) = @_;

    #  Read and return a paragraph delimited by two newlines (possibly
    #  with an intervening carriage-return), or the rest of the wire if
    #  there are no more double newlines.  Return an empty string '' on
    #  end-of-file.

    my $frag;

    for(;;)	# until would give trouble with scope of $1
    {
	#  Note that . matches anything except \n.
	return $1 if $wire->{ BUFFER } =~ s!\A((.*\n.)*.*\n\r?\n)!!;
	$frag = $wire->{ BUFFER }, undef $wire->{ BUFFER }, return $frag
	    unless $wire->append;
    }
}

sub print
{
    my $wire = shift;

    #  Print arguments after the first to $wire, reporting any error via callback;
    #  return 1 on success and undef otherwise.

    #  NB print does not watch for timeout or provide statistics.

    my $hdl = $wire->{ OUTHDL };

    if( print $hdl @_ )
    {
	1;
    }
    else
    {
	err_on_wire( $wire, "failure printing $wire->{PEER} (\l$!)" );
	undef;
    }
}

sub err_on_wire
{
    my ( $wire, $msg ) = @_;

    #  Internal: save error message and call the callback routine if any

    $wire->{ ERRMSG } = $msg;

    #  Call back error routine if supplied

    my $sub = $wire->{ CALLBACK };

    &$sub( $msg, $wire ) if defined &$sub;
}

sub errmsg
{
    my ( $wire ) = @_;

    $wire->{ ERRMSG };
}

sub handle
{
    my ( $wire, $want_outhdl ) = @_;

    #  Allows I/O operations by caller direct to filehandle: invalidates
    #  Wire buffer, timeout, and all calls except $wire->peer and
    #  $wire->close.  The input handle is returned unless a true argument
    #  is supplied.


    $wire->{ $want_outhdl ? OUTHDL : INHDL };
}

sub peer
{
    my ( $wire ) = @_;

    #  Either hostname:port or filename to which the wire is connected

    $wire->{ PEER };
}

sub source
{
    #  Obsolescent synonym

    &peer;
}

sub timeout
{
    my ( $wire, $newtmo ) = @_;

    #  Set timeout to $newtmo if defined, and return old value

    my $oldtmo = $wire->{ TIMEOUT };

    $wire->{ TIMEOUT } = $newtmo if defined $newtmo;

    $oldtmo;
}

sub stats
{
    my ( $wire ) = @_;

    #  Return the statistics: total bytes, # reads, average bytes/read, bufsiz.
    #  Note that only input statistics are supplied.

    ( $wire->{ NBYTES } || 0, $wire->{ NREADS } || 0,
      $wire->{ NREADS } && $wire->{ NBYTES } / $wire->{ NREADS },
      $wire->{ BUFSIZ } );
}

sub close
{
    my ( $wire ) = @_;

    close $wire->{ INHDL } if defined $wire->{ INHDL };
    close $wire->{ OUTHDL } if defined $wire->{ OUTHDL }
	and $wire->{ OUTHDL } ne $wire->{ INHDL };

    undef %{$wire};
}
 
sub DESTROY
{
    &close;
}

1;
#!#