SYN SYN

[p5sagit/p5-mst-13.2.git] / ext / IO / lib / IO / Socket.pm

diff --git a/ext/IO/lib/IO/Socket.pm b/ext/IO/lib/IO/Socket.pm
index 0bdf2ff..b8da092 100644 (file)
--- a/ext/IO/lib/IO/Socket.pm
+++ b/ext/IO/lib/IO/Socket.pm
@@ -6,23 +6,24 @@
 
 package IO::Socket;
 
-require 5.000;
+require 5.005_64;
 
 use IO::Handle;
 use Socket 1.3;
 use Carp;
 use strict;
-use vars qw(@ISA $VERSION);
+our(@ISA, $VERSION);
 use Exporter;
+use Errno;
 
 # legacy
 
 require IO::Socket::INET;
-require IO::Socket::UNIX;
+require IO::Socket::UNIX if ($^O ne 'epoc');
 
 @ISA = qw(IO::Handle);
 
-$VERSION = "1.251";
+$VERSION = "1.26";
 
 sub import {
     my $pkg = shift;
@@ -81,7 +82,7 @@ sub socket {
 }
 
 sub socketpair {
-    @_ == 4 || croak 'usage: IO::Socket->pair(DOMAIN, TYPE, PROTOCOL)';
+    @_ == 4 || croak 'usage: IO::Socket->socketpair(DOMAIN, TYPE, PROTOCOL)';
     my($class,$domain,$type,$protocol) = @_;
     my $sock1 = $class->new();
     my $sock2 = $class->new();
@@ -100,35 +101,38 @@ sub connect {
     my $sock = shift;
     my $addr = shift;
     my $timeout = ${*$sock}{'io_socket_timeout'};
-
+    my $err;
     my $blocking;
     $blocking = $sock->blocking(0) if $timeout;
 
-    eval {
-       croak 'connect: Bad address'
-           if(@_ == 2 && !defined $_[1]);
-
-       unless(connect($sock, $addr)) {
-           if($timeout && ($! == &IO::EINPROGRESS)) {
-               require IO::Select;
+    if (!connect($sock, $addr)) {
+       if ($timeout && $!{EINPROGRESS}) {
+           require IO::Select;
 
-               my $sel = new IO::Select $sock;
+           my $sel = new IO::Select $sock;
 
-               unless($sel->can_write($timeout) && defined($sock->peername)) {
-                   croak "connect: timeout";
-               }
+           if (!$sel->can_write($timeout)) {
+               $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
+               $@ = "connect: timeout";
            }
-           else {
-               croak "connect: $!";
+           elsif(!connect($sock,$addr) && not $!{EISCONN}) {
+               # Some systems refuse to re-connect() to
+               # an already open socket and set errno to EISCONN.
+               $err = $!;
+               $@ = "connect: $!";
            }
        }
-    };
+       else {
+           $err = $!;
+           $@ = "connect: $!";
+       }
+    }
 
-    my $ret = $@ ? undef : $sock;
+    $sock->blocking(1) if $blocking;
 
-    $sock->blocking($blocking) if $timeout;
+    $! = $err if $err;
 
-    $ret;
+    $err ? undef : $sock;
 }
 
 sub bind {
@@ -158,22 +162,23 @@ sub accept {
     my $new = $pkg->new(Timeout => $timeout);
     my $peer = undef;
 
-    eval {
-       if($timeout) {
-           require IO::Select;
+    if($timeout) {
+       require IO::Select;
 
-           my $sel = new IO::Select $sock;
+       my $sel = new IO::Select $sock;
+
+       unless ($sel->can_read($timeout)) {
+           $@ = 'accept: timeout';
+           $! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
+           return;
+       }
+    }
 
-           croak "accept: timeout"
-               unless $sel->can_read($timeout);
-       }
-       $peer = accept($new,$sock) || undef;
-    };
+    $peer = accept($new,$sock)
+       or return;
 
-    return wantarray ? defined $peer ? ($new, $peer)
-                                    : () 
-                    : defined $peer ? $new
-                                    : undef;
+    return wantarray ? ($new, $peer)
+                    : $new;
 }
 
 sub sockname {
@@ -279,7 +284,7 @@ sub socktype {
 sub protocol {
     @_ == 1 or croak 'usage: $sock->protocol()';
     my($sock) = @_;
-    ${*$sock}{'io_socket_protocol'};
+    ${*$sock}{'io_socket_proto'};
 }
 
 1;
@@ -320,7 +325,7 @@ the socket will be in. All other arguments will be passed to the
 configuration method of the package for that domain, See below.
 
  NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
- 
+
 As of VERSION 1.18 all IO::Socket objects have autoflush turned on
 by default. This was not the case with earlier releases.
 
@@ -356,11 +361,20 @@ perform the system call C<accept> on the socket and return a new object. The
 new object will be created in the same class as the listen socket, unless
 C<PKG> is specified. This object can be used to communicate with the client
 that was trying to connect. In a scalar context the new socket is returned,
-or undef upon failure. In an array context a two-element array is returned
-containing the new socket and the peer address, the list will
+or undef upon failure. In a list context a two-element array is returned
+containing the new socket and the peer address; the list will
 be empty upon failure.
 
-Additional methods that are provided are
+=item socketpair(DOMAIN, TYPE, PROTOCOL)
+
+Call C<socketpair> and return a list of two sockets created, or an
+empty list on failure.
+
+=back
+
+Additional methods that are provided are:
+
+=over 4
 
 =item timeout([VAL])
 
@@ -402,7 +416,8 @@ L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>
 
 =head1 AUTHOR
 
-Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
+Graham Barr. Currently maintained by the Perl Porters.  Please report all
+bugs to <perl5-porters@perl.org>.
 
 =head1 COPYRIGHT