Fix precedence problem in IO::Socket::connect() from 80d2c56d79

[perl5.git] / dist / IO / lib / IO / Socket.pm

diff --git a/dist/IO/lib/IO/Socket.pm b/dist/IO/lib/IO/Socket.pm
index 06e4e6c..d41f80b 100644 (file)
--- a/dist/IO/lib/IO/Socket.pm
+++ b/dist/IO/lib/IO/Socket.pm
@@ -1,3 +1,4 @@
+
 # IO::Socket.pm
 #
 # Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
@@ -23,7 +24,7 @@ require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian');
 
 @ISA = qw(IO::Handle);
 
-$VERSION = "1.32";
+$VERSION = "1.37";
 
 @EXPORT_OK = qw(sockatmark);
 
@@ -118,27 +119,29 @@ sub connect {
            my $sel = new IO::Select $sock;
 
            undef $!;
-            my($r,$w,$e) = IO::Select::select(undef,$sel,$sel,$timeout);
-            if(@$e[0]) {
-                # Windows return from select after the timeout in case of
-                # WSAECONNREFUSED(10061) if exception set is not used.
-                # This behavior is different from Linux.
-                # Using the exception
-                # set we now emulate the behavior in Linux 
-                #    - Karthik Rajagopalan
-                $err = $sock->getsockopt(SOL_SOCKET,SO_ERROR);
-                $@ = "connect: $err";
-            }
-            elsif(!@$w[0]) {
-                $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
-                $@ = "connect: timeout";
-            }
+           my($r,$w,$e) = IO::Select::select(undef,$sel,$sel,$timeout);
+           if(@$e[0]) {
+               # Windows return from select after the timeout in case of
+               # WSAECONNREFUSED(10061) if exception set is not used.
+               # This behavior is different from Linux.
+               # Using the exception
+               # set we now emulate the behavior in Linux
+               #    - Karthik Rajagopalan
+               $err = $sock->getsockopt(SOL_SOCKET,SO_ERROR);
+               $@ = "connect: $err";
+           }
+           elsif(!@$w[0]) {
+               $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
+               $@ = "connect: timeout";
+           }
            elsif (!connect($sock,$addr) &&
-                not ($!{EISCONN} || ($! == 10022 && $^O eq 'MSWin32'))
+                not ($!{EISCONN} || ($^O eq 'MSWin32' &&
+                ($! == ($] < 5.019004) ? 10022 : Errno::EINVAL)))
             ) {
                # Some systems refuse to re-connect() to
                # an already open socket and set errno to EISCONN.
-               # Windows sets errno to WSAEINVAL (10022)
+               # Windows sets errno to WSAEINVAL (10022) (pre-5.19.4) or
+               # EINVAL (22) (5.19.4 onwards).
                $err = $!;
                $@ = "connect: $!";
            }
@@ -166,7 +169,7 @@ sub blocking {
     my $sock = shift;
 
     return $sock->SUPER::blocking(@_)
-        if $^O ne 'MSWin32';
+        if $^O ne 'MSWin32' && $^O ne 'VMS';
 
     # Windows handles blocking differently
     #
@@ -248,6 +251,8 @@ sub accept {
     $peer = accept($new,$sock)
        or return;
 
+    ${*$new}{$_} = ${*$sock}{$_} for qw( io_socket_domain io_socket_type io_socket_proto );
+
     return wantarray ? ($new, $peer)
                     : $new;
 }
@@ -348,18 +353,27 @@ sub timeout {
 sub sockdomain {
     @_ == 1 or croak 'usage: $sock->sockdomain()';
     my $sock = shift;
+    if (!defined(${*$sock}{'io_socket_domain'})) {
+       my $addr = $sock->sockname();
+       ${*$sock}{'io_socket_domain'} = sockaddr_family($addr)
+           if (defined($addr));
+    }
     ${*$sock}{'io_socket_domain'};
 }
 
 sub socktype {
     @_ == 1 or croak 'usage: $sock->socktype()';
     my $sock = shift;
+    ${*$sock}{'io_socket_type'} = $sock->sockopt(Socket::SO_TYPE)
+       if (!defined(${*$sock}{'io_socket_type'}) && defined(eval{Socket::SO_TYPE}));
     ${*$sock}{'io_socket_type'}
 }
 
 sub protocol {
     @_ == 1 or croak 'usage: $sock->protocol()';
     my($sock) = @_;
+    ${*$sock}{'io_socket_proto'} = $sock->sockopt(Socket::SO_PROTOCOL)
+       if (!defined(${*$sock}{'io_socket_proto'}) && defined(eval{Socket::SO_PROTOCOL}));
     ${*$sock}{'io_socket_proto'};
 }
 
@@ -528,6 +542,12 @@ value returned.
 
 =back
 
+=head1 LIMITATIONS
+
+On some systems, for an IO::Socket object created with new_from_fd(),
+or created with accept() from such an object, the protocol(),
+sockdomain() and socktype() methods may return undef.
+
 =head1 SEE ALSO
 
 L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>
@@ -535,7 +555,7 @@ L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>
 =head1 AUTHOR
 
 Graham Barr.  atmark() by Lincoln Stein.  Currently maintained by the
-Perl Porters.  Please report all bugs to <perl5-porters@perl.org>.
+Perl Porters.  Please report all bugs to <perlbug@perl.org>.
 
 =head1 COPYRIGHT