File Coverage

blib/lib/Net/Gen.pm

Criterion	Covered	Total	%
statement	578	767	75.3
branch	199	452	44.0
condition	102	281	36.3
subroutine	65	73	89.0
pod	37	40	92.5
total	981	1613	60.8

# Copyright 1995,2002 Spider Boardman.
# All rights reserved.
#
# Automatic licensing for this software is available.  This software
# can be copied and used under the terms of the GNU Public License,
# version 1 or (at your option) any later version, or under the
# terms of the Artistic license.  Both of these can be found with
# the Perl distribution, which this software is intended to augment.
#
# THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.

# rcsid: "@(#) $Id: Gen.dat,v 1.44 2002/04/10 11:27:18 spider Exp $"


package Net::Gen;
use 5.004_04;		# new minimum Perl version for this package

use strict;
#use Carp; # no!  just require Carp when we want to croak.
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS
	    %_missing $AUTOLOAD $adebug);

BEGIN {
    $VERSION = '1.011';
    eval "sub Version () { __PACKAGE__ . ' v$VERSION' }";
}

#use Socket qw(!/pack_sockaddr/ !/^MSG_OOB$/ !SOMAXCONN);
use Socket ();
use AutoLoader;
use Exporter ();
use DynaLoader ();
use Symbol qw(gensym);
use SelectSaver ();
use IO::Handle ();

# Special wart for new_from_f{d,h}, since only the _fh flavour's already
# known to AutoLoader.
sub new_from_fd;  *new_from_fd = \&new_from_fh;

BEGIN {
    @ISA = qw(IO::Handle Exporter DynaLoader);

    @EXPORT = ();

    @EXPORT_OK = qw(pack_sockaddr
		    unpack_sockaddr
		    VAL_O_NONBLOCK
		    VAL_EAGAIN
		    RD_NODATA
		    EOF_NONBLOCK
		    EINPROGRESS EALREADY ENOTSOCK EDESTADDRREQ
		    EMSGSIZE EPROTOTYPE ENOPROTOOPT EPROTONOSUPPORT
		    ESOCKTNOSUPPORT EOPNOTSUPP EPFNOSUPPORT EAFNOSUPPORT
		    EADDRINUSE EADDRNOTAVAIL ENETDOWN ENETUNREACH ENETRESET
		    ECONNABORTED ECONNRESET ENOBUFS EISCONN ENOTCONN
		    ESHUTDOWN ETOOMANYREFS ETIMEDOUT
		    ECONNREFUSED EHOSTDOWN EHOSTUNREACH
		    ENOSR ETIME EBADMSG EPROTO ENODATA ENOSTR
		    EAGAIN EWOULDBLOCK
		    ENOENT EINVAL EBADF
		    SHUT_RD SHUT_WR SHUT_RDWR
		    SOL_SOCKET
		    SOMAXCONN
		    SO_ACCEPTCONN SO_BROADCAST SO_DEBUG SO_DONTROUTE
		    SO_ERROR SO_EXPANDED_RIGHTS SO_FAMILY SO_KEEPALIVE
		    SO_LINGER SO_OOBINLINE SO_PAIRABLE SO_RCVBUF
		    SO_RCVLOWAT SO_RCVTIMEO SO_REUSEADDR SO_REUSEPORT
		    SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO SO_STATE SO_TYPE
		    SO_USELOOPBACK SO_XSE
		    SOCK_STREAM SOCK_DGRAM SOCK_RAW SOCK_RDM SOCK_SEQPACKET
		    AF_UNSPEC AF_UNIX AF_INET AF_IMPLINK AF_PUP AF_CHAOS
		    AF_NS AF_ISO AF_OSI AF_ECMA AF_DATAKIT AF_CCITT AF_SNA
		    AF_DECnet AF_DLI AF_LAT AF_HYLINK AF_APPLETALK AF_ROUTE
		    AF_LINK AF_NETMAN AF_X25 AF_CTF AF_WAN AF_USER AF_LAST
		    PF_UNSPEC PF_UNIX PF_INET PF_IMPLINK PF_PUP PF_CHAOS
		    PF_NS PF_ISO PF_OSI PF_ECMA PF_DATAKIT PF_CCITT PF_SNA
		    PF_DECnet PF_DLI PF_LAT PF_HYLINK PF_APPLETALK PF_ROUTE
		    PF_LINK PF_NETMAN PF_X25 PF_CTF PF_WAN PF_USER PF_LAST
		    AF_LOCAL PF_LOCAL
		   );

    %EXPORT_TAGS = (
	NonBlockVals => [qw(EOF_NONBLOCK RD_NODATA VAL_EAGAIN VAL_O_NONBLOCK)],
	routines	=> [qw(pack_sockaddr unpack_sockaddr)],
	errnos	=> [qw(EINPROGRESS EALREADY ENOTSOCK EDESTADDRREQ
		       EMSGSIZE EPROTOTYPE ENOPROTOOPT EPROTONOSUPPORT
		       ESOCKTNOSUPPORT EOPNOTSUPP EPFNOSUPPORT EAFNOSUPPORT
		       EADDRINUSE EADDRNOTAVAIL ENETDOWN ENETUNREACH ENETRESET
		       ECONNABORTED ECONNRESET ENOBUFS EISCONN ENOTCONN
		       ESHUTDOWN ETOOMANYREFS ETIMEDOUT
		       ECONNREFUSED EHOSTDOWN EHOSTUNREACH
		       ENOSR ETIME EBADMSG EPROTO ENODATA ENOSTR
		       EAGAIN EWOULDBLOCK
		       ENOENT EINVAL EBADF
		      )],
	shutflags => [qw(SHUT_RD SHUT_WR SHUT_RDWR)],
	sockopts => [qw(SO_ACCEPTCONN SO_BROADCAST SO_DEBUG SO_DONTROUTE
			SO_ERROR SO_EXPANDED_RIGHTS SO_FAMILY SO_KEEPALIVE
			SO_LINGER SO_OOBINLINE SO_PAIRABLE SO_RCVBUF
			SO_RCVLOWAT SO_RCVTIMEO SO_REUSEADDR SO_REUSEPORT
			SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO SO_STATE SO_TYPE
			SO_USELOOPBACK SO_XSE
		       )],
	sockvals => [qw(SOL_SOCKET
			SOCK_STREAM SOCK_DGRAM SOCK_RAW SOCK_RDM SOCK_SEQPACKET
		       )],
	af	=> [qw(AF_UNSPEC AF_UNIX AF_INET AF_IMPLINK AF_PUP AF_CHAOS
		       AF_NS AF_ISO AF_OSI AF_ECMA AF_DATAKIT AF_CCITT AF_SNA
		       AF_DECnet AF_DLI AF_LAT AF_HYLINK AF_APPLETALK AF_ROUTE
		       AF_LINK AF_NETMAN AF_X25 AF_CTF AF_WAN AF_USER AF_LAST
		       AF_LOCAL
		      )],
	pf	=> [qw(PF_UNSPEC PF_UNIX PF_INET PF_IMPLINK PF_PUP PF_CHAOS
		       PF_NS PF_ISO PF_OSI PF_ECMA PF_DATAKIT PF_CCITT PF_SNA
		       PF_DECnet PF_DLI PF_LAT PF_HYLINK PF_APPLETALK PF_ROUTE
		       PF_LINK PF_NETMAN PF_X25 PF_CTF PF_WAN PF_USER PF_LAST
		       PF_LOCAL
		      )],
	ALL	=> [@EXPORT, @EXPORT_OK],
    );
    $EXPORT_TAGS{'non_block_vals'} = $EXPORT_TAGS{'NonBlockVals'};
    $EXPORT_TAGS{'families'} = [@{$EXPORT_TAGS{'af'}}, @{$EXPORT_TAGS{'pf'}}];
}

