# 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(). #+attrs locked sub AUTOLOAD { # 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 #+attrs locked sub initsockopts { 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 #+attrs locked sub _debug { 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 #+attrs locked method sub debug { 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 #+attrs locked method sub _accessor { 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 #+attrs locked method sub blocking { 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) #+attrs locked method sub register_param_keys { 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) #+attrs locked method sub register_param_handlers { 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) #+attrs locked method sub register_options { 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 #+attrs locked method sub param_saver { 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 #+attrs locked method sub setparams { 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 #+attrs locked method sub delparams { $_[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 #+attrs locked method sub checkparams { 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 #+attrs locked method sub getparam { 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) #+attrs locked method sub getparams { 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) #+attrs locked method sub condition { 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 #+attrs locked method sub open { $_[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 #+attrs locked method sub connect { $_[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? #+attrs locked method sub getsockinfo { $_[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 #+attrs locked method sub shutdown { $_[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 #+attrs locked method sub close { $_[0]->_trace(\@_,3); my $self = shift; $self->shutdown if $self->isopen; $self->stopio; } sub CLOSE; *CLOSE = \&close; #& stopio($self [, @ignored]) : boolean #+attrs locked method sub stopio { $_[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 #+attrs locked method sub ckeof { 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} #+attrs locked method sub recv { 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>) #+attrs locked method sub getline { 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__ =head1 NAME Net::Gen - generic sockets interface handling =head1 SYNOPSIS use Net::Gen; =head1 DESCRIPTION The C module provides basic services for handling socket-based communications. It supports no particular protocol family directly, however, so it is of direct use primarily to implementors of other modules. To this end, several housekeeping functions are provided for the use of derived classes, as well as several inheritable methods. The C class does inherit from C, thus making its methods available. See L|IO::Handle/METHODS> for details on those methods. However, some of those methods are overridden, so be sure to check the methods described below to be sure. (In particular, the C and C methods are overridden.) Also provided in this distribution are L|Net::Inet>, L|Net::TCP>, L|Net::TCP::Server>, L|Net::UDP>, L|Net::UNIX>, and L|Net::UNIX::Server>, which are layered atop C. =head2 Public Methods The public methods are listed alphabetically below. Here is an indication of their functional groupings: =over 4 =item Creation and setup C, C, C, C, C, C, C, C, C =item Parameter manipulation C, C, C, C, C, C, C =item Low-level control C, C, C, C, C, C, C, C =item Medium-level control C, C, C, C =item Informational C, C, C, C, C, C, C =item I/O C, C, C, C, C, C, C, C method knows about the buffer enough to tell you that a read will succeed if there's saved data, though.) Similarly, avoid the object's C method. =item * Please don't change the state of the socket behind my back. That means no close(), shutdown(), connect(), bind(), or listen() built-ins. Use the corresponding methods instead, or all bets are off. Of course, if you're only using this module to get the connect() or bind() processing, and you're going to discard the object after you've done your I/O, then it's OK to use the built-ins for I/O. Just don't expect my code to know what you did behind my back. =back That C<$fh> is a glob ref, by the way, but that doesn't matter for calling the built-in I/O primitives. =item getline Usage: $line = $obj->getline; This is a simulation of C$filehandleE)> that doesn't let stdio confuse the C/C method. As such, its return value is not necessarily a complete line when the socket is non-blocking. =item getlines Usage: @lines = $obj->getlines; This is a lot like C<@lines = E$filehandleE>, except that it doesn't let stdio confuse the C/C method. It's unreliable on non-blocking sockets. It will produce a fatal (but trappable) error if not called in list context. (In other words, it uses the die() builtin when not called in list context.) =item getparam Usage: $value = $obj->getparam($key, $defval, $def_if_undef); $value = $obj->getparam($key, $defval); $value = $obj->getparam($key); Returns the current setting for the named parameter (in the current object), or the specified default value if the parameter is not in the object's current parameter list. If the optional C<$def_if_undef> parameter is true, then undefined values will be treated the same as non-existent keys, and thus will return the supplied default value (C<$defval>). =item getparams Usage: %hash = $obj->getparams(\@keynames, $noundefs); %hash = $obj->getparams(\@keynames); $llen = $obj->getparams(\@keynames, $noundefs); $llen = $obj->getparams(\@keynames); Returns a hash as a list (I a reference) consisting of the key-value pairs corresponding to the specified keyname list. Only those keys which exist in the current parameter list of the object will be returned. If the C<$noundefs> parameter is present and true, then existing keys with undefined values will be suppressed as with non-existent keys. If called in scalar context, returns the number of values which would have been returned in list context. (This is twice the number of key-value pairs, in case that wasn't clear.) =item getropt Usage: $optsetting = $obj->getropt($level, $option); $optsetting = $obj->getropt($optname); Returns the raw value from a call to the getsockopt() builtin. If both the C<$level> and C<$option> arguments are given as numbers, the getsockopt() call will be made even if the given socket option is not registered with the object. Otherwise, the return value for unregistered options will be undef with the value of $! set as described below for the C method. =item gets Usage: $line = $obj->gets; This is a simulation of C$filehandleE)> that doesn't let stdio confuse the C/C method. (The C method is just an alias for the C method, for partial compatibility with the POSIX module.) This method is deprecated. Use the C method by that name, instead. The C method may disappear in a future release. =item getsockinfo Usage: ($localsockaddr, $peersockaddr) = $obj->getsockinfo; $peersockaddr = $obj->getsockinfo; Attempts to determine connection parameters associated with the object. If a getsockname() call on the associated filehandle succeeds, the C object parameter is set to that returned sockaddr. If a getpeername() call on the associated filehandle succeeds, the C parameter is set to that returned sockaddr. In scalar context, if both socket addresses were found, the getpeername() value is returned, otherwise C is returned. In list context, the getsockname() and getpeername() values are returned, unless both are undefined. Derived classes normally override this method with one which provides friendlier return information appropriate to the derived class, and which establishes more of the object parameters. =item getsopt Usage: @optvals = $obj->getsopt($level, $option); @optvals = $obj->getsopt($optname); Returns the unpacked values from a call to the getsockopt() builtin. In order to do the unpacking, the socket option must have been registered with the object. See the additional discussion of socket options in L below. Since registered socket options are known by name as well as by their level and option values, it is possible to make calls using only the option name. If the name is not registered with the object, the return value is the same as that for C, which is an empty return array and $! set appropriately (should be C). Examples: ($sotype) = $obj->getsopt('SO_TYPE'); @malinger = $obj->getsopt(SOL_SOCKET, SO_LINGER); ($sodebug) = $obj->getsopt('SOL_SOCKET', 'SO_DEBUG'); =item init Usage: return undef unless $self->init; Verifies that all previous parameter assignments are valid (via C). Returns the incoming object on success, and C on failure. This method is normally called from the C method appropriate to the class of the created object. =item ioctl Usage: $rval = $obj->ioctl($func, $value); Returns the result of an ioctl() call on the associated I/O stream. =item isbound Usage: $ok = $obj->isbound; Returns true if the object's C method has been used successfully, and the binding is still in effect. If this method has not been overridden by a derived class, the value is the saved return value of the call to the bind() builtin (if it was called). =item isconnected Usage: $ok = $obj->isconnected; Returns true if the object's C method has been used successfully to establish a "session", and that session is still connected. If this method has not been overridden by a derived class, the value is the saved return value of the call to the connect() builtin (if it was called). =item isconnecting Usage: $ok = $obj->isconnecting; Returns true if the object's C method has been used with a timeout or on a non-blocking socket, and the connect() did not complete. In other words, the failure from the connect() builtin indicated that the operation was still in progress. (A rejected connection or a connection which exceeded the operating system's timeout is said to have completed unsuccessfully, rather than not to have completed.) =item isopen Usage: $ok = $obj->isopen; Returns true if the object currently has a socket attached to its associated filehandle, and false otherwise. If this method has not been overridden by a derived class, the value is the saved return value of the call to the socket() builtin (if it was called). =item listen Usage: $ok = $obj->listen($maxqueue); $ok = $obj->listen; Makes a call to the listen() builtin on the filehandle associated with the object. Propagates the return value from listen(). If the C<$maxqueue> parameter is missing, it defaults to the value of the object's I parameter, or the value of C. If the C constant is not available in your configuration, the default value used for the C method is 5. This method will fail if the object is not bound and cannot be made bound by a simple call to its C method. =item new Usage: $obj = $classname->new(); $obj = $classname->new(\%parameters); Returns a newly-initialised object of the given class. If called for a class other than C, no validation of the supplied parameters will be performed. (This is so that the derived class can add the parameter validation it needs to the object before allowing validation.) =item new_from_fd =item new_from_fh Usage: $obj = $classname->new_from_fh(*FH); $obj = $classname->new_from_fh(\*FH); $obj = $classname->new_from_fd(fileno($fh)); Returns a newly-initialised object of the given class, open on a newly-dup()ed copy of the given filehandle or file descriptor. As many of the standard object parameters as possible will be determined from the passed filehandle. This is determined (in part) by calling the corresponding C, C, and C methods for the new object. Only real filehandles or file descriptor numbers are allowed as arguments. This method makes no attempt to resolve filehandle names. Yes, despite having two names, there's really just one method. =item open Usage: $ok = $obj->open; Makes a call to the socket() builtin, using the current object parameters to determine the desired protocol family, socket type, and protocol number. If the object was already open, its C method will be called before socket() is called again. The object parameters consulted (and possibly updated) are C, C, C, C, and C. Returns true if the socket() call results in an open filehandle, C otherwise. =item param_saver =item paramSaver Usage: my $savedstuff = $obj->param_saver(@param_names); my $savedstuff = $obj->paramSaver(@param_names); Saves the values (or lack thereof) for the indicated parameter names by wrapping them (and the original object) in an object blessed into an alternate package. When this `saver' object is destroyed (typically because the `my' variable went out of scope), the previous values of the parameters for the original object will be restored. This allows for temporary changes to an object's parameter settings without the worry of whether an inopportune die() will prevent the restoration of the original settings. An example (from the C method): my $saveblocking = $self->param_saver('blocking'); (This is used when there is a C parameter for the object.) =item print =item PRINT See L for details, as this method is just an alias for the C method. The C alias is for the support of tied filehandles. =item PRINTF Usage: $ok = $obj->PRINTF($format, @args); $ok = printf TIEDFH $format, @args; This method uses the sprintf() builtin and the C method to send the @args values to the filehandle associated with the object, using the $format format string. It exists for the support of tied filehandles. =item put Usage: $ok = $obj->put(@whatever); $ok = put $obj @whatever; This method uses the print() builtin to send the @whatever arguments to the filehandle associated with the object. That filehandle is always marked for autoflushing by the C method, so the method is in effect equivalent to this: $ok = $obj->send(join($, , @whatever) . $\ , 0); However, since multiple fwrite() calls are sometimes involved in the actual use of print(), this method can be more efficient than the above code sample for large strings in the argument list. It's a bad idea except on stream sockets (C) though, since the record boundaries are unpredictable through C. It's also a bad idea on non-blocking sockets, since the amount of data actually written to the socket is unknown. This method makes no attempt to trap C. =item READ Usage: $numread = $obj->READ($buffer, $maxlen); $numread = $obj->READ($buffer, $maxlen, $offset); $numread = read(TIEDFH, $buffer, $maxlen); $numread = read(TIEDFH, $buffer, $maxlen, $offset); This method uses the C method (with a flags argument of 0) to emulate the read() and sysread() builtins. This is specifically for the support of tied filehandles. Like the emulated builtins, this method returns the number of bytes successfully read, or undef on error. =item READLINE Usage: $line = $obj->READLINE; @lines = $obj->READLINE; $line = readline(TIEDFH); # or $line = ; @lines = readline(TIEDFH); # or @lines = ; This method supports the use of the EE (or readline()) operator on tied filehandles. In scalar context, it uses the C method. In list context, it reads all remaining input on the socket (until eof, which makes this unsuitable for connectionless socket types such as UDP), and splits it into lines based on the current value of the $/ variable. The return value is unreliable for non-blocking sockets. =item RECV Usage: $from = $obj->RECV($buffer, $maxlen, $flags); $from = $obj->RECV($buffer, $maxlen); $from = $obj->RECV($buffer); This method calls the recv() method with the arguments and return rearranged to match the recv() builtin. This is for the support of tied filehandles. =item recv Usage: $record = $obj->recv($maxlen, $flags, $whence); $record = $obj->recv($maxlen, $flags); $record = $obj->recv($maxlen); $record = $obj->recv; This method calls the recv() builtin, and returns a buffer (if one is received) or C on eof or error. If an eof is seen on the socket (as checked with its C method), then $! will be 0 on return. If the C<$whence> argument is supplied, it will be filled in with the sending socket address if possible. If the C<$flags> argument is not supplied, it defaults to 0. If the C<$maxlen> argument is not supplied, it is defaulted to the receive buffer size of the associated filehandle (if known), or the preferred blocksize of the associated filehandle (if known, which it usually won't be), or 8192. =item select Usage: ($nfound, $timeleft, $rbool, $wbool, $xbool) = $obj->select($doread, $dowrite, $doxcept, $timeout); $nfound = $obj->select($doread, $dowrite, $doxcept, $timeout); Issues a 4-argument select() call for the associated I/O stream. All arguments are optional. The $timeout argument is the same as the fourth argument to the select() builtin. The first three are booleans, used to determine whether the method should include the object's I/O stream in the corresponding parameter to the select() call. The return in list context is the standard two values from select(), follwed by booleans indicating whether the actual select() call found reading, writing, or exception to be true. In scalar context, the routine returns only the count of the number of matching conditions. This is probably only useful when you're checking just one of the three possible conditions. =item SEND =item send Usage: $ok = $obj->send($buffer, $flags, $destsockaddr); $ok = $obj->send($buffer, $flags); $ok = $obj->send($buffer); This method calls the send() builtin (three- or four-argument form). The C<$flags> parameter is defaulted to 0 if not supplied. If the C<$destsockaddr> value is missing or undefined, and the socket is connected (C<$obj-Eisconnected> returns true), then the three-argument form of the send() builtin will be used. Otherwise, the C<$destsockaddr> parameter will be defaulted from the last recv() peer address for the same kind of message (depending on whether C is set in the C<$flags> parameter). A defined C<$destsockaddr> will result in a four-argument send() call. The return value from the send() builtin is returned. This method makes no attempt to trap C. =item sendto Usage: $ok = $obj->sendto($buffer, $destsockaddr, $flags); $ok = $obj->sendto($buffer, $destsockaddr); This method calls the send() builtin (four-argument form). The C<$flags> parameter is defaulted to 0 if not supplied. The return value from the send() builtin is returned. This method makes no attempt to trap C. =item setparam Usage: $ok = $obj->setparam($key, $value, $newonly, $checkup); $ok = $obj->setparam($key, $value, $newonly); $ok = $obj->setparam($key, $value); Sets a single new parameter. Uses the C method, and has the same rules for the handling of the C<$newonly> and C<$checkup> parameters. Returns 1 if the set was successful, and C otherwise. =item setparams Usage: $ok = $obj->setparams(\%newparams, $newonly, $checkup); $ok = $obj->setparams(\%newparams, $newonly); $ok = $obj->setparams(\%newparams); Sets new parameters from the given hashref, with validation. This is done in a loop over the I pairs from the C parameter. The precise nature of the validation depends on the C<$newonly> and C<$checkup> parameters (which are optional), but in all cases the keys to be set are checked against those registered with the object. If the C<$newonly> parameter is negative, the value from the hashref will only be set if there is not already a defined value associated with that key, but the skipping of the setting of the value is silent. If the C<$newonly> parameter is not negative or if there is no existing defined value, if the C<$checkup> parameter is false then the setting of the new value is skipped if the new value is identical to the old value. If those checks don't cause the setting of a new value to be skipped, then if the C<$newonly> parameter is positive and there is already a defined value for the specified key, a warning will be issued and the new value will not be set. If none of the above checks cause the setting of a new value to be skipped, but if the specified key has a validation routine, that routine will be called with the given object, the current key, and the proposed new value as parameters. It is allowed for the validation routine to alter the new-value argument to change what will be set. (This is useful when changing a hostname to be in canonical form, for example.) If the validation routine returns a non-null string, that will be used to issue a warning, and the new value will not be set. If the validation routine returns a null string (or if there is no validation routine), the new value will (finally) get set for the given key. The C method returns 1 if all parameters were successfully set, and C otherwise. =item setropt Usage: $ok = $obj->setropt($level, $option, $rawvalue); $ok = $obj->setropt($optname, $rawvalue); Returns the result from a call to the setsockopt() builtin. If the $level and $option arguments are both given as numbers, the setsockopt() call will be made even if the option is not registered with the object. Otherwise, unregistered options will fail as for the C method, below. =item setsopt Usage: $ok = $obj->setsopt($level, $option, @optvalues); $ok = $obj->setsopt($optname, @optvalues); Returns the result from a call to the setsockopt() builtin. In order to be able to pack the C<@optvalues>, the option must be registered with the object, just as described in L above. =item shutdown Usage: $ok = $obj->shutdown($how); $ok = $obj->shutdown; Calls the shutdown() builtin on the filehandle associated with the object. This method is a no-op, returning 1, if the filehandle is not connected. The C<$how> parameter is as per the shutdown() builtin, which in turn should be as described in the shutdown(2) manpage. If the C<$how> parameter is not present, it is assumed to be C (which is 2 on most UNIX systems). Returns 1 if it has nothing to do, otherwise propagates the return from the shutdown() builtin. =item stopio Usage: $ok = $obj->stopio; Calls the close() builtin on the filehandle associated with the object, unless that filehandle is already closed. Returns 1 or the return value from the close() builtin. This method is primarily for the use of server modules which need to avoid C calls at inappropriate times. This method calls the C method for the keys of C and C. =item STORE Usage: $TIED_SCALAR = $data; Provided for the support of tied scalars. Results in a call to the C method, unless there's exactly one arg and it's C. In that case, since this normally results from C, it's ignored. =item TIEHANDLE Usage: tie *FH, $package, @options or die; print FH $out_data; print $in_data while defined($in_data = ); untie *FH; Tieing of a filehandle to a network handle is supported by this base However, this method only succeeds if the related call to the C method returns an object for which the C method returns true. Thus, the most useful example is in L|Net::UDP/"TIEHANDLE support">. =item TIESCALAR Usage: tie $x, $package, @options or die; $x = $out_data; print $in_data while defined($in_data = $x); untie $x; Tieing of scalars to a network handle is supported by this base class. However, this method only succeeds if the related call to the C method returns an object for which the C method returns true. Thus, the useful examples are in L|Net::TCP/TIESCALAR> and L|Net::UDP/"TIESCALAR support">. =item unbind Usage: $obj->unbind; Removes any saved binding for the object. Unless the object is currently connected, this will result in a call to its C method, in order to ensure that any previous binding is removed. Even if the object is connected, the C object parameter is removed (via the object's C method). The return value from this method is indeterminate. =item wasconnected Usage: $was = $obj->wasconnected; Returns true if the object has had a successful connect() completion since it was last opened. Returns false after a close() or on a new object. Also returns true if C<$obj-Eisconnecting> is true. =item WRITE Usage: $nwritten = $obj->WRITE($buf, $len); $nwritten = $obj->WRITE($buf, $len, $offset); $nwritten = syswrite(TIEDFH, $buf, $len); $nwritten = syswrite(TIEDFH, $buf, $len, $offset); This method exists for support of syswrite() on tied filehandles. It calls the syswrite() builtin on the underlying filehandle with the same parameters. =back =head2 Protected Methods Yes, I know that Perl doesn't really have protected methods as such. However, these are the methods which are only useful for implementing derived classes, and not for the general user. =over 4 =item ckeof Usage: $wasiteof = $obj->ckeof; After a 0-length read in the get() routine, it calls this method to determine whether such a 0-length read meant EOF. The default method supplied here checks for non-blocking sockets (if necessary), and for a C socket. If EOF_NONBLOCK is true, or if the C flag was not set in the fcntl() flags for the socket, or if the error code was not VAL_EAGAIN, I the socket is of type C, then this method returns true. It returns a false value otherwise. This method is overridable for classes like C, which support C and need to make a protocol-family-specific check to tell a 0-length packet from EOF. =item initsockopts Usage: $classname->initsockopts($level, \%optiondesc); Given a prototype optiondesc hash ref, updates it to include all the data needed for the values it can find, and deletes the ones it can't. For example, here's a single entry from such a prototype optiondesc: 'SO_LINGER' => ['II'], Given that, and the $level of C, and the incoming class name of C, C will attempt to evaluate C in package C, and if it succeeds it will fill out the rest of the information in the associated array ref, and add another key to the hash ref for the value of C (which is 128 on my system). If it can't evaluate that psuedo-constant, it will simply delete that entry from the referenced hash. Assuming a successful evaluation of this entry, the resulting entries would look like this: 'SO_LINGER' => ['II', SO_LINGER+0, SOL_SOCKET+0, 2], SO_LINGER+0 => ['II', SO_LINGER+0, SOL_SOCKET+0, 2], (All right, so the expressions would be known values, but maybe you get the idea.) A completed optiondesc hash is a set of key-value pairs where the value is an array ref with the following elements: [pack template, option value, option level, pack array len] Such a completed optiondesc is one of the required arguments to the C method (see below). =item register_options =item registerOptions Usage: $obj->register_options($levelname, $level, \%optiondesc); This method attaches the socket options specified by the given option descriptions hash ref and the given level (as text and as a number) to the object. The registered set of socket options is in fact a hashref of hashrefs, where the keys are the level names and level numbers, and the values are the optiondesc hash refs which get registered. Example: $self->register_options('SOL_SOCKET', SOL_SOCKET+0, \%sockopts); =item register_param_handlers =item registerParamHandlers Usage: $obj->register_param_handlers(\@keynames, \@keyhandlers); $obj->register_param_handlers(\%key_handler_pairs); This method registers the referenced keynames (if they haven't already been registered), and establishes the referenced keyhandlers as validation routines for those keynames. Each element of the keyhandlers array must be a code reference. When the C method invokes the handler, it will be called with three arguments: the target object, the keyname in question, and the proposed new value (which may be C, especially if being called from the C method). See the other discussion of validation routines in the C method description, above. =item register_param_keys =item registerParamKeys Usage: $obj->register_param_keys(\@keynames); This method registers the referenced keynames as valid parameters for C and the like for this object. The C methods can store arbitrary parameter values, but the C method will later ensure that all those keys eventually got registered. This out-of-order setup is allowed because of possible cross-dependencies between the various parameters, so they have to be set before they can be validated (in some cases). =item _accessor Usage: $value = $obj->_accessor($what); $oldvalue = $obj->_accessor($what, $newvalue); This method implements the use of the known parameter keys as get/set methods. It's used by the customised AUTOLOAD to generate such accessor functions as they're referenced. See L<"blocking"> above for an example. =back =head2 Known Socket Options These are the socket options known to the C module itself: =over 4 =item Z<> C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C =back =head2 Known Object Parameters These are the object parameters registered by the C module itself: =over 4 =item AF Address family (will default from PF, and vice versa). =item blocking Set to 0 when a socket has been marked as non-blocking, and to 1 otherwise. If it's C, it'll be treated as though it were set to 1. The use of anything which even looks like C calls on non-blocking sockets as at your own risk. If you don't know how to work with non-blocking sockets already, the results of trying them may surprise you. =item dstaddr The result of getpeername(), or an ephemeral proposed connect() address. =item dstaddrlist A reference to an array of socket addresses to try for connect(). =item maxqueue An override of the default maximum queue depth parameter for listen(). This will be used if the $maxqueue argument to listen() is not supplied. =item netgen_fakeconnect This parameter is set true to keep the C method from really calling the connect() built-in if the socket has not had an source address specified and it is not bound. This is used by the L and L modules to keep from exercising a bug in some socket implementations with respect to how datagram sockets are handled. (This was specifically done in response to quirks of Solaris 2.5.1.) Instead, the C method simply sets the C object parameter, which the C method will respect. =item PF Protocol family for this object. Will default from AF, and vice versa. =item proto The protocol to pass to the socket() call (often defaulted to 0). =item reuseaddr A boolean, indicating whether the C method should do a setsockopt() call to set C to 1. =item reuseport A boolean, indicating whether the C method should do a setsockopt() call to set C to 1. =item srcaddr The result of getsockname(), or an ephemeral proposed bind() address. =item srcaddrlist A reference to an array of socket addresses to try for bind(). =item timeout The maximum time to wait for connect() or accept() attempts to succeed. See the discussion of timeouts and non-blocking sockets in L above. =item type The socket type to create (C, C, etc.) =back =head2 Non-Method Subroutines =over 4 =item pack_sockaddr Usage: $connect_address = pack_sockaddr($family, $fam_addr); Returns a packed C corresponding to the provided $family (which must be a number) and the address-family-specific $fam_addr (pre-packed). =item unpack_sockaddr Usage: ($family, $fam_addr) = unpack_sockaddr($packed_address); The inverse of pack_sockaddr(). =item E* Various socket-related C values. See L<":errnos"> for the list. These routines will always be defined, but they will return 0 if the corresponding error symbol was not found on your system. =item EOF_NONBLOCK Returns a boolean value depending on whether a read from a non-blocking socket can distinguish an end-of-file condition from a no-data-available condition. This corresponds to the value available from the C module as C<$Config::Config{'d_eofnblk'}>), except that C is always defined. =item RD_NODATA Gives the integer return value found by the F script for a read() system call on a non-blocking socket which has no data available. This is similar to the string representation of the value available from the C module as C<$Config::Config{'rd_nodata'}>. =item VAL_EAGAIN Gives the value of the error symbol found by the F script which is set by a non-blocking filehandle when no data is available. This differs from the value available from the C module (C<$Config::Config{'eagain'}>) in that the latter is a string, typically C<"EAGAIN">. =item VAL_O_NONBLOCK Gives the value found by the F script for setting a filehandle non-blocking. The value available from the C module is a string representing the value found (C<$Config::Config{'o_nonblock'}>), whereas the value from C is an integer, suitable for passing to sysopen() or for eventual use in fcntl(). =back =head2 Exports =over 4 =item default None. =item exportable C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C =item tags The following I<:tags> are available for grouping exported items together: =over 6 =item :af C C C C C C C C C C C C C C C C C C C C C C C C C C C =item :errnos C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C =item :families The union of the C<:af> and C<:pf> tags. =item :NonBlockVals =item :non_block_vals C C C C =item :pf C C C C C C C C C C C C C C C C C C C C C C C C C C C =item :routines C C =item :shutflags C C C =item :sockopts C C C C C C C C C C C C C C C C C C C C C C C =item :sockvals C C C C C C =item :ALL All of the above. =back Z<> =back =head1 THREADING STATUS This module has been tested with threaded perls, and should be as thread-safe as perl itself. (As of 5.005_03 and 5.005_57, that's not all that safe just yet.) It also works with interpreter-based threads ('ithreads') in more recent perl releases. =head1 SEE ALSO L, L, Net::Dnet(3) =head1 AUTHOR Spider Boardman Espidb@cpan.orgE =cut #other sections should be added, sigh. #any real autoloaded methods go after this line #& setdebug($this, [bool, [norecurse]]) : previous sub setdebug { $_[0]->_debug($_[1]); } # fluff routine to make things easy #& setparam($self, $name, $value, [newonly, [docheck]]) : boolean sub setparam { my $whoami = $_[0]->_trace(\@_,1); my($self,$key,$val,$newonly,$docheck) = @_; carp "Excess arguments to ${whoami} ignored" if @_ > 5; croak "Invalid arguments to ${whoami}, called" if @_ < 3 or not ref $self or not exists $ {*$self}{Keys}{$key}; $self->setparams({$key => $val}, $newonly, $docheck); } #& bind($self [, @ignored]) : boolean #+attrs locked method sub bind { $_[0]->_trace(\@_,2); my $self = shift; $self->close if $self->wasconnected || $self->isconnected || $self->isconnecting || $self->isbound; return $ {*$self}{'isbound'} = undef unless $self->isopen or $self->open; $self->setsopt('SO_REUSEADDR', 1) if $ {*$self}{Parms}{reuseaddr}; $self->setsopt('SO_REUSEPORT', 1) if $ {*$self}{Parms}{reuseport}; my $rval; if ($ {*$self}{Parms}{srcaddrlist}) { my $tryaddr; foreach $tryaddr (@{$ {*$self}{Parms}{srcaddrlist}}) { next unless $rval = CORE::bind($self, $tryaddr); $ {*$self}{Parms}{srcaddr} = $tryaddr; last; } } elsif (defined($ {*$self}{Parms}{srcaddr}) and length $ {*$self}{Parms}{srcaddr}) { $rval = CORE::bind($self, $ {*$self}{Parms}{srcaddr}); } else { $rval = CORE::bind($self, pack_sockaddr($ {*$self}{Parms}{AF},'')); } $ {*$self}{'isbound'} = $rval; return $rval unless $rval; $self->getsockinfo; $self->isbound; } #& unbind($self [, @ignored]) #+attrs locked method sub unbind { $_[0]->_trace(\@_,2); my($self) = @_; $self->close unless $self->isconnected || $self->isconnecting; $self->delparams([qw(srcaddrlist)]); } #& delparam($self, @paramnames) : boolean sub delparam { my ($self,@keys) = @_; $self->delparams(\@keys); } #& listen($self [, $maxq=SOMAXCONN]) : boolean #+attrs locked method sub listen { my $whoami = $_[0]->_trace(\@_,2); my ($self,$maxq) = @_; $maxq = $self->getparam('maxqueue',SOMAXCONN,1) unless defined $maxq; croak "Invalid args for ${whoami}(@_), called" if $maxq =~ /\D/ or !ref $self; carp "Excess args for ${whoami}(@_) ignored" if @_ > 2; return undef unless $self->isbound or $self->bind; $ {*$self}{'didlisten'} = $maxq; CORE::listen($self,$maxq) or undef $ {*$self}{'didlisten'}; } #& didlisten($self [, @ignored]) : boolean sub didlisten { #$_[0]->_trace(\@_,4," - ".($ {*{$_[0]}}{'didlisten'} ? "yes" : "no")); $ {*{$_[0]}}{'didlisten'}; } sub TIESCALAR { $_[0]->_trace(\@_,2); my $class = shift; my $self = $class->new(@_); $self && $self->isconnected && $self; } #+attrs locked method sub FETCH { $_[0]->_trace(\@_,2); scalar $_[0]->READLINE; } #+attrs locked method sub STORE { $_[0]->_trace(\@_,2); my $self = shift; return if @_ == 1 and !defined $_[0]; # "undef $x" $self->put(@_); } # socket-option routines #& _findxopt($self, $realp, @args) : ($aref,@subargs) sub _findxopt { my($self,$realp,@args) = @_; my($aref,$level,$what); $level = shift @args; # try input arg as level first if ($level =~ /^(0x[\da-f]+|0[0-7]*|[1-9]\d*)$/si) { # if numeric, it had better be the level $level = ((substr($level, 0, 1) eq '0') ? oct($level) : $level+0); } $aref = $ {*$self}{Sockopts}{$level}; if (!$aref) { # here, we have to search for the ruddy thing by keyword # if level was numeric, punt by trying to force EINVAL until ($level =~ /\D/) { # numeric level, check for realp and numeric what last unless $realp; $what = shift @args; last unless $what =~ /^(0x[\da-f]+|0[0-7]*|[1-9]\d*)$/si; $what = ((substr($what, 0, 1) eq '0') ? oct($what) : $what+0); $aref = ['h*', $what, $level, 0+@args]; return ($aref,@args); } return getsockopt($self,-1,-1) unless $level =~ /\D/; $what = $level; foreach $level (keys %{$ {*$self}{Sockopts}}) { next unless ref($ {*$self}{Sockopts}{$level}) eq 'HASH'; last if $aref = $ {*$self}{Sockopts}{$level}{$what}; } $ {*$self}{Sockopts}{$what} = $aref if ref $aref eq 'ARRAY'; } elsif (ref $aref eq 'HASH') { $what = shift @args; if ($what =~ /^(0x[\da-f]+|0[0-7]*|[1-9]\d*)$/si) { $what = ((substr($what, 0, 1) eq '0') ? oct($what) : $what+0); } $aref = $$aref{$what}; } # force EINVAL (I hope) if unrecognized value return getsockopt($self,-1,-1) unless ref $aref eq 'ARRAY'; ($aref,@args); } #& _getxopt($this, $realp, [$level,] $what) : @values #+attrs locked method sub _getxopt { my($self,$realp,@args) = @_; my($aref,$level,$what,$rval,$format); @args = $self->_findxopt($realp, @args); # get the array ref return unless $aref = shift @args; carp "Excess args to getsockopt ignored" if @args; $what = $$aref[1]; $level = $$aref[2]; $format = $$aref[0]; $rval = getsockopt($self,$level+0,$what+0); if ($self->debug > 3) { @args = unpack($format,$rval) if defined $rval; print STDERR " - getsockopt $self,$level,$what => "; print STDERR (defined $rval ? "@args\n" : "(undef)\n"); } return $rval if $realp; return () unless defined $rval; unpack($format,$rval); } #& getsopt($this, [$level,] $what) : @values sub getsopt { my($self,@args) = @_; $self->_getxopt(0,@args); } #& getropt($this, [$level,] $what) : $value sub getropt { my($self,@args) = @_; $self->_getxopt(1,@args); } #& _setxopt($this, $realp, [$level,] $what, @vals) : boolean #+attrs locked method sub _setxopt { my($self,$realp,@args) = @_; my($aref,$level,$what,$rval,$format); @args = $self->_findxopt($realp, @args); # get the array ref and real args return undef unless $aref = shift @args; $what = $$aref[1]; $level = $$aref[2]; $format = $$aref[0]; if ($realp) { $rval = shift @args; } else { $rval = pack($format, @args); carp "Excess args to " . join('::',(caller(0))[0,3]) . " ignored" if @args > $$aref[3]; $rval = undef if !length($rval) and !$$aref[3]; } print STDERR " - setsockopt $self,$level,$what,", join($",unpack($format,$rval)),"\n" if $self->debug > 3; setsockopt($self,$level+0,$what+0,$rval); } #& setsopt($this, [$level,] $what, @vals) : boolean sub setsopt { $_[0]->_trace(\@_,2); my($self,@args) = @_; $self->_setxopt(0,@args); } #& setropt($this, [$level,] $what, $realvalue) : boolean sub setropt { $_[0]->_trace(\@_,2); my($self,@args) = @_; $self->_setxopt(1,@args); } #& BINMODE($this) #+attrs locked method sub BINMODE { # Need to allow for PerlIO layers here @_ > 1 ? binmode($_[0], $_[1]) : 1; } #& FILENO($this) : {$int | undef} sub FILENO { # $_[0]->_trace(\@_,4); CORE::fileno($_[0]); } #& fileno($this) : {$int | undef} sub fileno { # $_[0]->_trace(\@_,4); CORE::fileno($_[0]); } #& getfh($this) : {$gvref | undef} sub getfh { # $_[0]->_trace(\@_,4); $_[0]; } #& fhvec($this) : {$fhvec | undef} sub fhvec { $_[0]->_trace(\@_,4); my($self) = @_; return getsockopt($self,SOL_SOCKET,SO_TYPE) unless $self->isopen and defined(CORE::fileno($self)); # return EBADF unless open $ {*$self}{FHVec}; # already setup by condition() } #& select($this [[, $read, $write, $xcept, $timeout]]) : $nready | @list #+attrs locked method sub select { $_[0]->_trace(\@_,4); my($self,$doread,$dowrite,$doxcept,$timer) = @_; my($fhvec,$rvec,$wvec,$xvec,$nfound,$timeleft) = $self->fhvec; return unless $fhvec; $rvec = $doread ? $fhvec : undef; $wvec = $dowrite ? $fhvec : undef; $xvec = $doxcept ? $fhvec : undef; $timer = 0 if $doread and defined($ {*$self}{sockLineBuf}); ($nfound, $timeleft) = CORE::select($rvec, $wvec, $xvec, $timer) or return (); if (defined($ {*$self}{sockLineBuf}) && $doread && ($rvec ne $fhvec)) { $nfound++; $rvec |= $fhvec; } wantarray ? ($nfound, $timeleft, $doread && $rvec eq $fhvec, $dowrite && $wvec eq $fhvec, $doxcept && $xvec eq $fhvec) : $nfound; } #& ioctl($this, @args) : $scalar #+attrs locked method sub ioctl { my $whoami = $_[0]->_trace(\@_,4); croak "Insufficient arguments to ${whoami}(@_), found" if @_ < 3; carp "Excess arguments to ${whoami} ignored" if @_ > 3; CORE::ioctl($_[0], $_[1], $_[2]); } #& fcntl($this, @args) : $scalar #+attrs locked method sub fcntl { my $whoami = $_[0]->_trace(\@_,4); croak "Insufficient arguments to ${whoami}(@_), found" if @_ < 3; carp "Excess arguments to ${whoami} ignored" if @_ > 3; CORE::fcntl($_[0], $_[1], $_[2]); } #& format_addr($thunk, $sockaddr) : {$string | undef} sub format_addr { return undef unless defined $_[1]; my($rval,$fam,$addr); ($fam,$addr) = unpack_sockaddr($_[1]) or return undef; $rval = "[${fam}]:"; if (defined($addr) and length($addr)) { $rval .= "0x" . unpack('h*', $addr); } else { $rval .= "(null)"; } $rval; } #& format_local_addr($this, [@args]) : {$string | undef} sub format_local_addr { my($self,@args) = @_; $self->format_addr($self->getparam('srcaddr'),@args); } #& format_remote_addr($this, [@args]) : {$string | undef} sub format_remote_addr { my($self,@args) = @_; $self->format_addr($self->getparam('dstaddr'),@args); } #& new_from_fh(classname, $filehandle) : {$obj | undef} sub new_from_fh { my $whoami = $_[0]->_trace(\@_,2); my($pack) = @_; if (@_ != 2) { croak "Invalid number of arguments to ${whoami}, called"; } my ($fh,$rfh); eval {local $SIG{__DIE__}; local $SIG{__WARN__}; $fh=CORE::fileno($_[1])}; unless(defined $fh) { if ($_[1] =~ /\D/ or !length($_[1])) { croak "Invalid filehandle '$_[1]' in ${whoami}, called"; } $fh = 0 + $_[1]; } my $self = $pack->new(); return undef unless $self; unless (CORE::open($self, "+<&$fh")) { { local $!; undef $self; undef $self; } return $self; } $ {*$self}{'isopen'} = 1; $ {*$self}{'isconnected'} = 1 if getpeername($self); $rfh = getsockname($self); if (defined $rfh and length $rfh) { ($fh, $rfh) = unpack_sockaddr($rfh); $ {*$self}{AF} = $fh if defined $fh and length $fh and $fh ne '0'; $ {*$self}{'isbound'} = defined $rfh and $rfh =~ /[^\0]/; } ($rfh) = $self->getsopt('SO_TYPE'); $ {*$self}{type} = $rfh if defined $rfh; $self->getsockinfo; $self->isopen && $self; } #& accept($self) : {$new_obj | undef} sub accept { my $whoami = $_[0]->_trace(\@_,2); my($self) = @_; carp "Excess args to ${whoami}(@_) ignored" if @_ > 1; return undef unless $self->didlisten or $self->listen; my $ns = $self->new; return undef unless $ns; $ns->stopio; # make sure we can use the filehandle $ {*$ns}{Parms} = { %{$ {*$self}{Parms}} }; $ns->checkparams; { my ($timeout,$fhvec,$saveblocking) = ($ {*$self}{Parms}{'timeout'}, $ {*$self}{FHVec}); if (defined $timeout and $ {*$self}{Parms}{'blocking'}) { $saveblocking = $self->param_saver('blocking'); $self->setparams({'blocking'=>0}); my $nfound = CORE::select($fhvec, undef, undef, $timeout); } unless (CORE::accept($ns, $self)) { { local $!; undef $ns; undef $ns; } return $ns; } } $ {*$ns}{'isopen'} = $ {*$ns}{'isbound'} = $ {*$ns}{'isconnected'} = 1; $ns->getsockinfo; unless ($ns->isconnected) { { local $!; undef $ns; undef $ns; } return $ns; } $ns->condition; $ns; } #& RECV($self, $buf [,$maxlen] [,$flags]) : {$from | undef} sub RECV { my ($from,$buf); my $whoami = $_[0]->_trace(\@_,5); croak "Invalid arguments to ${whoami}, called" if @_ < 2 or @_ > 4 or !ref($_[0]); $buf = $_[0]->recv($_[2], $_[3], $from); return undef unless defined $buf; $_[1] = $buf; $from; } #& TIEHANDLE($class, $host, $port [,\%options]) : {$new_obj | undef} sub TIEHANDLE { # redirects via $class->new(...) $_[0]->_trace(\@_,1); my $class = shift; my $self; if (ref $class and defined fileno($class)) { if ($class->isa(__PACKAGE__)) { $self = $class->new_from_fh(@_) || $class->new(@_); } else { $self = new_from_fh($class,@_) || new($class,@_); } } else { $self = $class->new(@_); $self && $self->isconnected && $self; } } #& PRINTF($self, $format [,@args]) : boolean sub PRINTF { $_[0]->_trace(\@_,5); my $self = shift; my $fmt = shift; local $\ = ''; # currently not per-file $self->PRINT(sprintf $fmt,@_); } #& READ($self, $buffer, $length [,$offset]) : {$lenread | undef} sub READ { my $whoami = $_[0]->_trace(\@_,5); croak "Invalid args to ${whoami}, called" if @_ < 3 or @_ > 4 or !ref($_[0]); my $len = $_[2]+0; croak "Negative buffer length in ${whoami}, called" if $len < 0; if (@_ > 3) { $_[3] += 0; # force offset to be numeric croak "Buffer offset outside buffer contents in ${whoami}, called" if ($_[3] < 0 and $_[3]+length($_[1]) < 0); } my $buf = $_[0]->recv($len, 0); $_[1] = '' unless defined $_[1]; unless (defined $buf) { return undef if $!; return 0; } my $xbuf; $len -= length($buf); while ($len > 0) { # keep trying to fill the specified length $xbuf = $_[0]->recv($len, 0); last unless defined $xbuf; $buf .= $xbuf; $len -= length($xbuf); } if (@_ > 3) { substr($_[1], $_[3]) = $buf; } else { $_[1] = $buf; } length($buf); } #& GETC($self) : {$charstr | undef} sub GETC { my $whoami = $_[0]->_trace(\@_,6); carp "Excess arguments to ${whoami} ignored" if @_ > 1; $_[0]->recv(1,0); } #& READLINE($self) : {$line | undef || @lines} sub READLINE { return $_[0]->getline unless wantarray and defined($/); my $whoami = $_[0]->_trace(\@_,5); my $self = shift; my (@lines, $line); carp "Excess arguments to ${whoami} ignored" if @_; while (defined($line = $self->getline)) { push(@lines, $line) } @lines; } #& getlines($self) : @lines sub getlines { my $whoami = $_[0]->_trace(\@_,6); croak "Invalid call to $whoami" unless @_ == 1; croak "Not in list context calling $whoami" unless wantarray; $_[0]->READLINE; } #& sendto($self, $buf, $where, [$flags]) : boolean sub sendto { my $whoami = $_[0]->_trace(\@_,3); my($self,$buf,$whither,$flags) = @_; croak "Invalid args to ${whoami}, called" if @_ < 3 or !ref $self; $flags = 0 unless defined $flags; 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 if ($ {*$self}{Parms}{netgen_fakeconnect}) { return $self->send($buf,$flags,$whither); } CORE::send($self, $buf, $flags, $whither); } #& EOF($self) : boolean sub EOF { my $whoami = $_[0]->_trace(\@_,3); my ($self,$buf) = @_; croak "Invalid args to ${whoami}, called" if @_ != 1 or !ref $self; return getsockopt($self,SOL_SOCKET,SO_TYPE) unless $self->isopen; # generate EBADF return if not open return 0 if defined $ {*$self}{sockLineBuf}; # not EOF if can read my $fhvec = $ {*$self}{FHVec}; my $nfound = CORE::select($fhvec, undef, undef, 0); return 0 unless $nfound; $buf = $self->recv; return 1 if ! $! and !defined $buf; $ {*$self}{sockLineBuf} = $buf; 0; } #& WRITE($self,$buffer,$len[,$offset]) : {$length | undef} sub WRITE { my $whoami = $_[0]->_trace(\@_,3); my ($self,$buf,$len,$offset,$blen) = @_; croak "Invalid args to ${whoami}, called" if @_ < 2 or @_ > 4 or !ref $self; $offset = 0 if @_ == 3; $blen = length $buf; $len = $blen unless defined $len; if ($offset < 0) { $offset += $blen; croak "Offset outside of string in ${whoami}, called" if $offset < 0; } croak "Offset outside of string in ${whoami}, called" if $offset > $blen; return getsockopt($self,SOL_SOCKET,SO_TYPE) unless $self->isopen; # generate EBADF return if not open $len = $blen - $offset if $len > $blen - $offset; syswrite($self, $buf, $len, $offset); }