#! /usr/local/bin/perl -wc
#
#V  WireHarken.pm V3.1 24 Dec 1997 allow BUFSIZ option for accept
#   WireHarken.pm V3.0 28 Nov 1997 bless $hark into class
#   WireHarken.pm V2.2  5 Jun 1996 with PEER not SOURCE
#   WireHarken.pm V2.1 16 May 1996 complete renaming; fix select retval
#   WireHarken.pm V2.0 28 Feb 1995 renamed from Harken, for Wire V4.0
#   Harken.pm V1.0 8 Dec 1994 for Perl 5.000
#   Jim Richardson, University of Sydney
#   jimr@maths.usyd.edu.au or http://www.maths.usyd.edu.au:8000/jimr.html

package WireHarken;

#   Open a specified or arbitrary port and listen on it; supply the port
#   number and accept connections as requested.  
#
#   To open a port use
#
#	$hark = WireHarken->open( [ option [, option ] ] )
#
#   where the permitted options are
#
#	PORT => portno (defaults to an arbitrary port; must be root for low ports)
#	BACKLOG => number of pending connections allowed (default 1)
#	LOCALADDR => raw address of local interface (e.g. pack('C4', 129,129,1,1))
#
#   The default for LOCALADDR is the primary address of `hostname`, and this
#   should usually be sufficient, but on a multi-address machine it may be
#   useful to specify explicitly which local address is desired.
#
#   The available methods are:
#
#	$port = $hark->port
#	$wire = $hark->accept( [ option, ... ] )
#	$hark->close
#
#   accept returns a Wire object, and takes options
#
#	TIMEOUT => seconds		(accept and read timeout)
#	CALLBACK => \&subroutine	(called on errors as in Wire)
#	BUFSIZ => $bufsiz		(buffer size for append)
#	CLOSEHARKEN => 1		(closes $hark after accepting connection)


BEGIN
{
    $modname = 'WireHarken';
    $filehandle = 'fh000000';
}

    use Valparams;
    use Wire;

sub open
{
    my $class = shift;
    my $hark = valparams( { @_ }, qw( PORT BACKLOG LOCALADDR ) );

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

    $hark->{ BACKLOG } ||= 1;

    unless( sockbind( $hdl, 0, $hark->{ LOCALADDR }, $hark->{ PORT } || 0 )
	    && listen( $hdl, $hark->{ BACKLOG } ) )
    {
	my $errmsg = $!;
	close $hdl;
	$port = $hark->{ PORT };
	undef $hark;
	die "${modname}->open: could not listen on port $port (\l$errmsg)\n";
    }

    #  Turn off output buffering (is this necessary here?)

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

    bless $hark, $class;
}

sub port
{
    my ( $hark ) = @_;

    die "${modname}->port: handle not open\n" unless defined $hark->{ INHDL };

    ( unpack( 'x2 n', getsockname( $hark->{ INHDL } ) ) )[0];
}

sub accept
{
    my $hark = shift;
    my $wire = valparams( { @_ }, qw( TIMEOUT CALLBACK BUFSIZ CLOSEHARKEN ) );
    bless $wire, Wire;

    my ( $hdl, $peer, $tmo, $selval );

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

    #  Watch for timeout before accept

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

	$selval = select( $mask, undef, undef, $wire->{ TIMEOUT } );

	unless( $selval > 0 )
	{
	    #  Return value zero (timeout) or negative (or undefined?): error

	    $wire->err_on_wire(
		"${modname}->accept: " .
		    ( $selval == 0 ? "timeout after $wire->{TIMEOUT} seconds" :
			$! ) );

	    undef $wire->{ INHDL };	# to thwart Wire->DESTROY
	    undef $wire->{ OUTHDL };

	    return undef $wire;
	}
    }

    #  Now accept a connection

    unless( $peer = accept( $hdl, $hark->{ INHDL } ) )
    {
	$wire->err_on_wire( "$modname accept failed (\l$!)" );
	return undef $wire;
    }

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

    my ( $port, @addr ) = unpack( 'x2 S C4', $peer );
    $wire->{ PEER } = join( '.', @addr ) . ":$port";

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

    &close( $hark ) if $wire->{ CLOSEHARKEN };

    $wire;
}

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

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

    undef %$hark;
}
   
1;

#!#