my %loaded;


# dummies for the Carp:: routines, which we'll re-invoke if we get called.

sub croak
{
    require Carp;
    goto &Carp::croak;
}

sub carp
{
    require Carp;
    goto &Carp::carp;
}


my $nullsub = sub {};		# handy null warning handler
# If the warning handler is this exact code ref, don't bother calling
# croak in the AUTOLOAD constant section, since we're being called from
# inside the eval in initsockopts().

sub AUTOLOAD : locked
{
    # This AUTOLOAD is used to validate possible missing constants from
    # the XS code, or to auto-create get/setattr subs.
    # The defined constants are already available as XSUBs, and the same
    # XS code which handles that also sets up the %_missing hash to note
    # which names were known but are undefined.
    # If the name is in %_missing, we'll croak as a normal AUTOLOAD with
    # a constant() XS function (except for when $nullsub is the die handler).
    # If the name isn't known to %_missing, but it is known
    # as a key for setparams/getparams, it will be simulated via _accessor().
    # Otherwise, control will be passed to the AUTOLOAD in AutoLoader.

#   use attrs 'locked';		# modifies the symbol table and abuses a global

    my ($constname,$callpkg);
    {				# block to preserve $1,$2,et al.
	($callpkg,$constname) = $AUTOLOAD =~ /^(.*)::(.*)$/;
    }
    if (exists $_missing{$AUTOLOAD}) {
	my $wh = $SIG{__WARN__};
	die "\n"
	    if ($wh and (ref($wh) eq 'CODE') and $wh == $nullsub);
	croak "Your vendor has not defined $callpkg macro $constname, used";
    }
    if (@_ && ref $_[0] && @_ < 3 && exists $ {*{$_[0]}}{Keys}{$constname}) {
	no strict 'refs';	# allow us to define the sub
	my $what = $constname;	# don't tie up $constname for closures
	warn "Auto-generating accessor $AUTOLOAD\n" if $adebug;
	*$AUTOLOAD = sub {
	    splice @_, 1, 0, $what;
	    goto &_accessor;
	};
	goto &$AUTOLOAD;
    }
    warn "Autoloading $AUTOLOAD\n" if $adebug;
    $AutoLoader::AUTOLOAD = $AUTOLOAD;
    goto &AutoLoader::AUTOLOAD;
}

BEGIN {
# do this now so the constant XSUBs really are
    __PACKAGE__->DynaLoader::bootstrap($VERSION);
}


# Preloaded methods go here.  Autoload methods go after __END__, and are
# processed by the autosplit program.


# This package has the core 'generic' routines for fiddling with
# sockets.


# initsockopts - Set up the socket options of a class using this module.
# The structure of a sockopt hash is like this:
# %sockopts = ( OPTION => ['pack_string', $option_number, $option_level,
#				$number_of_elements], ... );
# The option level and number are for calling [gs]etsockopt, and
# the number of elements is for some (weak) consistency checking.
# The pack/unpack template is used by $obj->getsopt and setsopt.
# Only the pack template is set on input to this routine.  On exit,
# it will have deleted any entries which cannot be resolved, and will
# have filled in the ones which can.  It will also have duplicated
# the entries to be indexed by option value as well as by option name.

my %evalopts;			# avoid compiling an eval per sockopt

#& initsockopts($class, $level+0, \%sockopts) : void
sub initsockopts : locked
{
    my ($class,$level,$opts) = @_;
    croak "Invalid arguments to " . __PACKAGE__ . "::initsockopts, called"
	if @_ != 3 or ref $opts ne 'HASH';
    $level += 0;		# force numeric
    my($opt,$oval,@oval,$esub);
    my $nullwarn = $nullsub;	# a handy __WARN__ handler
    # The above has to be there, since the file-scope 'my' won't be seen
    # in the generated closure.
    $class = ref $class if ref $class;
    $evalopts{$class} ||= eval "package $class; no strict 'refs';" .
	'sub ($) {local($SIG{__WARN__})=$nullwarn;local($SIG{__DIE__});' .
	    '&{$_[0]}()}';
    $esub = $evalopts{$class};
    foreach $opt (keys %$opts) {
	delete $$opts{$opt}, next if exists $_missing{"${class}::$opt"};
	$oval = eval {&$esub($opt)};
	delete $$opts{$opt}, next if $@ or !defined($oval) or $oval eq '';
	$oval += 0;		# force numeric
	push(@{$$opts{$opt}}, $oval, $level);
	$$opts{$oval} = $$opts{$opt};
	$oval = $$opts{$opt}[0];
	@oval = unpack($oval, pack($oval, 0));
	$$opts{$opt}[3] = scalar @oval;
    }
}


