# Copyright 1995,1999 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. package Net::Gen; use 5.004_05; # 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 = '0.91'; } sub Version () { __PACKAGE__ . " v$VERSION" } use Socket qw(!/pack_sockaddr/ !/^MSG_OOB$/ !SOMAXCONN); 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 SOMAXCONN 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 ); %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)], ALL => [@EXPORT, @EXPORT_OK], ); } my %loaded; 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 { # 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'; 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); require Carp; Carp::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. # 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; } # 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 sub initsockopts # $class, $level+0, \%sockopts { use attrs '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. $evalopts{$class} ||= eval "package $class; no strict 'refs';" . 'sub ($) {local($SIG{__WARN__})=$nullwarn;local($SIG{__DIE__});' . '&{$_[0]}()}'; $esub = $evalopts{$class}; foreach $opt (keys %$opts) { $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_KEEPALIVE' => [ 'I' ], 'SO_OOBINLINE' => [ 'I' ], 'SO_REUSEADDR' => [ 'I' ], 'SO_USELOOPBACK' => [ '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' ], # Finally, one which is a struct 'SO_LINGER' => [ 'II' ], # Out of known socket options ); __PACKAGE__->initsockopts( SOL_SOCKET(), \%sockopts ); sub _genfh () # (void), returns orphan globref with HV slot. { 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.... sub _debug # $this [, $newval] ; returns oldval { use attrs 'locked'; my ($this,$newval) = @_; return $this->debug($newval) if ref $this; # class method here my $oldval = $debug; $debug = 0+$newval if defined $newval; $oldval; } sub debug # $self [, $newval] ; returns oldval { use attrs 'locked', 'method'; my ($self,$newval) = @_; my $oldval = ${*$self}{Parms}{'debug'} if defined wantarray; $self->setparams({'debug'=>$newval}) if defined $newval; $oldval; } sub _trace # $this , \@args, minlevel, [$moretext] { 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}; } sub _setdebug # $self, $name, $newval { 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'; sub _accessor # $self, $what [, $newval] ; returns oldvalue { use attrs '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; } sub _setblocking # $self, $name, $newval { 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 } sub blocking # $self [, $newval] ; returns canonical oldval { use attrs '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; } sub _settimeout # $self, $what, $newval { 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); 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; sub registerParamKeys # $self, \@keys { use attrs '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} = (); # remember the names } sub register_param_keys; # helps with -w *register_param_keys = \®isterParamKeys; # alias form preferred by many sub registerParamHandlers # $self, \@keys, [\]@handlers { # -or- $self, \%key-handlers use attrs '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 register_param_handlers; # helps with -w *register_param_handlers = \®isterParamHandlers; # alias other form sub registerOptions # $self, $levelname, $level, \%options { use attrs '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 register_options; # helps with -w *register_options = \®isterOptions; # alias form preferred by many # pseudo-subclass for saving parameters (ParamSaver, inspired by SelectSaver) sub paramSaver # $self, @params { use attrs 'locked', 'method'; my ($self, @params) = @_; my %setparams = $self->getparams(\@params); my @delparams = map { exists ${*$self}{Parms}{$_} ? () : ($_) } @params; bless [$self, \%setparams, \@delparams], 'Net::Gen::ParamSaver'; } sub param_saver; # aliases *param_saver = \¶mSaver; sub ParamSaver; *ParamSaver = \¶mSaver; sub Net::Gen::ParamSaver::DESTROY { use attrs 'locked'; local $!; # just to be sure we don't clobber it $_[0]->[0]->setparams($_[0]->[1]); $_[0]->[0]->delparams($_[0]->[2]); } sub new # classname [, \%params] { # -or- $classname [, @ignored] 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"; } $pack = ref $pack if ref $pack; my $self = _genfh; bless $self,$pack; $pack->_trace(\@_,2,", self=$self after bless"); ${*$self}{Parms} = \%parms; if (%Keys) { ${*$self}{Keys} = { %Keys }; ${*$self}{Sockopts} = { %Opts }; } else { $self->registerParamKeys(\@Keys); # register our keys $self->registerParamHandlers(\%Codekeys); $self->registerOptions('SOL_SOCKET', SOL_SOCKET(), \%sockopts); %Keys = %{${*$self}{Keys}}; %Opts = %{${*$self}{Sockopts}}; } if ($pack 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; } sub setparams # $this, \%newparams [, $newonly [, $check]] { use attrs '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); 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}; next if $newonly < 0 && defined ${*$self}{Parms}{$parm}; if (!$check) { # this ungodly construct brought to you by -w next if defined(${*$self}{Parms}{$parm}) eq defined($newval) and !defined($newval) || ${*$self}{Parms}{$parm} eq $newval || ${*$self}{Parms}{$parm} !~ /\D/ && $newval !~ /\D/ && length($newval) && length(${*$self}{Parms}{$parm}) && ${*$self}{Parms}{$parm} == $newval ; } carp("Overwrite of $parm parameter for ".(ref $self)." object ignored") , $errs++, next if $newonly > 0 && defined ${*$self}{Parms}{$parm}; 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; } ${*$self}{Parms}{$parm} = $newval; } $errs ? undef : 1; } sub delparams # $self, \@paramnames ; returns bool { use attrs '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 } sub checkparams # $self, (void) ; returns bool { use attrs '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); } sub init # $self, (void) ; returns updated $self { $_[0]->_trace(\@_,1); my($self) = @_; $self->checkparams ? $self : undef; } sub getparam # $self, $key [, $default [, $defaultifundef]] { use attrs '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}; } sub getparams # $self, \@keys [, $noundef]; returns (%hash) { use attrs '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; } sub condition # $self ; return not useful { use attrs '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); } sub open # $self [, @ignore] ; returns boolean { use attrs '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 ); sub _valconnect # $self, $addr, $timeout ; returns boolean { 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; } sub _tryconnect # $self, $addr, $timeout ; returns boolean { 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'}) { 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; } sub connect # $self, [@ignored] ; returns boolean { use attrs '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; } sub getsockinfo # $self, [@ignored] ; returns ?dest sockaddr? { use attrs '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); sub shutdown # $self [, $how=SHUT_RDWR] ; returns boolean { use attrs '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); sub close # $self [, @ignored] ; returns boolean { use attrs 'locked', 'method'; $_[0]->_trace(\@_,3); my $self = shift; $self->shutdown if $self->isopen; $self->stopio; } sub CLOSE; *CLOSE = \&close; sub stopio # $self [, @ignored] ; returns boolean { use attrs '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. sub send # $self, $buf, [$flags, [$where]] : boolean { 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) unless (defined $whither or $self->isconnected) { if ($self->getparams([qw(dstaddrlist dstaddr)],1) > 0) { return undef unless $self->connect; } 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; } } 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; sub put # $self, @stuff ; returns boolean { $_[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 sub ckeof # $self ; returns boolean { use attrs '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 } sub recv # $self, [$maxlen, [$flags, [$from]]] ; { # returns $buf or undef use attrs '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 { ${*$self}{sockLineBuf} = undef; } $_[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 sub getline # $self ; returns like scalar(<$fhandle>) { use attrs '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}; ${*$self}{sockLineBuf} = undef; # 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); } sub isopen # $self [, @ignored] ; returns boolean { #$_[0]->_trace(\@_,4," - ".(${*{$_[0]}}{'isopen'} ? "yes" : "no")); ${*{$_[0]}}{'isopen'}; } sub isconnected # $self [, @ignored] ; returns boolean { #$_[0]->_trace(\@_,4," - ".(${*{$_[0]}}{'isconnected'} ? "yes" : "no")); ${*{$_[0]}}{'isconnected'}; } sub isconnecting # $self [, @ignored] ; returns boolean { #$_[0]->_trace(\@_,4," - ".(${*{$_[0]}}{'isconnecting'} ? "yes" : "no")); ${*{$_[0]}}{'isconnecting'}; } sub wasconnected # $self [, @ignored] ; returns boolean { #$_[0]->_trace(\@_,4," - ".(${*{$_[0]}}{'wasconnected'} ? "yes" : "no")); ${*{$_[0]}}{'wasconnected'}; } sub isbound # $self [, @ignored] ; returns boolean { #$_[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 for details on those methods. Also provided in this distribution are C, C, C, and C, which are layered atop C. =head2 Public Methods The public methods are listed alphabetically below. Here is an indication of their functional groupings: =over =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. =item fileno Usage: $fnum = $obj->fileno; Returns the actual file descriptor number for the underlying socket. See L for some restrictions as to the safety of using this. =item format_addr Usage: $string = $obj->format_addr($sockaddr); $string = format_addr Module $sockaddr; Returns a formatted representation of the address. This is a method so that it can be overridden by derived classes. It is used to implement ``pretty-printing'' methods for source and destination addresses. =item format_local_addr Usage: $string = $obj->format_local_addr; Returns a formatted representation of the local socket address associated with the object. =item format_remote_addr Usage: $string = $obj->format_remote_addr; Returns a formatted representation of the remote socket address associated with the object. =item get This is just a sugar-coated way to call the C method which will work with indirect-object syntax. See L for details. =item GETC Usage: $char = $obj->GETC; $char = getc(TIEDFH); This method uses the C method with a $flags argument of 0 and a $maxlen argument of 1 to emulate the getc() builtin. Like that builtin, it returns a string representing the character read when successful, and undef on eof or errors. This method exists for the support of tied filehandles. It's unreliable for non-blocking sockets. =item getfh Usage: $fhandle = $obj->getfh; I've strongly resisted giving people direct access to the filehandle embedded in the object because of the problems of mixing C input calls and traditional socket-level I/O. However, if you're sure you can keep things straight, here are the rules under which it's safe to use the embedded filehandle: =over =item Z<> Don't use perl's own C calls. Stick to sysread() and recv(). =item Z<> Don't use the object's C method, since that stores a read-ahead buffer in the object which only the object's own C/C and C methods know to return to you. (The object's C