diff options
author | Paul Evans <leonerd@leonerd.org.uk> | 2012-02-03 09:33:16 +0000 |
---|---|---|
committer | Chris 'BinGOs' Williams <chris@bingosnet.co.uk> | 2012-02-03 11:10:23 +0000 |
commit | 497f7de2d964167330f7260590736e9adb18899c (patch) | |
tree | 8a340353e778766d77e0a645b365c573e6af886a /cpan/IO-Socket-IP | |
parent | 778a861bb0a8d42e4be677cc40a39d1fac0babe5 (diff) | |
download | perl-497f7de2d964167330f7260590736e9adb18899c.tar.gz |
Add IO::Socket::IP 0.08 as dual-life module
Signed-off-by: Chris 'BinGOs' Williams <chris@bingosnet.co.uk>
Diffstat (limited to 'cpan/IO-Socket-IP')
-rw-r--r-- | cpan/IO-Socket-IP/lib/IO/Socket/IP.pm | 826 | ||||
-rw-r--r-- | cpan/IO-Socket-IP/t/00use.t | 6 | ||||
-rw-r--r-- | cpan/IO-Socket-IP/t/01local-client-v4.t | 50 | ||||
-rw-r--r-- | cpan/IO-Socket-IP/t/02local-server-v4.t | 54 | ||||
-rw-r--r-- | cpan/IO-Socket-IP/t/03local-cross-v4.t | 36 | ||||
-rw-r--r-- | cpan/IO-Socket-IP/t/04local-client-v6.t | 60 | ||||
-rw-r--r-- | cpan/IO-Socket-IP/t/05local-server-v6.t | 62 | ||||
-rw-r--r-- | cpan/IO-Socket-IP/t/06local-cross-v6.t | 41 | ||||
-rw-r--r-- | cpan/IO-Socket-IP/t/10args.t | 52 | ||||
-rw-r--r-- | cpan/IO-Socket-IP/t/11sockopts.t | 43 | ||||
-rw-r--r-- | cpan/IO-Socket-IP/t/12port-fallback.t | 42 | ||||
-rw-r--r-- | cpan/IO-Socket-IP/t/13addrinfo.t | 53 | ||||
-rw-r--r-- | cpan/IO-Socket-IP/t/14fileno.t | 24 | ||||
-rw-r--r-- | cpan/IO-Socket-IP/t/15io-socket.t | 34 | ||||
-rw-r--r-- | cpan/IO-Socket-IP/t/20nonblocking-connect.t | 48 | ||||
-rw-r--r-- | cpan/IO-Socket-IP/t/21nonblocking-connect-internet.t | 99 |
16 files changed, 1530 insertions, 0 deletions
diff --git a/cpan/IO-Socket-IP/lib/IO/Socket/IP.pm b/cpan/IO-Socket-IP/lib/IO/Socket/IP.pm new file mode 100644 index 0000000000..ab457588b0 --- /dev/null +++ b/cpan/IO-Socket-IP/lib/IO/Socket/IP.pm @@ -0,0 +1,826 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2010-2011 -- leonerd@leonerd.org.uk + +package IO::Socket::IP; + +use strict; +use warnings; +use base qw( IO::Socket ); + +our $VERSION = '0.08'; + +use Carp; + +use Socket 1.95 qw( + getaddrinfo getnameinfo + AF_INET + AI_PASSIVE + IPPROTO_TCP IPPROTO_UDP + NI_DGRAM NI_NUMERICHOST NI_NUMERICSERV + SO_REUSEADDR SO_REUSEPORT SO_BROADCAST SO_ERROR + SOCK_DGRAM SOCK_STREAM + SOL_SOCKET +); +my $AF_INET6 = eval { Socket::AF_INET6() }; # may not be defined +my $AI_ADDRCONFIG = eval { Socket::AI_ADDRCONFIG() } || 0; +use POSIX qw( dup2 ); +use Errno qw( EINPROGRESS ); + +use constant HAVE_MSWIN32 => ( $^O eq "MSWin32" ); + +my $IPv6_re = do { + # translation of RFC 3986 3.2.2 ABNF to re + my $IPv4address = do { + my $dec_octet = q<(?:[0-9]|[1-9][0-9]|1[0-9][0-9]|2[0-4][0-9]|25[0-5])>; + qq<$dec_octet(?: \\. $dec_octet){3}>; + }; + my $IPv6address = do { + my $h16 = qq<[0-9A-Fa-f]{1,4}>; + my $ls32 = qq<(?: $h16 : $h16 | $IPv4address)>; + qq<(?: + (?: $h16 : ){6} $ls32 + | :: (?: $h16 : ){5} $ls32 + | (?: $h16 )? :: (?: $h16 : ){4} $ls32 + | (?: (?: $h16 : ){0,1} $h16 )? :: (?: $h16 : ){3} $ls32 + | (?: (?: $h16 : ){0,2} $h16 )? :: (?: $h16 : ){2} $ls32 + | (?: (?: $h16 : ){0,3} $h16 )? :: $h16 : $ls32 + | (?: (?: $h16 : ){0,4} $h16 )? :: $ls32 + | (?: (?: $h16 : ){0,5} $h16 )? :: $h16 + | (?: (?: $h16 : ){0,6} $h16 )? :: + )> + }; + qr<$IPv6address>xo; +}; + +=head1 NAME + +C<IO::Socket::IP> - A drop-in replacement for C<IO::Socket::INET> supporting +both IPv4 and IPv6 + +=head1 SYNOPSIS + + use IO::Socket::IP; + + my $sock = IO::Socket::IP->new( + PeerHost => "www.google.com", + PeerPort => "http", + Type => SOCK_STREAM, + ) or die "Cannot construct socket - $@"; + + my $familyname = ( $sock->sockdomain == PF_INET6 ) ? "IPv6" : + ( $sock->sockdomain == PF_INET ) ? "IPv4" : + "unknown"; + + printf "Connected to google via %s\n", $familyname; + +=head1 DESCRIPTION + +This module provides a protocol-independent way to use IPv4 and IPv6 sockets, +as a drop-in replacement for L<IO::Socket::INET>. Most constructor arguments +and methods are provided in a backward-compatible way. For a list of known +differences, see the C<IO::Socket::INET> INCOMPATIBILITES section below. + +It uses the C<getaddrinfo(3)> function to convert hostnames and service names +or port numbers into sets of possible addresses to connect to or listen on. +This allows it to work for IPv6 where the system supports it, while still +falling back to IPv4-only on systems which don't. + +=head1 REPLACING C<IO::Socket> DEFAULT BEHAVIOUR + +By placing C<-register> in the import list, C<IO::Socket> uses +C<IO::Socket::IP> rather than C<IO::Socket::INET> as the class that handles +C<PF_INET>. C<IO::Socket> will also use C<IO::Socket::IP> rather than +C<IO::Socket::INET6> to handle C<PF_INET6>, provided that the C<AF_INET6> +constant is available. + +Changing C<IO::Socket>'s default behaviour means that calling the +C<IO::Socket> constructor with either C<PF_INET> or C<PF_INET6> as the +C<Domain> parameter will yield an C<IO::Socket::IP> object. + + use IO::Socket::IP -register; + + my $sock = IO::Socket->new( + Domain => PF_INET6, + LocalHost => "::1", + Listen => 1, + ) or die "Cannot create socket - $@\n"; + + print "Created a socket of type " . ref($sock) . "\n"; + +Note that C<-register> is a global setting that applies to the entire program; +it cannot be applied only for certain callers, removed, or limited by lexical +scope. + +=cut + +sub import +{ + my $pkg = shift; + my @symbols; + + foreach ( @_ ) { + if( $_ eq "-register" ) { + $pkg->register_domain( AF_INET ); + $pkg->register_domain( $AF_INET6 ) if defined $AF_INET6; + } + else { + push @symbols, $_; + } + } + + @_ = ( $pkg, @symbols ); + goto &IO::Socket::import; +} + +=head1 CONSTRUCTORS + +=cut + +=head2 $sock = IO::Socket::IP->new( %args ) + +Creates a new C<IO::Socket::IP> object, containing a newly created socket +handle according to the named arguments passed. The recognised arguments are: + +=over 8 + +=item PeerHost => STRING + +=item PeerService => STRING + +Hostname and service name for the peer to C<connect()> to. The service name +may be given as a port number, as a decimal string. + +=item PeerAddr => STRING + +=item PeerPort => STRING + +For symmetry with the accessor methods and compatibility with +C<IO::Socket::INET>, these are accepted as synonyms for C<PeerHost> and +C<PeerService> respectively. + +=item PeerAddrInfo => ARRAY + +Alternate form of specifying the peer to C<connect()> to. This should be an +array of the form returned by C<Socket::getaddrinfo>. + +This parameter takes precedence over the C<Peer*>, C<Family>, C<Type> and +C<Proto> arguments. + +=item LocalHost => STRING + +=item LocalService => STRING + +Hostname and service name for the local address to C<bind()> to. + +=item LocalAddr => STRING + +=item LocalPort => STRING + +For symmetry with the accessor methods and compatibility with +C<IO::Socket::INET>, these are accepted as synonyms for C<LocalHost> and +C<LocalService> respectively. + +=item LocalAddrInfo => ARRAY + +Alternate form of specifying the local address to C<bind()> to. This should be +an array of the form returned by C<Socket::getaddrinfo>. + +This parameter takes precedence over the C<Local*>, C<Family>, C<Type> and +C<Proto> arguments. + +=item Family => INT + +The address family to pass to C<getaddrinfo> (e.g. C<AF_INET>, C<AF_INET6>). +Normally this will be left undefined, and C<getaddrinfo> will search using any +address family supported by the system. + +=item Type => INT + +The socket type to pass to C<getaddrinfo> (e.g. C<SOCK_STREAM>, +C<SOCK_DGRAM>). Normally defined by the caller; if left undefined +C<getaddrinfo> may attempt to infer the type from the service name. + +=item Proto => STRING or INT + +The IP protocol to use for the socket (e.g. C<'tcp'>, C<IPPROTO_TCP>, +C<'udp'>,C<IPPROTO_UDP>). Normally this will be left undefined, and either +C<getaddrinfo> or the kernel will choose an appropriate value. May be given +either in string name or numeric form. + +=item Listen => INT + +If defined, puts the socket into listening mode where new connections can be +accepted using the C<accept> method. The value given is used as the +C<listen(2)> queue size. + +=item ReuseAddr => BOOL + +If true, set the C<SO_REUSEADDR> sockopt + +=item ReusePort => BOOL + +If true, set the C<SO_REUSEPORT> sockopt (not all OSes implement this sockopt) + +=item Broadcast => BOOL + +If true, set the C<SO_BROADCAST> sockopt + +=item Timeout + +This C<IO::Socket::INET>-style argument is not currently supported. See the +C<IO::Socket::INET> INCOMPATIBILITES section below. + +=item MultiHomed + +This C<IO::Socket::INET>-style argument is not currently supported. See the +C<IO::Socket::INET> INCOMPATIBILITES section below. However, the behaviour it +enables is always performed by C<IO::Socket::IP>. + +=item Blocking => BOOL + +If defined but false, the socket will be set to non-blocking mode. Otherwise +it will default to blocking mode. See the NON-BLOCKING section below for more +detail. + +=back + +If neither C<Type> nor C<Proto> hints are provided, a default of +C<SOCK_STREAM> and C<IPPROTO_TCP> respectively will be set, to maintain +compatibility with C<IO::Socket::INET>. + +If the constructor fails, it will set C<$@> to an appropriate error message; +this may be from C<$!> or it may be some other string; not every failure +necessarily has an associated C<errno> value. + +=head2 $sock = IO::Socket::IP->new( $peeraddr ) + +As a special case, if the constructor is passed a single argument (as +opposed to an even-sized list of key/value pairs), it is taken to be the value +of the C<PeerAddr> parameter. This is parsed in the same way, according to the +behaviour given in the C<PeerHost> AND C<LocalHost> PARSING section below. + +=cut + +sub new +{ + my $class = shift; + my %arg = (@_ == 1) ? (PeerHost => $_[0]) : @_; + return $class->SUPER::new(%arg); +} + +# IO::Socket may call this one; neaten up the arguments from IO::Socket::INET +# before calling our real _configure method +sub configure +{ + my $self = shift; + my ( $arg ) = @_; + + $arg->{PeerHost} = delete $arg->{PeerAddr} + if exists $arg->{PeerAddr} && !exists $arg->{PeerHost}; + + $arg->{PeerService} = delete $arg->{PeerPort} + if exists $arg->{PeerPort} && !exists $arg->{PeerService}; + + $arg->{LocalHost} = delete $arg->{LocalAddr} + if exists $arg->{LocalAddr} && !exists $arg->{LocalHost}; + + $arg->{LocalService} = delete $arg->{LocalPort} + if exists $arg->{LocalPort} && !exists $arg->{LocalService}; + + for my $type (qw(Peer Local)) { + my $host = $type . 'Host'; + my $service = $type . 'Service'; + + if (exists $arg->{$host} && !exists $arg->{$service}) { + local $_ = $arg->{$host}; + defined or next; + local ( $1, $2 ); # Placate a taint-related bug; [perl #67962] + if (/\A\[($IPv6_re)\](?::([^\s:]*))?\z/o || /\A([^\s:]*):([^\s:]*)\z/) { + $arg->{$host} = $1; + $arg->{$service} = $2 if defined $2 && length $2; + } + } + } + + $self->_configure( $arg ); +} + +sub _configure +{ + my $self = shift; + my ( $arg ) = @_; + + my %hints; + my @localinfos; + my @peerinfos; + + my @sockopts_enabled; + + $hints{flags} = $AI_ADDRCONFIG; + + if( defined $arg->{Family} ) { + my $family = delete $arg->{Family}; + $hints{family} = $family; + } + + if( defined $arg->{Type} ) { + my $type = delete $arg->{Type}; + $hints{socktype} = $type; + } + + if( defined $arg->{Proto} ) { + my $proto = delete $arg->{Proto}; + + unless( $proto =~ m/^\d+$/ ) { + my $protonum = getprotobyname( $proto ); + defined $protonum or croak "Unrecognised protocol $proto"; + $proto = $protonum; + } + + $hints{protocol} = $proto; + } + + # To maintain compatibilty with IO::Socket::INET, imply a default of + # SOCK_STREAM + IPPROTO_TCP if neither hint is given + if( !defined $hints{socktype} and !defined $hints{protocol} ) { + $hints{socktype} = SOCK_STREAM; + $hints{protocol} = IPPROTO_TCP; + } + + # Some OSes (NetBSD) don't seem to like just a protocol hint without a + # socktype hint as well. We'll set a couple of common ones + if( !defined $hints{socktype} and defined $hints{protocol} ) { + $hints{socktype} = SOCK_STREAM if $hints{protocol} == IPPROTO_TCP; + $hints{socktype} = SOCK_DGRAM if $hints{protocol} == IPPROTO_UDP; + } + + if( my $info = delete $arg->{LocalAddrInfo} ) { + @localinfos = @$info; + } + elsif( defined $arg->{LocalHost} or defined $arg->{LocalService} ) { + # Either may be undef + my $host = delete $arg->{LocalHost}; + my $service = delete $arg->{LocalService}; + + local $1; # Placate a taint-related bug; [perl #67962] + defined $service and $service =~ s/\((\d+)\)$// and + my $fallback_port = $1; + + my %localhints = %hints; + $localhints{flags} |= AI_PASSIVE; + ( my $err, @localinfos ) = getaddrinfo( $host, $service, \%localhints ); + + if( $err and defined $fallback_port ) { + ( $err, @localinfos ) = getaddrinfo( $host, $fallback_port, \%localhints ); + } + + $err and ( $@ = "$err", return ); + } + + if( my $info = delete $arg->{PeerAddrInfo} ) { + @peerinfos = @$info; + } + elsif( defined $arg->{PeerHost} or defined $arg->{PeerService} ) { + defined( my $host = delete $arg->{PeerHost} ) or + croak "Expected 'PeerHost'"; + defined( my $service = delete $arg->{PeerService} ) or + croak "Expected 'PeerService'"; + + local $1; # Placate a taint-related bug; [perl #67962] + defined $service and $service =~ s/\((\d+)\)$// and + my $fallback_port = $1; + + ( my $err, @peerinfos ) = getaddrinfo( $host, $service, \%hints ); + + if( $err and defined $fallback_port ) { + ( $err, @peerinfos ) = getaddrinfo( $host, $fallback_port, \%hints ); + } + + $err and ( $@ = "$err", return ); + } + + push @sockopts_enabled, SO_REUSEADDR if delete $arg->{ReuseAddr}; + push @sockopts_enabled, SO_REUSEPORT if delete $arg->{ReusePort}; + push @sockopts_enabled, SO_BROADCAST if delete $arg->{Broadcast}; + + my $listenqueue = delete $arg->{Listen}; + + croak "Cannot Listen with a PeerHost" if defined $listenqueue and @peerinfos; + + my $blocking = delete $arg->{Blocking}; + defined $blocking or $blocking = 1; + + keys %$arg and croak "Unexpected keys - " . join( ", ", sort keys %$arg ); + + my @infos; + foreach my $local ( @localinfos ? @localinfos : {} ) { + foreach my $peer ( @peerinfos ? @peerinfos : {} ) { + next if defined $local->{family} and defined $peer->{family} and + $local->{family} != $peer->{family}; + next if defined $local->{socktype} and defined $peer->{socktype} and + $local->{socktype} != $peer->{socktype}; + next if defined $local->{protocol} and defined $peer->{protocol} and + $local->{protocol} != $peer->{protocol}; + + my $family = $local->{family} || $peer->{family} or next; + my $socktype = $local->{socktype} || $peer->{socktype} or next; + my $protocol = $local->{protocol} || $peer->{protocol} || 0; + + push @infos, { + family => $family, + socktype => $socktype, + protocol => $protocol, + localaddr => $local->{addr}, + peeraddr => $peer->{addr}, + }; + } + } + + # In the nonblocking case, caller will be calling ->setup multiple times. + # Store configuration in the object for the ->setup method + # Yes, these are messy. Sorry, I can't help that... + + ${*$self}{io_socket_ip_infos} = \@infos; + + ${*$self}{io_socket_ip_idx} = -1; + + ${*$self}{io_socket_ip_sockopts} = \@sockopts_enabled; + ${*$self}{io_socket_ip_listenqueue} = $listenqueue; + ${*$self}{io_socket_ip_blocking} = $blocking; + + ${*$self}{io_socket_ip_errors} = [ undef, undef, undef ]; + + if( $blocking ) { + $self->setup or return undef; + } + return $self; +} + +sub setup +{ + my $self = shift; + + while(1) { + ${*$self}{io_socket_ip_idx}++; + last if ${*$self}{io_socket_ip_idx} >= @{ ${*$self}{io_socket_ip_infos} }; + + my $info = ${*$self}{io_socket_ip_infos}->[${*$self}{io_socket_ip_idx}]; + + $self->socket( @{$info}{qw( family socktype protocol )} ) or + ( ${*$self}{io_socket_ip_errors}[2] = $!, next ); + + $self->blocking( 0 ) unless ${*$self}{io_socket_ip_blocking}; + + foreach my $sockopt ( @{ ${*$self}{io_socket_ip_sockopts} } ) { + $self->setsockopt( SOL_SOCKET, $sockopt, pack "i", 1 ) or ( $@ = "$!", return undef ); + } + + if( defined( my $addr = $info->{localaddr} ) ) { + $self->bind( $addr ) or + ( ${*$self}{io_socket_ip_errors}[1] = $!, next ); + } + + if( defined( my $listenqueue = ${*$self}{io_socket_ip_listenqueue} ) ) { + $self->listen( $listenqueue ) or ( $@ = "$!", return undef ); + } + + if( defined( my $addr = $info->{peeraddr} ) ) { + # It seems that IO::Socket hides EINPROGRESS errors, making them look + # like a success. This is annoying here. + # Instead of putting up with its frankly-irritating intentional + # breakage of useful APIs I'm just going to end-run around it and + # call CORE::connect() directly + if( CORE::connect( $self, $addr ) ) { + $! = 0; + return 1; + } + + return 0 if $! == EINPROGRESS or HAVE_MSWIN32 && $! == Errno::EWOULDBLOCK(); + + ${*$self}{io_socket_ip_errors}[0] = $!; + next; + } + + return 1; + } + + $self->close; + + # Pick the most appropriate error, stringified + $! = ( grep defined, @{ ${*$self}{io_socket_ip_errors}} )[0]; + $@ = "$!"; + return undef; +} + +sub connect +{ + my $self = shift; + return $self->SUPER::connect( @_ ) if @_; + + $! = 0, return 1 if $self->fileno and defined $self->peername; + + if( $self->fileno ) { + # A connect has just failed, get its error value + ${*$self}{io_socket_ip_errors}[0] = $self->getsockopt( SOL_SOCKET, SO_ERROR ); + } + + return $self->setup; +} + +=head1 METHODS + +As well as the following methods, this class inherits all the methods in +L<IO::Socket> and L<IO::Handle>. + +=cut + +sub _get_host_service +{ + my $self = shift; + my ( $addr, $numeric ) = @_; + + my $flags = 0; + + $flags |= NI_DGRAM if $self->socktype == SOCK_DGRAM; + $flags |= NI_NUMERICHOST|NI_NUMERICSERV if $numeric; + + my ( $err, $host, $service ) = getnameinfo( $addr, $flags ); + croak "getnameinfo - $err" if $err; + + return ( $host, $service ); +} + +=head2 ( $host, $service ) = $sock->sockhost_service( $numeric ) + +Returns the hostname and service name of the local address (that is, the +socket address given by the C<sockname> method). + +If C<$numeric> is true, these will be given in numeric form rather than being +resolved into names. + +The following four convenience wrappers may be used to obtain one of the two +values returned here. If both host and service names are required, this method +is preferable to the following wrappers, because it will call +C<getnameinfo(3)> only once. + +=cut + +sub sockhost_service +{ + my $self = shift; + my ( $numeric ) = @_; + + $self->_get_host_service( $self->sockname, $numeric ); +} + +=head2 $addr = $sock->sockhost + +Return the numeric form of the local address + +=head2 $port = $sock->sockport + +Return the numeric form of the local port number + +=head2 $host = $sock->sockhostname + +Return the resolved name of the local address + +=head2 $service = $sock->sockservice + +Return the resolved name of the local port number + +=cut + +sub sockhost { ( shift->sockhost_service(1) )[0] } +sub sockport { ( shift->sockhost_service(1) )[1] } + +sub sockhostname { ( shift->sockhost_service(0) )[0] } +sub sockservice { ( shift->sockhost_service(0) )[1] } + +=head2 ( $host, $service ) = $sock->peerhost_service( $numeric ) + +Returns the hostname and service name of the peer address (that is, the +socket address given by the C<peername> method), similar to the +C<sockhost_service> method. + +The following four convenience wrappers may be used to obtain one of the two +values returned here. If both host and service names are required, this method +is preferable to the following wrappers, because it will call +C<getnameinfo(3)> only once. + +=cut + +sub peerhost_service +{ + my $self = shift; + my ( $numeric ) = @_; + + $self->_get_host_service( $self->peername, $numeric ); +} + +=head2 $addr = $sock->peerhost + +Return the numeric form of the peer address + +=head2 $port = $sock->peerport + +Return the numeric form of the peer port number + +=head2 $host = $sock->peerhostname + +Return the resolved name of the peer address + +=head2 $service = $sock->peerservice + +Return the resolved name of the peer port number + +=cut + +sub peerhost { ( shift->peerhost_service(1) )[0] } +sub peerport { ( shift->peerhost_service(1) )[1] } + +sub peerhostname { ( shift->peerhost_service(0) )[0] } +sub peerservice { ( shift->peerhost_service(0) )[1] } + +# This unbelievably dodgy hack works around the bug that IO::Socket doesn't do +# it +# https://rt.cpan.org/Ticket/Display.html?id=61577 +sub accept +{ + my $self = shift; + my ( $new, $peer ) = $self->SUPER::accept or return; + + ${*$new}{$_} = ${*$self}{$_} for qw( io_socket_domain io_socket_type io_socket_proto ); + + return wantarray ? ( $new, $peer ) + : $new; +} + +# This second unbelievably dodgy hack guarantees that $self->fileno doesn't +# change, which is useful during nonblocking connect +sub socket +{ + my $self = shift; + return $self->SUPER::socket(@_) if not defined $self->fileno; + + # I hate core prototypes sometimes... + CORE::socket( my $tmph, $_[0], $_[1], $_[2] ) or return undef; + + dup2( $tmph->fileno, $self->fileno ) or die "Unable to dup2 $tmph onto $self - $!"; +} + +=head1 NON-BLOCKING + +If the constructor is passed a defined but false value for the C<Blocking> +argument then the socket is put into non-blocking mode. When in non-blocking +mode, the socket will not be set up by the time the constructor returns, +because the underlying C<connect(2)> syscall would otherwise have to block. + +The non-blocking behaviour is an extension of the C<IO::Socket::INET> API, +unique to C<IO::Socket::IP>, because the former does not support multi-homed +non-blocking connect. + +When using non-blocking mode, the caller must repeatedly check for +writeability on the filehandle (for instance using C<select> or C<IO::Poll>). +Each time the filehandle is ready to write, the C<connect> method must be +called, with no arguments. Note that some operating systems, most notably +C<MSWin32> do not report a C<connect()> failure using write-ready; so you must +also C<select()> for exceptional status. + +While C<connect> returns false, the value of C<$!> indicates whether it should +be tried again (by being set to the value C<EINPROGRESS>, or C<EWOULDBLOCK> on +MSWin32), or whether a permanent error has occurred (e.g. C<ECONNREFUSED>). + +Once the socket has been connected to the peer, C<connect> will return true +and the socket will now be ready to use. + +Note that calls to the platform's underlying C<getaddrinfo(3)> function may +block. If C<IO::Socket::IP> has to perform this lookup, the constructor will +block even when in non-blocking mode. + +To avoid this blocking behaviour, the caller should pass in the result of such +a lookup using the C<PeerAddrInfo> or C<LocalAddrInfo> arguments. This can be +achieved by using L<Net::LibAsyncNS>, or the C<getaddrinfo(3)> function can be +called in a child process. + + use IO::Socket::IP; + use Errno qw( EINPROGRESS EWOULDBLOCK ); + + my @peeraddrinfo = ... # Caller must obtain the getaddinfo result here + + my $socket = IO::Socket::IP->new( + PeerAddrInfo => \@peeraddrinfo, + Blocking => 0, + ) or die "Cannot construct socket - $@"; + + while( !$socket->connect and ( $! == EINPROGRESS || $! == EWOULDBLOCK ) ) { + my $wvec = ''; + vec( $wvec, fileno $socket, 1 ) = 1; + my $evec = ''; + vec( $evec, fileno $socket, 1 ) = 1; + + select( undef, $wvec, $evec, undef ) or die "Cannot select - $!"; + } + + die "Cannot connect - $!" if $!; + + ... + +The example above uses C<select()>, but any similar mechanism should work +analogously. C<IO::Socket::IP> takes care when creating new socket filehandles +to preserve the actual file descriptor number, so such techniques as C<poll> +or C<epoll> should be transparent to its reallocation of a different socket +underneath, perhaps in order to switch protocol family between C<PF_INET> and +C<PF_INET6>. + +For another example using C<IO::Poll> and C<Net::LibAsyncNS>, see the +F<examples/nonblocking_libasyncns.pl> file in the module distribution. + +=head1 C<PeerHost> AND C<LocalHost> PARSING + +To support the C<IO::Socket::INET> API, the host and port information may be +passed in a single string rather than as two separate arguments. + +If either C<LocalHost> or C<PeerHost> (or their C<...Addr> synonyms) have any +of the following special forms, and C<LocalService> or C<PeerService> (or +their C<...Port> synonyms) are absent, special parsing is applied. + +The value of the C<...Host> argument will be split to give both the hostname +and port (or service name): + + hostname.example.org:http # Host name + 192.0.2.1:80 # IPv4 address + [2001:db8::1]:80 # IPv6 address + +In each case, the port or service name (e.g. C<80>) is passed as the +C<LocalService> or C<PeerService> argument. + +Either of C<LocalService> or C<PeerService> (or their C<...Port> synonyms) can +be either a service name, a decimal number, or a string containing both a +service name and number, in a form such as + + http(80) + +In this case, the name (C<http>) will be tried first, but if the resolver does +not understand it then the port number (C<80>) will be used instead. + +=head1 C<IO::Socket::INET> INCOMPATIBILITES + +=over 4 + +=item * + +The C<Timeout> and C<MultiHomed> constructor arguments are currently not +recognised. + +The behaviour enabled by C<MultiHomed> is in fact implemented by +C<IO::Socket::IP> as it is required to correctly support searching for a +useable address from the results of the C<getaddrinfo(3)> call. + +=back + +=cut + +=head1 TODO + +=over 4 + +=item * + +Cache the returns from C<sockhost_service> and C<peerhost_service> to avoid +double-lookup overhead in such code as + + printf "Peer is %s:%d\n", $sock->peerhost, $sock->peerport; + +=item * + +Investigate whether C<POSIX::dup2> upsets BSD's C<kqueue> watchers, and if so, +consider what possible workarounds might be applied. + +=back + +=head1 BUGS + +=over 4 + +=item * + +Nonblocking connect fails unit tests on MSWin32 smoke-testing machines. The +specifics of the failure are that C<connect()> seems to block anyway despite +being asked not to, and that failure to connect is not detected properly. I am +as yet unsure why this is. + +Blocking connect on MSWin32, and both blocking and nonblocking connect on +other platforms, all test OK on smoke testing. + +=back + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/cpan/IO-Socket-IP/t/00use.t b/cpan/IO-Socket-IP/t/00use.t new file mode 100644 index 0000000000..5cb6310503 --- /dev/null +++ b/cpan/IO-Socket-IP/t/00use.t @@ -0,0 +1,6 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More tests => 1; + +use_ok( "IO::Socket::IP" ); diff --git a/cpan/IO-Socket-IP/t/01local-client-v4.t b/cpan/IO-Socket-IP/t/01local-client-v4.t new file mode 100644 index 0000000000..7e9980c8d7 --- /dev/null +++ b/cpan/IO-Socket-IP/t/01local-client-v4.t @@ -0,0 +1,50 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More tests => 16; + +use IO::Socket::IP; + +use IO::Socket::INET; +use Socket qw( unpack_sockaddr_in ); + +foreach my $socktype (qw( SOCK_STREAM SOCK_DGRAM )) { + my $testserver = IO::Socket::INET->new( + ( $socktype eq "SOCK_STREAM" ? ( Listen => 1 ) : () ), + LocalHost => "127.0.0.1", + Type => Socket->$socktype, + Proto => ( $socktype eq "SOCK_STREAM" ? "tcp" : "udp" ), # Because IO::Socket::INET is stupid and always presumes tcp + ) or die "Cannot listen on PF_INET - $@"; + + my $socket = IO::Socket::IP->new( + PeerHost => "127.0.0.1", + PeerService => $testserver->sockport, + Type => Socket->$socktype, + ); + + ok( defined $socket, "IO::Socket::IP->new constructs a $socktype socket" ) or + diag( " error was $@" ); + + is( $socket->sockdomain, AF_INET, "\$socket->sockdomain for $socktype" ); + is( $socket->socktype, Socket->$socktype, "\$socket->socktype for $socktype" ); + + my $testclient = ( $socktype eq "SOCK_STREAM" ) ? + $testserver->accept : + do { $testserver->connect( $socket->sockname ); $testserver }; + + ok( defined $testclient, "accepted test $socktype client" ); + + is_deeply( [ unpack_sockaddr_in $socket->sockname ], + [ unpack_sockaddr_in $testclient->peername ], + "\$socket->sockname for $socktype" ); + + is_deeply( [ unpack_sockaddr_in $socket->peername ], + [ unpack_sockaddr_in $testclient->sockname ], + "\$socket->peername for $socktype" ); + + is( $socket->peerhost, "127.0.0.1", "\$socket->peerhost for $socktype" ); + is( $socket->peerport, $testserver->sockport, "\$socket->peerport for $socktype" ); + + # Can't easily test the non-numeric versions without relying on the system's + # ability to resolve the name "localhost" +} diff --git a/cpan/IO-Socket-IP/t/02local-server-v4.t b/cpan/IO-Socket-IP/t/02local-server-v4.t new file mode 100644 index 0000000000..2a0d1310cc --- /dev/null +++ b/cpan/IO-Socket-IP/t/02local-server-v4.t @@ -0,0 +1,54 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More tests => 26; + +use IO::Socket::IP; + +use IO::Socket::INET; +use Socket qw( unpack_sockaddr_in ); + +foreach my $socktype (qw( SOCK_STREAM SOCK_DGRAM )) { + my $testserver = IO::Socket::IP->new( + ( $socktype eq "SOCK_STREAM" ? ( Listen => 1 ) : () ), + LocalHost => "127.0.0.1", + Type => Socket->$socktype, + ); + + ok( defined $testserver, "IO::Socket::IP->new constructs a $socktype socket" ) or + diag( " error was $@" ); + + is( $testserver->sockdomain, AF_INET, "\$testserver->sockdomain for $socktype" ); + is( $testserver->socktype, Socket->$socktype, "\$testserver->socktype for $socktype" ); + + is( $testserver->sockhost, "127.0.0.1", "\$testserver->sockhost for $socktype" ); + like( $testserver->sockport, qr/^\d+$/, "\$testserver->sockport for $socktype" ); + + my $socket = IO::Socket::INET->new( + PeerHost => "127.0.0.1", + PeerPort => $testserver->sockport, + Type => Socket->$socktype, + Proto => ( $socktype eq "SOCK_STREAM" ? "tcp" : "udp" ), # Because IO::Socket::INET is stupid and always presumes tcp + ) or die "Cannot connect to PF_INET - $@"; + + my $testclient = ( $socktype eq "SOCK_STREAM" ) ? + $testserver->accept : + do { $testserver->connect( $socket->sockname ); $testserver }; + + ok( defined $testclient, "accepted test $socktype client" ); + isa_ok( $testclient, "IO::Socket::IP", "\$testclient for $socktype" ); + + is( $testclient->sockdomain, AF_INET, "\$testclient->sockdomain for $socktype" ); + is( $testclient->socktype, Socket->$socktype, "\$testclient->socktype for $socktype" ); + + is_deeply( [ unpack_sockaddr_in $socket->sockname ], + [ unpack_sockaddr_in $testclient->peername ], + "\$socket->sockname for $socktype" ); + + is_deeply( [ unpack_sockaddr_in $socket->peername ], + [ unpack_sockaddr_in $testclient->sockname ], + "\$socket->peername for $socktype" ); + + is( $testclient->sockport, $socket->peerport, "\$testclient->sockport for $socktype" ); + is( $testclient->peerport, $socket->sockport, "\$testclient->peerport for $socktype" ); +} diff --git a/cpan/IO-Socket-IP/t/03local-cross-v4.t b/cpan/IO-Socket-IP/t/03local-cross-v4.t new file mode 100644 index 0000000000..5eacd1dd04 --- /dev/null +++ b/cpan/IO-Socket-IP/t/03local-cross-v4.t @@ -0,0 +1,36 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More tests => 12; + +use IO::Socket::IP; + +foreach my $socktype (qw( SOCK_STREAM SOCK_DGRAM )) { + my $testserver = IO::Socket::IP->new( + ( $socktype eq "SOCK_STREAM" ? ( Listen => 1 ) : () ), + LocalHost => "127.0.0.1", + Type => Socket->$socktype, + ) or die "Cannot listen on PF_INET - $@"; + + my $socket = IO::Socket::IP->new( + PeerHost => "127.0.0.1", + PeerService => $testserver->sockport, + Type => Socket->$socktype, + ) or die "Cannot connect on PF_INET - $@"; + + my $testclient = ( $socktype eq "SOCK_STREAM" ) ? + $testserver->accept : + do { $testserver->connect( $socket->sockname ); $testserver }; + + is( $testclient->sockport, $socket->peerport, "\$testclient->sockport for $socktype" ); + is( $testclient->peerport, $socket->sockport, "\$testclient->peerport for $socktype" ); + + is( $testclient->sockhost, $socket->peerhost, "\$testclient->sockhost for $socktype" ); + is( $testclient->peerhost, $socket->sockhost, "\$testclient->peerhost for $socktype" ); + + $socket->write( "Request\n" ); + is( $testclient->getline, "Request\n", "\$socket to \$testclient for $socktype" ); + + $testclient->write( "Response\n" ); + is( $socket->getline, "Response\n", "\$testclient to \$socket for $socktype" ); +} diff --git a/cpan/IO-Socket-IP/t/04local-client-v6.t b/cpan/IO-Socket-IP/t/04local-client-v6.t new file mode 100644 index 0000000000..575cb30969 --- /dev/null +++ b/cpan/IO-Socket-IP/t/04local-client-v6.t @@ -0,0 +1,60 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More; + +use IO::Socket::IP; +use Socket; + +my $AF_INET6 = eval { require Socket and Socket::AF_INET6() } or + plan skip_all => "No AF_INET6"; + +eval { IO::Socket::IP->new( LocalHost => "::1" ) } or + plan skip_all => "Unable to bind to ::1"; + +plan tests => 16; + +foreach my $socktype (qw( SOCK_STREAM SOCK_DGRAM )) { + my $testserver = IO::Socket->new; + $testserver->socket( $AF_INET6, Socket->$socktype, 0 ) + or die "Cannot socket() - $!"; + $testserver->bind( Socket::pack_sockaddr_in6( 0, Socket::inet_pton( $AF_INET6, "::1" ) ) ) or + die "Cannot bind() - $!"; + if( $socktype eq "SOCK_STREAM" ) { + $testserver->listen( 1 ) or die "Cannot listen() - $!"; + } + + my $testport = ( Socket::unpack_sockaddr_in6 $testserver->sockname )[0]; + + my $socket = IO::Socket::IP->new( + PeerHost => "::1", + PeerService => $testport, + Type => Socket->$socktype, + ); + + ok( defined $socket, "IO::Socket::IP->new constructs a $socktype socket" ) or + diag( " error was $@" ); + + is( $socket->sockdomain, $AF_INET6, "\$socket->sockdomain for $socktype" ); + is( $socket->socktype, Socket->$socktype, "\$socket->socktype for $socktype" ); + + my $testclient = ( $socktype eq "SOCK_STREAM" ) ? + $testserver->accept : + do { $testserver->connect( $socket->sockname ); $testserver }; + + ok( defined $testclient, "accepted test $socktype client" ); + + is_deeply( [ Socket::unpack_sockaddr_in6( $socket->sockname ) ], + [ Socket::unpack_sockaddr_in6( $testclient->peername ) ], + "\$socket->sockname for $socktype" ); + + is_deeply( [ Socket::unpack_sockaddr_in6( $socket->peername ) ], + [ Socket::unpack_sockaddr_in6( $testclient->sockname ) ], + "\$socket->peername for $socktype" ); + + is( $socket->peerhost, "::1", "\$socket->peerhost for $socktype" ); + is( $socket->peerport, $testport, "\$socket->peerport for $socktype" ); + + # Can't easily test the non-numeric versions without relying on the system's + # ability to resolve the name "localhost" +} diff --git a/cpan/IO-Socket-IP/t/05local-server-v6.t b/cpan/IO-Socket-IP/t/05local-server-v6.t new file mode 100644 index 0000000000..46777b3e11 --- /dev/null +++ b/cpan/IO-Socket-IP/t/05local-server-v6.t @@ -0,0 +1,62 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More; + +use IO::Socket::IP; +use Socket; + +my $AF_INET6 = eval { require Socket and Socket::AF_INET6() } or + plan skip_all => "No AF_INET6"; + +eval { IO::Socket::IP->new( LocalHost => "::1" ) } or + plan skip_all => "Unable to bind to ::1"; + +plan tests => 26; + +foreach my $socktype (qw( SOCK_STREAM SOCK_DGRAM )) { + my $testserver = IO::Socket::IP->new( + ( $socktype eq "SOCK_STREAM" ? ( Listen => 1 ) : () ), + LocalHost => "::1", + Type => Socket->$socktype, + ); + + ok( defined $testserver, "IO::Socket::IP->new constructs a $socktype socket" ) or + diag( " error was $@" ); + + is( $testserver->sockdomain, $AF_INET6, "\$testserver->sockdomain for $socktype" ); + is( $testserver->socktype, Socket->$socktype, "\$testserver->socktype for $socktype" ); + + is( $testserver->sockhost, "::1", "\$testserver->sockhost for $socktype" ); + like( $testserver->sockport, qr/^\d+$/, "\$testserver->sockport for $socktype" ); + + my $socket = IO::Socket->new; + $socket->socket( $AF_INET6, Socket->$socktype, 0 ) + or die "Cannot socket() - $!"; + $socket->connect( Socket::pack_sockaddr_in6( $testserver->sockport, Socket::inet_pton( $AF_INET6, "::1" ) ) ) + or die "Cannot connect() - $!"; + + my $testclient = ( $socktype eq "SOCK_STREAM" ) ? + $testserver->accept : + do { $testserver->connect( $socket->sockname ); $testserver }; + + ok( defined $testclient, "accepted test $socktype client" ); + isa_ok( $testclient, "IO::Socket::IP", "\$testclient for $socktype" ); + + is( $testclient->sockdomain, $AF_INET6, "\$testclient->sockdomain for $socktype" ); + is( $testclient->socktype, Socket->$socktype, "\$testclient->socktype for $socktype" ); + + is_deeply( [ Socket::unpack_sockaddr_in6( $socket->sockname ) ], + [ Socket::unpack_sockaddr_in6( $testclient->peername ) ], + "\$socket->sockname for $socktype" ); + + is_deeply( [ Socket::unpack_sockaddr_in6( $socket->peername ) ], + [ Socket::unpack_sockaddr_in6( $testclient->sockname ) ], + "\$socket->peername for $socktype" ); + + my $peerport = ( Socket::unpack_sockaddr_in6 $socket->peername )[0]; + my $sockport = ( Socket::unpack_sockaddr_in6 $socket->sockname )[0]; + + is( $testclient->sockport, $peerport, "\$testclient->sockport for $socktype" ); + is( $testclient->peerport, $sockport, "\$testclient->peerport for $socktype" ); +} diff --git a/cpan/IO-Socket-IP/t/06local-cross-v6.t b/cpan/IO-Socket-IP/t/06local-cross-v6.t new file mode 100644 index 0000000000..9cd1e94a3f --- /dev/null +++ b/cpan/IO-Socket-IP/t/06local-cross-v6.t @@ -0,0 +1,41 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More; + +use IO::Socket::IP; + +eval { IO::Socket::IP->new( LocalHost => "::1" ) } or + plan skip_all => "Unable to bind to ::1"; + +plan tests => 12; + +foreach my $socktype (qw( SOCK_STREAM SOCK_DGRAM )) { + my $testserver = IO::Socket::IP->new( + ( $socktype eq "SOCK_STREAM" ? ( Listen => 1 ) : () ), + LocalHost => "::1", + Type => Socket->$socktype, + ) or die "Cannot listen on PF_INET6 - $@"; + + my $socket = IO::Socket::IP->new( + PeerHost => "::1", + PeerService => $testserver->sockport, + Type => Socket->$socktype, + ) or die "Cannot connect on PF_INET6 - $@"; + + my $testclient = ( $socktype eq "SOCK_STREAM" ) ? + $testserver->accept : + do { $testserver->connect( $socket->sockname ); $testserver }; + + is( $testclient->sockport, $socket->peerport, "\$testclient->sockport for $socktype" ); + is( $testclient->peerport, $socket->sockport, "\$testclient->peerport for $socktype" ); + + is( $testclient->sockhost, $socket->peerhost, "\$testclient->sockhost for $socktype" ); + is( $testclient->peerhost, $socket->sockhost, "\$testclient->peerhost for $socktype" ); + + $socket->write( "Request\n" ); + is( $testclient->getline, "Request\n", "\$socket to \$testclient for $socktype" ); + + $testclient->write( "Response\n" ); + is( $socket->getline, "Response\n", "\$testclient to \$socket for $socktype" ); +} diff --git a/cpan/IO-Socket-IP/t/10args.t b/cpan/IO-Socket-IP/t/10args.t new file mode 100644 index 0000000000..75a5ca0e4d --- /dev/null +++ b/cpan/IO-Socket-IP/t/10args.t @@ -0,0 +1,52 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More; + +use IO::Socket::IP; + +sub arguments_is { + my ($arg, $exp, $name) = @_; + + $arg = [$arg] + unless ref $arg; + + $name ||= join ' ', map { defined $_ ? $_ : 'undef' } @$arg; + + my $got = do { + no warnings 'redefine'; + my $args; + + local *IO::Socket::IP::_configure = sub { + $args = $_[1]; + return $_[0]; + }; + + IO::Socket::IP->new(@$arg); + + $args; + }; + + is_deeply($got, $exp, $name); +} + +my @tests = ( + [ [ '[::1]:80' ], { PeerHost => '::1', PeerService => '80' } ], + [ [ '[::1]:http' ], { PeerHost => '::1', PeerService => 'http' } ], + [ [ '[::1]' ], { PeerHost => '::1', } ], + [ [ '[::1]:' ], { PeerHost => '::1', } ], + [ [ '127.0.0.1:80' ], { PeerHost => '127.0.0.1', PeerService => '80' } ], + [ [ '127.0.0.1:http' ], { PeerHost => '127.0.0.1', PeerService => 'http' } ], + [ [ '127.0.0.1' ], { PeerHost => '127.0.0.1', } ], + [ [ '127.0.0.1:' ], { PeerHost => '127.0.0.1', } ], + [ [ 'localhost:80' ], { PeerHost => 'localhost', PeerService => '80' } ], + [ [ 'localhost:http' ], { PeerHost => 'localhost', PeerService => 'http' } ], + [ [ PeerHost => '[::1]:80' ], { PeerHost => '::1', PeerService => '80' } ], + [ [ PeerHost => '[::1]' ], { PeerHost => '::1' } ], + [ [ LocalHost => '[::1]:80' ], { LocalHost => '::1', LocalService => '80' } ], + [ [ LocalHost => undef ], { LocalHost => undef } ], +); + +plan tests => scalar(@tests); + +arguments_is(@$_) for @tests; diff --git a/cpan/IO-Socket-IP/t/11sockopts.t b/cpan/IO-Socket-IP/t/11sockopts.t new file mode 100644 index 0000000000..a0828c2b73 --- /dev/null +++ b/cpan/IO-Socket-IP/t/11sockopts.t @@ -0,0 +1,43 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More tests => 3; + +use IO::Socket::IP; + +use Socket qw( SOL_SOCKET SO_REUSEADDR SO_REUSEPORT SO_BROADCAST ); + +{ + my $sock = IO::Socket::IP->new( + LocalHost => "127.0.0.1", + Type => SOCK_STREAM, + Listen => 1, + ReuseAddr => 1, + ) or die "Cannot socket() - $@"; + + ok( $sock->getsockopt( SOL_SOCKET, SO_REUSEADDR ), 'SO_REUSEADDR set' ); +} + +SKIP: { + # Some OSes don't implement SO_REUSEPORT + skip "No SO_REUSEPORT", 1 unless defined eval { SO_REUSEPORT }; + + my $sock = IO::Socket::IP->new( + LocalHost => "127.0.0.1", + Type => SOCK_STREAM, + Listen => 1, + ReusePort => 1, + ) or die "Cannot socket() - $@"; + + ok( $sock->getsockopt( SOL_SOCKET, SO_REUSEPORT ), 'SO_REUSEPORT set' ); +} + +{ + my $sock = IO::Socket::IP->new( + LocalHost => "127.0.0.1", + Type => SOCK_DGRAM, + Broadcast => 1, + ) or die "Cannot socket() - $@"; + + ok( $sock->getsockopt( SOL_SOCKET, SO_BROADCAST ), 'SO_BROADCAST set' ); +} diff --git a/cpan/IO-Socket-IP/t/12port-fallback.t b/cpan/IO-Socket-IP/t/12port-fallback.t new file mode 100644 index 0000000000..732d20eea1 --- /dev/null +++ b/cpan/IO-Socket-IP/t/12port-fallback.t @@ -0,0 +1,42 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More tests => 1; + +use IO::Socket::IP; +use Socket 1.95 qw( + PF_INET SOCK_STREAM IPPROTO_TCP pack_sockaddr_in INADDR_ANY + AI_PASSIVE +); + +my $AI_ADDRCONFIG = eval { Socket::AI_ADDRCONFIG() } || 0; + +my @gai_args; +my @gai_rets; + +no strict 'refs'; +no warnings 'redefine'; + +*{"IO::Socket::IP::getaddrinfo"} = sub { + push @gai_args, [ @_ ]; + return @{ shift @gai_rets }; +}; + +@gai_rets = ( + [ "Service unknown" ], + [ "", { + family => PF_INET, + socktype => SOCK_STREAM, + protocol => IPPROTO_TCP, + addr => pack_sockaddr_in( 80, INADDR_ANY ) + } ], +); + +IO::Socket::IP->new( LocalPort => "zyxxyblarg(80)" ); + +is_deeply( \@gai_args, + [ + [ undef, "zyxxyblarg", { flags => AI_PASSIVE|$AI_ADDRCONFIG, socktype => SOCK_STREAM, protocol => IPPROTO_TCP } ], + [ undef, "80", { flags => AI_PASSIVE|$AI_ADDRCONFIG, socktype => SOCK_STREAM, protocol => IPPROTO_TCP } ], + ], + '@gai_args for LocalPort => "zyxxyblarg(80)"' ); diff --git a/cpan/IO-Socket-IP/t/13addrinfo.t b/cpan/IO-Socket-IP/t/13addrinfo.t new file mode 100644 index 0000000000..b293101f1b --- /dev/null +++ b/cpan/IO-Socket-IP/t/13addrinfo.t @@ -0,0 +1,53 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More tests => 4; + +use IO::Socket::IP; + +use IO::Socket::INET; +use Socket qw( SOCK_STREAM unpack_sockaddr_in getaddrinfo ); + +{ + my $testserver = IO::Socket::INET->new( + Listen => 1, + LocalHost => "127.0.0.1", + Type => SOCK_STREAM, + ) or die "Cannot listen on PF_INET - $@"; + + my ( $err, @peeraddrinfo ) = getaddrinfo( "127.0.0.1", $testserver->sockport, { socktype => SOCK_STREAM } ); + $err and die "Cannot getaddrinfo 127.0.0.1 - $err"; + + my $socket = IO::Socket::IP->new( + PeerAddrInfo => \@peeraddrinfo, + ); + + ok( defined $socket, 'IO::Socket::IP->new( PeerAddrInfo => ... ) constructs a new socket' ) or + diag( " error was $@" ); + + is_deeply( [ unpack_sockaddr_in $socket->peername ], + [ unpack_sockaddr_in $testserver->sockname ], + '$socket->peername' ); +} + +{ + my ( $err, @localaddrinfo ) = getaddrinfo( "127.0.0.1", 0, { socktype => SOCK_STREAM } ); + $err and die "Cannot getaddrinfo 127.0.0.1 - $err"; + + my $socket = IO::Socket::IP->new( + Listen => 1, + LocalAddrInfo => \@localaddrinfo, + ); + + ok( defined $socket, 'IO::Socket::IP->new( LocalAddrInfo => ... ) constructs a new socket' ) or + diag( " error was $@" ); + + my $testclient = IO::Socket::INET->new( + PeerHost => "127.0.0.1", + PeerPort => $socket->sockport, + ) or die "Cannot connect to localhost - $@"; + + is_deeply( [ unpack_sockaddr_in $socket->sockname ], + [ unpack_sockaddr_in $testclient->peername ], + '$socket->sockname' ); +} diff --git a/cpan/IO-Socket-IP/t/14fileno.t b/cpan/IO-Socket-IP/t/14fileno.t new file mode 100644 index 0000000000..cc3f895a66 --- /dev/null +++ b/cpan/IO-Socket-IP/t/14fileno.t @@ -0,0 +1,24 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More tests => 2; + +use IO::Socket::IP; +use Socket qw( AF_INET SOCK_STREAM ); + +socket( my $tmph, AF_INET, SOCK_STREAM, 0 ) or die "Cannot socket() - $!"; + +my $socket = IO::Socket::IP->new or die "Cannot create IO::Socket::IP - $@"; + +$socket->socket( AF_INET, SOCK_STREAM, 0 ) or die "Cannot socket() - $!"; +my $fileno = $socket->fileno; + +$socket->socket( AF_INET, SOCK_STREAM, 0 ) or die "Cannot socket() - $!"; + +is( $socket->fileno, $fileno, '$socket->fileno preserved after ->socket' ); + +close $tmph; + +$socket->socket( AF_INET, SOCK_STREAM, 0 ) or die "Cannot socket() - $!"; + +is( $socket->fileno, $fileno, '$socket->fileno preserved after ->socket with free handle' ); diff --git a/cpan/IO-Socket-IP/t/15io-socket.t b/cpan/IO-Socket-IP/t/15io-socket.t new file mode 100644 index 0000000000..e8cecda3af --- /dev/null +++ b/cpan/IO-Socket-IP/t/15io-socket.t @@ -0,0 +1,34 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More tests => 2; + +use IO::Socket; +use IO::Socket::IP -register; + +my $sock = IO::Socket->new( + Domain => AF_INET, + Type => SOCK_STREAM, + LocalHost => "127.0.0.1", + LocalPort => 0, +); + +isa_ok( $sock, "IO::Socket::IP", 'IO::Socket->new( Domain => AF_INET )' ); + +SKIP: { + my $AF_INET6 = eval { Socket::AF_INET6() } || + eval { require Socket6; Socket6::AF_INET6() }; + $AF_INET6 or skip "No AF_INET6", 1; + eval { IO::Socket::IP->new( LocalHost => "::1" ) } or + skip "Unable to bind to ::1", 1; + + my $sock = IO::Socket->new( + Domain => $AF_INET6, + Type => SOCK_STREAM, + LocalHost => "::1", + LocalPort => 0, + ); + + isa_ok( $sock, "IO::Socket::IP", 'IO::Socket->new( Domain => AF_INET6 )' ) or + diag( " error was $@" ); +} diff --git a/cpan/IO-Socket-IP/t/20nonblocking-connect.t b/cpan/IO-Socket-IP/t/20nonblocking-connect.t new file mode 100644 index 0000000000..2566c06269 --- /dev/null +++ b/cpan/IO-Socket-IP/t/20nonblocking-connect.t @@ -0,0 +1,48 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More tests => 8; + +use IO::Socket::IP; + +use IO::Socket::INET; +use Errno qw( EINPROGRESS EWOULDBLOCK ); + +my $testserver = IO::Socket::INET->new( + Listen => 1, + LocalHost => "127.0.0.1", + Type => SOCK_STREAM, +) or die "Cannot listen on PF_INET - $@"; + +my $socket = IO::Socket::IP->new( + PeerHost => "127.0.0.1", + PeerService => $testserver->sockport, + Type => SOCK_STREAM, + Blocking => 0, +); + +ok( defined $socket, 'IO::Socket::IP->new( Blocking => 0 ) constructs a socket' ) or + diag( " error was $@" ); + +while( !$socket->connect and ( $! == EINPROGRESS || $! == EWOULDBLOCK ) ) { + my $wvec = ''; + vec( $wvec, fileno $socket, 1 ) = 1; + my $evec = ''; + vec( $evec, fileno $socket, 1 ) = 1; + + select( undef, $wvec, $evec, undef ) or die "Cannot select() - $!"; +} + +ok( !$!, 'Repeated ->connect eventually succeeds' ); + +is( $socket->sockdomain, AF_INET, '$socket->sockdomain' ); +is( $socket->socktype, SOCK_STREAM, '$socket->socktype' ); + +is_deeply( [ unpack_sockaddr_in $socket->peername ], + [ unpack_sockaddr_in $testserver->sockname ], + '$socket->peername' ); + +is( $socket->peerhost, "127.0.0.1", '$socket->peerhost' ); +is( $socket->peerport, $testserver->sockport, '$socket->peerport' ); + +ok( !$socket->blocking, '$socket->blocking' ); diff --git a/cpan/IO-Socket-IP/t/21nonblocking-connect-internet.t b/cpan/IO-Socket-IP/t/21nonblocking-connect-internet.t new file mode 100644 index 0000000000..e946221dfe --- /dev/null +++ b/cpan/IO-Socket-IP/t/21nonblocking-connect-internet.t @@ -0,0 +1,99 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More tests => 10; + +use IO::Socket::IP; + +use IO::Socket::INET; +use Errno qw( EINPROGRESS EWOULDBLOCK ECONNREFUSED ); + +# Chris Williams (BINGOS) has offered cpanidx.org as a TCP testing server here +my $test_host = "cpanidx.org"; +my $test_good_port = 80; +my $test_bad_port = 6666; + +SKIP: { + IO::Socket::INET->new( + PeerHost => $test_host, + PeerPort => $test_good_port, + Type => SOCK_STREAM, + ) or skip "Can't connect to $test_host:$test_good_port", 5; + + my $socket = IO::Socket::IP->new( + PeerHost => $test_host, + PeerService => $test_good_port, + Type => SOCK_STREAM, + Blocking => 0, + ); + + ok( defined $socket, "defined \$socket for $test_host:$test_good_port" ) or + diag( " error was $@" ); + + # This and test is required to placate a warning IO::Socket would otherwise + # throw; https://rt.cpan.org/Ticket/Display.html?id=63052 + ok( not( $socket->opened and $socket->connected ), '$socket not yet connected' ); + + my $selectcount = 0; + + while( !$socket->connect and ( $! == EINPROGRESS || $! == EWOULDBLOCK ) ) { + my $wvec = ''; + vec( $wvec, fileno $socket, 1 ) = 1; + my $evec = ''; + vec( $evec, fileno $socket, 1 ) = 1; + + $selectcount++; + my $ret = select( undef, $wvec, $evec, 60 ); + defined $ret or die "Cannot select() - $!"; + $ret or die "select() timed out"; + } + + ok( !$!, '->connect eventually succeeds' ); + ok( $selectcount > 0, '->connect had to select() at least once' ); + + ok( $socket->connected, '$socket now connected' ); +} + +SKIP: { + IO::Socket::INET->new( + PeerHost => $test_host, + PeerPort => $test_bad_port, + Type => SOCK_STREAM, + ) and skip "Connecting to $test_host:$test_bad_port succeeds", 5; + $! == ECONNREFUSED or skip "Connecting to $test_host:$test_bad_port doesn't give ECONNREFUSED", 5; + + my $socket = IO::Socket::IP->new( + PeerHost => $test_host, + PeerService => $test_bad_port, + Type => SOCK_STREAM, + Blocking => 0, + ); + + ok( defined $socket, "defined \$socket for $test_host:$test_bad_port" ) or + diag( " error was $@" ); + + ok( not( $socket->opened and $socket->connected ), '$socket not yet connected' ); + + my $selectcount = 0; + + while( !$socket->connect and ( $! == EINPROGRESS || $! == EWOULDBLOCK ) ) { + my $wvec = ''; + vec( $wvec, fileno $socket, 1 ) = 1; + my $evec = ''; + vec( $evec, fileno $socket, 1 ) = 1; + + $selectcount++; + my $ret = select( undef, $wvec, $evec, 60 ); + defined $ret or die "Cannot select() - $!"; + $ret or die "select() timed out"; + } + + my $dollarbang = $!; + + ok( $dollarbang == ECONNREFUSED, '->connect eventually fails with ECONNREFUSED' ) or + diag( " dollarbang = $dollarbang" ); + + ok( $selectcount > 0, '->connect had to select() at least once' ); + + ok( !$socket->opened, '$socket is not even opened' ); +} |