my %sockopts;

# The known socket options (from Socket.pm)

%sockopts = (
	     # First, the simple flag options

	     'SO_ACCEPTCONN'	=> [ 'I' ],
	     'SO_BROADCAST'	=> [ 'I' ],
	     'SO_DEBUG'		=> [ 'I' ],
	     'SO_DONTROUTE'	=> [ 'I' ],
	     'SO_ERROR'		=> [ 'I' ],
	     'SO_EXPANDED_RIGHTS' => [ 'I' ],
	     'SO_KEEPALIVE'	=> [ 'I' ],
	     'SO_OOBINLINE'	=> [ 'I' ],
	     'SO_PAIRABLE'	=> [ 'I' ],
	     'SO_REUSEADDR'	=> [ 'I' ],
	     'SO_REUSEPORT'	=> [ 'I' ],
	     'SO_USELOOPBACK'	=> [ 'I' ],
	     'SO_XSE'		=> [ 'I' ],

	     # Simple integer options

	     'SO_RCVBUF'	=> [ 'I' ],
	     'SO_SNDBUF'	=> [ 'I' ],
	     'SO_RCVTIMEO'	=> [ 'I' ],
	     'SO_SNDTIMEO'	=> [ 'I' ],
	     'SO_RCVLOWAT'	=> [ 'I' ],
	     'SO_SNDLOWAT'	=> [ 'I' ],
	     'SO_TYPE'		=> [ 'I' ],
	     'SO_STATE'		=> [ 'I' ],
	     'SO_FAMILY'	=> [ 'I' ],

	     # Finally, one which is a struct

	     'SO_LINGER'	=> [ 'II' ],

	     # Out of known socket options
	     );

__PACKAGE__->initsockopts( SOL_SOCKET(), \%sockopts );


#& _genfh() : returns orphan globref with HV slot.
sub _genfh ()
{
    my $rval = gensym;
    *{$rval} = {};		# initialise a hash slot
    $rval;
}

my $debug = 0;			# module-wide debug hack -- don't use

# On the other hand, per-object debugging isn't so bad....

# can update $debug file variable
#& _debug($this [, $newval]) : oldval
sub _debug : locked
{
    my ($this,$newval) = @_;
    return $this->debug($newval) if ref $this;
    # class method here
    my $oldval = $debug;
    $debug = 0+$newval if defined $newval;
    $oldval;
}

#& debug($self [, $newval]) : oldval
sub debug : locked method
{
    my ($self,$newval) = @_;
    my $oldval = $ {*$self}{Parms}{'debug'} if defined wantarray;
    $self->setparams({'debug'=>$newval}) if defined $newval;
    $oldval;
}

#& _trace($this, \@args, minlevel, [$moretext]) : void
sub _trace
{
    my ($this,$aref,$level,$msg) = @_;
    my $rtn = (caller(1))[3];
#    local $^W=0;		# keep the arglist interpolation from carping
    $msg = '' unless defined $msg;
    print STDERR "${rtn}(@{$aref||[]})${msg}\n"
	if $level and $this->_debug >= $level;
    ${rtn};
}

#& _setdebug($self, $name, $newval) : {'' | "carp string"}
sub _setdebug
{
    my ($self,$what,$val) = @_;
    return '' unless defined $val;
    return "$self->{$what} parameter ($val) must be non-negative integer"
	if $val eq '' or $val =~ /\D/;
    $_[2] += 0;		# force numeric
    '';			# return goodness
}

# try to work even in places where Fcntl.xs doesn't.

my ($F_GETFL,$F_SETFL) =
    eval 'use Fcntl qw(F_GETFL F_SETFL);(F_GETFL,F_SETFL)';
my $nonblock_flag = eval 'pack("I",VAL_O_NONBLOCK)';
my $eagain = eval 'VAL_EAGAIN';

#& _accessor($self, $what [, $newval]) : oldvalue
sub _accessor : locked method
{
    my ($self, $what, $newval) = @_;
    croak "Usage: \$sock->$what or \$sock->$what(\$newvalue),"
	if @_ > 3;
    my $oldval = $self->getparam($what) if defined wantarray;
    $self->setparams({$what=>$newval}) if @_ > 2;
    $oldval;
}

#& _setblocking($self, $name, $newval) : {'' | "carp string"}
sub _setblocking
{
    my ($self,$what,$newval) = @_;
    $newval = 1 unless defined $newval;
    # default previous value, just in case
    $ {*$self}{Parms}{$what} = 1 unless
	defined $ {*$self}{Parms}{$what};
    if ($newval) {
	$_[2] = 1;	# canonicalise the new value
	if (defined $F_GETFL and defined $F_SETFL and
	    defined $nonblock_flag and $self->isopen)
	{
	    if ((CORE::fcntl($self, $F_GETFL, 0) & VAL_O_NONBLOCK) ==
		VAL_O_NONBLOCK)
	    {
		$ {*$self}{Parms}{$what} = 0;  # note previous status
		return 'Failed to clear non-blocking status'
		    unless eval {CORE::fcntl($self, $F_SETFL,
					   CORE::fcntl($self, $F_GETFL, 0) &
					     ~VAL_O_NONBLOCK)};
	    }
	}
    }
    else {
	$_[2] = 0;	# canonicalise the new value
	unless (defined $F_GETFL and defined $F_SETFL and
		defined $nonblock_flag)
	{
	    return 'Non-blocking sockets unavailable in this configuration';
	}
	if ($self->isopen) {
	    if ((CORE::fcntl($self, $F_GETFL, 0) & VAL_O_NONBLOCK) !=
		VAL_O_NONBLOCK)
	    {
		$ {*$self}{Parms}{$what} = 1;  # note previous state
		return 'Failed to set non-blocking status'
		    unless eval {CORE::fcntl($self, $F_SETFL,
					   CORE::fcntl($self, $F_GETFL, 0) |
					     VAL_O_NONBLOCK)};
	    }
	}
    }
    '';		# return goodness if got this far
}

#& blocking($self [, $newval]) : canonical_oldval
sub blocking : locked method
{
    my ($self, $newval) = @_;
    croak 'Usage: $sock->blocking or $sock->blocking(0|1),'
	if @_ > 2;
    my $oldval = $self->getparam('blocking', 1, 1) if defined wantarray;
    $self->setparams({'blocking'=>$newval}) if @_ > 1;
    $oldval;
}

#& _settimeout($self, $what, $newval) : {'' | "carp string"}
sub _settimeout
{
    my ($self,$what,$newval) = @_;
    unless (defined $newval) {
	return '';		# It's always OK to delete a timeout.
    }
    if (!length($newval) or $newval =~ /\D/) {
	"Parameter $what must be a non-negative integer or undefined";
    }
    else {
	'';
    }
}

my @Keys = qw(PF AF type proto dstaddr dstaddrlist srcaddr srcaddrlist
	      maxqueue reuseaddr netgen_fakeconnect reuseport);
my %Codekeys = (
		'debug' => \&_setdebug,
		'blocking' => \&_setblocking,
		'timeout' => \&_settimeout,
	       );
# This hash remembers the original {Keys} settings after the first time.
my %Keys;

# This hash remembers the original socket option settings after the first time.
my %Opts;

#& register_param_keys($self, \@keys)
sub register_param_keys : locked method
{
    my ($self, $names) = @_;
    my $whoami = $self->_trace(\@_,3);
    croak "Invalid arguments to ${whoami}(@_), called"
	if @_ != 2 or ref $names ne 'ARRAY';
    @{$ {*$self}{Keys}}{@$names} =
	@{$ {*$self}{Keys}}{@$names}; # remember the names
    # this form doesn't clobber pre-existing register_param_handlers values
}

sub registerParamKeys;	# helps with -w
*registerParamKeys = \®ister_param_keys; # alias form preferred by many

#& register_param_handlers($self, \@keys, [\]@handlers)
#&  -or- ($self, \%key-handlers)
sub register_param_handlers : locked method
{
    my ($self, $names, @handlers, $handlers) = @_;
    my $whoami = $self->_trace(\@_,3);
    if (ref $names eq 'HASH') {
	croak "Invalid parameters to ${whoami}(@_), called"
	    if @_ != 2;
	$handlers = [values %$names];
	$names = [keys %$names];
    }
    else {
	croak "Invalid parameters to ${whoami}(@_), called"
	    if @_ < 3 or ref $names ne 'ARRAY';
	$handlers = \@handlers;	# in case passed as a list
	$handlers = $_[2] if @_ == 3 and ref($_[2]) eq 'ARRAY';
    }
    croak "Invalid handlers in ${whoami}(@_), called"
	if @$handlers != @$names or grep(ref $_ ne 'CODE', @$handlers);
    # finally, all is validated, so set the bloody things
    @{$ {*$self}{Keys}}{@$names} = @$handlers;
}

sub registerParamHandlers;	# helps with -w
*registerParamHandlers = \®ister_param_handlers; # alias other form

#& register_options($self, $levelname, $level, \%options)
sub register_options : locked method
{
    my ($self, $levname, $level, $opts) = @_;
    my $whoami = $self->_trace(\@_,3);
    croak "Invalid arguments to ${whoami}(@_), called"
	if ref $opts ne 'HASH';
    $ {*$self}{Sockopts}{$levname} = $opts;
    $ {*$self}{Sockopts}{$level+0} = $opts;
}

sub registerOptions;		# helps with -w
*registerOptions = \®ister_options; # alias form preferred by many

# pseudo-subclass for saving parameters (ParamSaver, inspired by SelectSaver)
#& param_saver($self, @params) : restoration_object
sub param_saver : locked method
{
    my ($self, @params) = @_;
    my @delparams =
	# map { exists $ {*$self}{Parms}{$_} ? () : ($_) } @params;
	grep {!exists $ {*$self}{Parms}{$_}} @params;
    my %setparams = $self->getparams(\@params);
    bless [$self, \%setparams, \@delparams], 'Net::Gen::ParamSaver';
}

sub paramSaver;			# aliases
*paramSaver = \¶m_saver;
sub ParamSaver;
*ParamSaver = \¶m_saver;

sub Net::Gen::ParamSaver::DESTROY
{
    local $!;	# just to be sure we don't clobber it
    $_[0]->[0]->setparams($_[0]->[1]);
    $_[0]->[0]->delparams($_[0]->[2]);
}

#& new(classname [, \%params]) : {$self | undef}
#&  -or- $classname [, @ignored]
sub new
{
    my $whoami = $_[0]->_trace(\@_,1);
    my($pack,$parms) = @_;
    my %parms;
    %parms = ( %$parms ) if $parms and ref $parms eq 'HASH';
    $parms{'debug'} = $pack->_debug unless defined $parms{'debug'};
    $parms{'blocking'} = 1 unless defined $parms{'blocking'};
    if (@_ > 2 and $parms and ref $parms eq 'HASH') {
	croak "Invalid argument format to ${whoami}(@_), called";
    }
    my $class = ref $pack || $pack;
    my $self = _genfh;
    bless $self,$class;
    $pack->_trace(\@_,2,", self=$self after bless");
    $ {*$self}{Parms} = \%parms;
    if (%Keys) {
	$ {*$self}{Keys} = { %Keys };
	$ {*$self}{Sockopts} = { %Opts };
    }
    else {
	$self->register_param_keys(\@Keys); # register our keys
	$self->register_param_handlers(\%Codekeys);
	$self->register_options('SOL_SOCKET', SOL_SOCKET(), \%sockopts);
	%Keys = %{$ {*$self}{Keys}};
	%Opts = %{$ {*$self}{Sockopts}};
    }
    if ($class eq __PACKAGE__) {
	unless ($self->init) {
	    local $!;		# preserve errno
	    undef $self;	# against the side-effects of this
	    undef $self;	# another statement needed for unwinding
	}
    }
    if (($self || $pack)->_debug) {
	if (defined $self) {
	    print STDERR "${whoami} returning self=$self\n";
	}
	else {
	    print STDERR "${whoami} returning undef\n";
	}
    }
    $self;
}

#& setparams($this, \%newparams [, $newonly [, $check]]) : boolean
sub setparams : locked method
{
    my ($self,$newparams,$newonly,$check) = @_;
    my $errs = 0;

    croak "Bad arguments to " . __PACKAGE__ . "::setparams, called"
	unless @_ > 1 and ref $newparams eq 'HASH';
    carp "Excess arguments to " . __PACKAGE__ . "::setparams ignored"
	if @_ > 4;

    $newonly ||= 0;		# undefined or zero is equiv now (-w problem)
    my ($parm,$newval,$pslot);
    while (($parm,$newval) = each %$newparams) {
	print STDERR __PACKAGE__ . "::setparams $self $parm" .
	    (defined $newval ? " $newval" : "") . "\n"
		if $self->debug;
	(carp "Unknown parameter type $parm for a " . (ref $self) . " object")
	    , $errs++, next
		unless exists $ {*$self}{Keys}{$parm};
	$pslot = \$ {*$self}{Parms}{$parm};
	next if $newonly < 0 && defined $$pslot;
	if (!$check)
	{
	    # this ungodly construct brought to you by -w
	    next if
		defined($$pslot) eq defined($newval)
		    and
			!defined($newval) ||
			$$pslot eq $newval ||
			    $$pslot !~ /\D/ &&
			    $newval !~ /\D/ &&
				length($newval) &&
				length($$pslot) &&
				$$pslot == $newval
	    ;
	}
	carp("Overwrite of $parm parameter for ".(ref $self)." object ignored")
	    , $errs++, next
		if $newonly > 0 && defined $$pslot;
	if (defined($ {*$self}{Keys}{$parm}) and
	    (ref($ {*$self}{Keys}{$parm}) eq 'CODE'))
	{
	    my $rval = &{$ {*$self}{Keys}{$parm}}($self,$parm,$newval);
	    (carp $rval), $errs++, next if $rval;
	}
	# not using $$pslot here in case {Parms} hash re-generated
	$ {*$self}{Parms}{$parm} = $newval;
    }

    $errs ? undef : 1;
}


#& delparams($self, \@paramnames) : boolean
sub delparams : locked method
{
    $_[0]->_trace(\@_,1);
    my($self,$keysref) = @_;
    my(@k,%k);
    @k = grep(exists $ {*$self}{Parms}{$_}, @$keysref);
    return 1 unless @k;		# if no keys need deleting, succeed vacuously
    @k{@k} = ();		# a hash of undefs for the following
    return undef unless $self->setparams(\%k); # see whether undef is allowed
    delete @{$ {*$self}{Parms}}{@k};
    1;				# return goodness
}

#& checkparams($self) : boolean
sub checkparams : locked method
{
    my $whoami = $_[0]->_trace(\@_,1);
    my $self = shift;
    carp "Excess arguments to ${whoami} ignored"
	if @_;
    my $curparms = $ {*$self}{Parms};
    $curparms = {} unless ref $curparms eq 'HASH';
    # make sure only the valid ones are set when we're done
    $ {*$self}{Parms} = {};
    my(@valkeys) = grep(exists $ {*$self}{Keys}{$_}, keys %$curparms);
    # this assignment allows for inter-key dependencies to be evaluated
    @{$ {*$self}{Parms}}{@valkeys} =
	@{$curparms}{@valkeys};
    # validate all current against the defined keys
    $self->setparams($curparms, 0, 1);
}

#& init($self) : {$self | undef}
sub init
{
    $_[0]->_trace(\@_,1);
    my($self) = @_;
    $self->checkparams ? $self : undef;
}

#& getparam($self, $key [, $default [, $defaultifundef]]) : param_value
sub getparam : locked method
{
    my $whoami = $_[0]->_trace(\@_,2);
    my($self,$key,$defval,$noundef) = @_;
    carp "Excess arguments to ${whoami}($self) ignored"
	if @_ > 4;
    if ($noundef) {
	return $defval unless defined($ {*$self}{Parms}{$key});
    }
    else {
	return $defval unless exists($ {*$self}{Parms}{$key});
    }
    $ {*$self}{Parms}{$key};
}

#& getparams($self, \@keys [, $noundef]) : (%hash)
sub getparams : locked method
{
    my $whoami = $_[0]->_trace(\@_,2);
    my ($self,$aref,$noundef) = @_;
    croak "Insufficient arguments to ${whoami}($self), called"
	if @_ < 2 || !ref $self || ref $aref ne 'ARRAY';
    carp "Excess arguments to ${whoami}($self) ignored"
	if @_ > 3;
    return unless defined wantarray;
    if (wantarray) {
	# the actual list is wanted -- see which way to do it
	if ($noundef) {
	    map {defined $ {*$self}{Parms}{$_} ?
		    ($_, $ {*$self}{Parms}{$_}) :
		    ()
		} @$aref;
	}
	else {
	    map {exists $ {*$self}{Parms}{$_} ?
		    ($_, $ {*$self}{Parms}{$_}) :
		    ()
		} @$aref;
	}
    }
    else {
	# the list count is wanted -- see which way to do it
	if ($noundef) {
	    2 * grep {defined $ {*$self}{Parms}{$_}} @$aref;
	}
	else {
	    2 * grep {exists $ {*$self}{Parms}{$_}} @$aref;
	}
    }
#    my @ret;
#    foreach (@$aref) {
#	push(@ret, $_, $ {*$self}{Parms}{$_})
#	    if exists($ {*$self}{Parms}{$_}) and
#		!$noundef || defined($ {*$self}{Parms}{$_});
#    }
#    wantarray ? @ret : 0+@ret;
}


#& condition($self)
sub condition : locked method
{
    my $self = $_[0];
    my $sel = SelectSaver->new;
    CORE::select($self);
    $| = 1;
    # $\ = "\015\012";
    binmode($self);
    vec($ {*$self}{FHVec} = '', CORE::fileno($self), 1) = 1;
    $self->setparams({'blocking'=>$self->getparam('blocking',1,1)},0,1);
}

#& open($self [, @ignore]) : boolean
sub open : locked method
{
    $_[0]->_trace(\@_,2);
    my $self = shift;
    $self->stopio if $self->isopen;
    my($pf,$af,$type,$proto) = \@{$ {*$self}{Parms}}{qw(PF AF type proto)};
    $$pf = PF_UNSPEC unless defined $$pf;
    $$af = AF_UNSPEC unless defined $$af;
    $$type = 0 unless defined $$type;
    $$proto = 0 unless defined $$proto;
    if (($$pf == PF_UNSPEC) && ($$af != AF_UNSPEC)) {
	$$pf = $$af;
    }
    elsif (($$af == AF_UNSPEC) && ($$pf != PF_UNSPEC)) {
	$$af = $$pf;
    }
    if ($ {*$self}{'isopen'} = socket($self,$$pf,$$type,$$proto)) {
	# keep stdio output buffers out of my way
	$self->condition;
    }
    $self->isopen;
}

# sub listen - autoloaded

# hashes for async. connect error values
my %connok = ( EISCONN,1 );
my %connip = ( EWOULDBLOCK,1 , EINPROGRESS,1 , EAGAIN,1 , EALREADY,1 );

#& _valconnect($self, $addr, $timeout) : boolean
sub _valconnect
{
    my ($self,$addr,$timeout) = @_;
    my ($fhvec,$rdvec,$wrvec,$nfound) = $ {*$self}{FHVec};
    # don't block if socket is non-blocking
    $timeout = 0 if
	!defined $timeout && !$ {*$self}{Parms}{'blocking'};
    # assume caller checked for ->isconnecting
    $rdvec = $wrvec = $fhvec;
    $nfound = CORE::select($rdvec, $wrvec, undef, $timeout);
    # If socket is 'ready', then the connect is complete (possibly failed).
    $ {*$self}{'isconnecting'} = 0 if $nfound;
    # If we don't think the connect has finished, just try to invent a
    # reasonable error and bug out.
    if (!$nfound) {
	$! = EINPROGRESS || EWOULDBLOCK || EALREADY || EAGAIN;
	return;
    }
    my $rval;
    # If we can try to find out with SO_ERROR, give it a shot.
    # This won't give valid results with SOCKS.  Tough.
    if ($ {*$self}{Sockopts}{'SOL_SOCKET'}{'SO_ERROR'}) {
	# Don't try the getsockopt if the connect is still pending!
	# Solaris 2.5.1 (at least) hangs the getsockopt in that case.
	# The connect is complete -- figure out whether we believe
	# the status.
	$rval = getsockopt($self,SOL_SOCKET,SO_ERROR);
	return unless defined $rval;
	$rval = unpack("I", $rval);
	if ($rval) {
	    $! = $rval;
	    return;
	}
	return unless defined getpeername($self);
	return 1;
    }
    # Here, we can't use SO_ERROR (it's not available).
    # The canonical test for success here involves a read() attempt, but
    # we can't use that unless we have a stream socket.  SOCK_SEQPACKET and
    # real datagram services would lose their initial transmission to a
    # read check.  So, we try it here only if we think we are SOCK_STREAM.
    my $type = $ {*$self}{Parms}{'type'};
    if ($type && $type==SOCK_STREAM) {
	my $buf = "";
	$rval = sysread($self,$buf,0);
	return unless defined $rval;
	# It succeeded.  Should it have?  If getpeername says so,
	# we still can't be sure, and we'll have to use a second connect().
    }
    return unless defined getpeername($self);
    $rval = CORE::connect($self,$addr);
    return $rval if $rval;
    return 1 if $connok{0+$!};
    $rval;
}

#& _tryconnect($self, $addr, $timeout) : boolean
sub _tryconnect
{
    my ($self,$addr,$timeout) = @_;
    if ($ {*$self}{'isconnecting'}) {
	if ($ {*$self}{Parms}{'dstaddr'} and
	    ($ {*$self}{Parms}{'dstaddr'} ne $addr))
	{
	    carp "$self->_tryconnect: different destination address while ->isconnecting!"
		if $ {*$self}{Parms}{'debug'} > 2;
	    $self->stopio;
	    return undef unless $self->open;
	    if ($self->getparam('srcaddr') || $self->getparam('srcaddrlist')
		and !$self->isbound)
	    {
		return undef unless $self->bind;
	    }
	}
    }
    # Apparently, some versions of Solaris don't like a second connect.
    # So, if we're retrying a non-blocking connect, check by other means
    # before trying to use a second connect to get the status.
    # Warning: This will not work with SOCKS.
    unless ($ {*$self}{'isconnecting'}) {
	# For Solaris, if datagram socket, don't connect if not bound.
	if ($ {*$self}{Parms}{netgen_fakeconnect}) {
	    if (!$self->isbound) {
		$ {*$self}{Parms}{'dstaddr'} = $addr;
		return 1;
	    }
	    else {
		$self->delparams(['netgen_fakeconnect']);
	    }
	}
	my $rval = CORE::connect($self,$addr);
	return $rval if $rval;
	return 1  if $connok{0+$!};
	return $rval unless $connip{0+$!};
	$ {*$self}{'isconnecting'} = 1;
	$ {*$self}{Parms}{'dstaddr'} = $addr;
	return $rval unless defined $timeout;
    }
    &_valconnect;
}

#& connect($self, [@ignored]) : boolean
sub connect : locked method
{
    $_[0]->_trace(\@_,2);
    my $self = shift;
    my $hval = *$self{HASH};
    my $parms = $hval->{Parms};
    $self->close if
	$hval->{'isconnected'} ||
	(!$hval->{'isconnecting'} && $hval->{'wasconnected'});
    return undef unless $self->isopen or $self->open;
    if ($parms->{'srcaddr'} || $parms->{'srcaddrlist'}
	and !$hval->{'isconnecting'} and !$self->isbound)
    {
	return undef unless $self->bind;
    }
    my $rval;
    my $error = 0;	# errno to propagate if failing
    {
	my ($saveblocking,$timeout);
	if (defined ($timeout = $parms->{'timeout'}) && $self->blocking) {
	    $saveblocking = $self->param_saver('blocking');
	    $self->setparams({'blocking'=>0}) or undef $timeout;
	}
	my $dlist = $parms->{dstaddrlist};
	if (defined($dlist) and
	    ref($dlist) eq 'ARRAY' and
	    !$hval->{'isconnecting'})
	{
	    my $tryaddr;
	    foreach $tryaddr (@{$dlist}) {
		$rval = _tryconnect($self, $tryaddr, $timeout);
		$parms->{dstaddr} = $tryaddr  if $rval;
		last if $rval or
		    defined $timeout && !$timeout
		    and $connip{0+$!};
	    }
	}
	else {
	    $rval = _tryconnect($self, $parms->{dstaddr}, $timeout);
	}
	$error = $!+0 unless $rval;
    }
    $hval->{'isconnected'} = $rval;
    $hval->{'wasconnected'} = '0 but true';
    if (!$rval) {
	$! = $error;
	return $rval;
    }
    $self->getsockinfo;
    $self->isconnected;
}

#& getsockinfo($self, [@ignored]) : ?dest sockaddr?
sub getsockinfo : locked method
{
    $_[0]->_trace(\@_,4);
    my $self = shift;
    my ($sad,$dad);

    $self->setparams({dstaddr => $dad}) if defined($dad = getpeername($self));
    $self->setparams({srcaddr => $sad}) if defined($sad = getsockname($self));
    wantarray ?
	((defined($sad) || defined($dad)) ? ($sad, $dad) : ()) :
	$sad && $dad;
}

# 'static' hashes for translating between SHUT_* values and the traditional
# (but off-by-one) 1-3.  Used for marking shutdown progress.  The connect
# code helps in the conspiracy by setting '0 but true' rather than '0'.

my %to_shut_flags = (SHUT_RD,1, SHUT_WR,2, SHUT_RDWR,3);

#& shutdown($self [, $how=SHUT_RDWR]) : boolean
sub shutdown : locked method
{
    $_[0]->_trace(\@_,3);
    my $self = shift;
    return 1 unless $self->isconnected or $self->isconnecting;
    my $how = shift;
    $how = SHUT_RDWR unless defined $how and $how !~ m/\D/ and length $how;
    $how += 0;
    my $xhow = $to_shut_flags{$how};
    ($how = SHUT_RDWR), ($xhow = 3)
	unless $xhow;
    my $was = ($ {*$self}{'wasconnected'} |= $xhow);
    my $rval = CORE::shutdown($self, $how);
    local $!;	# preserve shutdown()'s errno
    $ {*$self}{'isconnecting'} = $ {*$self}{'isconnected'} = 0 if
	$was == 3 or
	(!defined(getpeername($self)) && ($ {*$self}{'wasconnected'} = 3));
    $rval;
}


my @CloseVars = qw(FHVec isopen isbound didlisten wasconnected isconnected
		   isconnecting);
my @CloseKeys = qw(srcaddr dstaddr);

#& close($self [, @ignored]) : boolean
sub close : locked method
{
    $_[0]->_trace(\@_,3);
    my $self = shift;
    $self->shutdown if $self->isopen;
    $self->stopio;
}

sub CLOSE;
*CLOSE = \&close;

#& stopio($self [, @ignored]) : boolean
sub stopio : locked method
{
    $_[0]->_trace(\@_,4);
    my $self = shift;
    my $wasopen = $self->isopen;
    @{*$self}{@CloseVars} = ();	# these flags no longer true
    $self->delparams(\@CloseKeys); # connection values now invalid
    return 1 unless $wasopen;
    CORE::close($self);
}

# I/O enries

# Warning!  No intercepting of SIGPIPE is done, so the output routines
# can abort the program.

# Note that (at least) Solaris 2.5.1 doesn't like connect() on datagram
# sockets, at least not if they're not bound.  So, we fake it here.

#& send($self, $buf, [$flags, [$where]]) : boolean
sub send
{
    my $whoami = $_[0]->_trace(\@_,3);
    my($self,$buf,$flags,$whither) = @_;
    croak "Invalid args to ${whoami}, called"
	if @_ < 2 or !ref $self;
    $flags = 0 unless defined $flags;
    carp "Excess arguments to ${whoami} ignored" if @_ > 4;
    # send(2) requires connect(2)
    if (!(defined $whither or $self->isconnected)) {
	if ($self->getparams([qw(dstaddrlist dstaddr)],1) > 0) {
	    return undef unless $self->connect;
	    if ($ {*$self}{Parms}{netgen_fakeconnect}) {
		$whither = $ {*$self}{Parms}{'dstaddr'};
	    }
	}
	else {
	    if ($flags & MSG_OOB) {
		$whither = $ {*$self}{lastOOBFrom};
	    }
	    else {
		$whither = $ {*$self}{lastRegFrom};
	    }
# Can't short-circuit this--need to get the right errno value.
#	    return undef unless defined $whither or $self->connect;
	}
    }
    elsif ($self->isconnected && $ {*$self}{Parms}{netgen_fakeconnect}) {
	if (defined $whither) {
	    # *sigh* -- what errno should I return?
	    $! = EISCONN || EINVAL;
	    return undef;
	}
	$whither = $ {*$self}{Parms}{'dstaddr'};
    }
    return getsockopt($self,SOL_SOCKET,SO_TYPE) unless
	$self->isopen;		# generate EBADF return if not open
    defined $whither
	? CORE::send($self, $buf, $flags, $whither)
	: CORE::send($self, $buf, $flags);
}

sub SEND;
*SEND = \&send;

#& put($self, @stuff) : boolean
sub put
{
    $_[0]->_trace(\@_,3);
    my($self,@args) = @_;
    print {$self} @args;
}

sub PRINT;			# avoid -w error
*PRINT = \&put;			# alias that may someday be used for tied FH
sub print;			# avoid -w error
*print = \&put;			# maybe-useful alias

#& ckeof($self) : boolean
sub ckeof : locked method
{
    my $saverr = $!+0;
    local $!;			# preserve this over fcntl() and such
    my $whoami = $_[0]->_trace(\@_,3);
    my($self) = @_;
    croak "Invalid args to ${whoami}, called"
	if !@_ or !ref $self;
    # Bug out if we shouldn't have been called.
    return 1 if EOF_NONBLOCK or $saverr != $eagain;
    # Bug out early if not a socket where EOF is possible.
    return 0
	unless unpack('I',getsockopt($self,SOL_SOCKET,SO_TYPE)) == SOCK_STREAM;
    # See whether need to test for non-blocking status.
    my $flags = ($F_GETFL ? CORE::fcntl($self,$F_GETFL,0+0) : undef);
    if ((defined($flags) && defined($nonblock_flag))
	? ($flags & VAL_O_NONBLOCK)
	: 1)
    {
	# *sigh* -- no way to tell, here
	return 0;
    }
    1;				# wrong errno or blocking
}

#& recv($self, [$maxlen, [$flags, [$from]]]) : {$buf | undef}
sub recv : locked method
{
    my $whoami = $_[0]->_trace(\@_,3);
    my($self,$maxlen,$flags) = @_;
    my($buf,$from,$xfrom) = '';
    croak "Invalid args to ${whoami}, called"
	if !@_ or !ref $self;
    carp "Excess arguments to ${whoami} ignored"
	if @_ > 4;
    return getsockopt($self,SOL_SOCKET,SO_TYPE) unless
	$self->isopen or $self->open; # generate EBADF return if not open
    $maxlen = unpack('I',getsockopt($self,SOL_SOCKET,SO_RCVBUF)) ||
	(stat $self)[11] || 8192
	    unless $maxlen;
    $flags = 0 unless defined $flags;
    if (defined($ {*$self}{sockLineBuf}) && !$flags) {
	$buf = $ {*$self}{sockLineBuf};
	if (length($buf) > $maxlen) {
	    $ {*$self}{sockLineBuf} = substr($buf, $maxlen);
	    substr($buf, $maxlen) = '';
	}
	else {
	    undef $ {*$self}{sockLineBuf};
	}
	$_[3] = $ {*$self}{lastRegFrom} if @_ > 3;
	return $buf;
    }
    $! = 0;			# ease EOF checking
    $xfrom = $from = CORE::recv($self,$buf,$maxlen,$flags);
    my $errnum = $!+0;		# preserve possible recv failure
    $xfrom = getpeername($self) if defined($from) and $from eq '';
    $from = $xfrom if defined($xfrom) and $from eq '' and $xfrom ne '';
    $ {*$self}{lastFrom} = $from;
    $_[3] = $from if @_ > 3;
    if ($flags & MSG_OOB) {
	$ {*$self}{lastOOBFrom} = $from;
    }
    else {
	$ {*$self}{lastRegFrom} = $from;
    }
    $! = $errnum;		# restore possible failure in case we return
    return undef if !defined $from and (EOF_NONBLOCK or $errnum != $eagain);
    return $buf if length $buf;
    # At this point, we had a 0-length read with no error (or EAGAIN).
    # Especially for a SOCK_STREAM connection, this may mean EOF.
    $! = $errnum;		# restore possible failure just in case
    unless ($self->ckeof) {
	return defined($from) ? $buf : undef;
    }
    $self->shutdown(SHUT_RD);	# make sure I know about this EOF
    $! = 0;			# no error for EOF
    undef;			# no buffer, either, though
}

sub get;			# (helps with -w)
*get = \&recv;			# a name that works for indirect references

#& getline($self) : like scalar(<$fhandle>)
sub getline : locked method
{
    my $whoami = $_[0]->_trace(\@_,4);
    carp "Excess arguments to ${whoami} ignored"
	if @_ > 1;
    my ($self) = @_;
    croak "Invalid arguments to ${whoami}, called"
	if !@_ or !ref($self);
    my ($rval, $buf, $tbuf);
    $buf = $ {*$self}{sockLineBuf};
    undef $ {*$self}{sockLineBuf}; # keep get from returning this again
    if (!defined($/)) {
	$rval = <$self>;	# return all of the input
	# what about non-blocking sockets here?!?
	# $self->shutdown(SHUT_RD);	# keep track of EOF
	# Above removed because ->recv does it on real EOF already.
	if (defined($buf) and defined($rval)) {
	    return $buf . $rval
	}
	if (defined($buf)) {
	    return $buf
	}
	return $rval
    }
    my $sep = $/;		# get the current separator
    $sep = "\n\n" if $sep eq ''; # account for paragraph mode
    while (!defined($buf) or $buf !~ /\Q$sep/) {
	$rval = $self->get;
	last unless defined $rval;
	if (defined $buf) {
	    $buf .= $rval;
	}
	else {
	    $buf = $rval;
	}
    }
    if (defined($buf) and ($tbuf = index($buf, $sep)) >= 0) {
	$rval = substr($buf, 0, $tbuf + length($sep));
	$tbuf = substr($buf, length($rval));
	# duplicate annoyance of paragraph mode
	$tbuf =~ s/^\n+//s if $/ eq '';
	$ {*$self}{sockLineBuf} = $tbuf if length($tbuf);
	return $rval;
    }
    else {
	return $buf;
    }
}

sub gets;			# an alias for FileHandle:: or POSIX:: compat.
*gets = \&getline;

sub DESTROY
{
    $_[0]->_trace(\@_,1);
}

#& isopen($self [, @ignored]) : boolean
sub isopen
{
    #$_[0]->_trace(\@_,4," - ".($ {*{$_[0]}}{'isopen'} ? "yes" : "no"));
    $ {*{$_[0]}}{'isopen'};
}

#& isconnected($self [, @ignored]) : boolean
sub isconnected
{
    #$_[0]->_trace(\@_,4," - ".($ {*{$_[0]}}{'isconnected'} ? "yes" : "no"));
    $ {*{$_[0]}}{'isconnected'};
}

#& isconnecting($self [, @ignored]) : boolean
sub isconnecting
{
    #$_[0]->_trace(\@_,4," - ".($ {*{$_[0]}}{'isconnecting'} ? "yes" : "no"));
    $ {*{$_[0]}}{'isconnecting'};
}

#& wasconnected($self [, @ignored]) : boolean
sub wasconnected
{
    #$_[0]->_trace(\@_,4," - ".($ {*{$_[0]}}{'wasconnected'} ? "yes" : "no"));
    $ {*{$_[0]}}{'wasconnected'};
}

#& isbound($self [, @ignored]) : boolean
sub isbound
{
    #$_[0]->_trace(\@_,4," - ".($ {*{$_[0]}}{'isbound'} ? "yes" : "no"));
    $ {*{$_[0]}}{'isbound'};
}

1;

# autoloaded methods go after the END clause (& pod) below

__END__