[perl #27044] IO::Socket::INET nonblocking mode fails on Win32 - here is the fix

# New Ticket Created by  cnd@spamcop.net 
# Please include the string:  [perl #27044]
# in the subject line of all future correspondence about this issue. 
# <URL: http://rt.perl.org:80/rt3/Ticket/Display.html?id=27044 >


This is a bug report for perl from cnd@spamcop.net,
generated with the help of perlbug 1.33 running under perl v5.6.1.


-----------------------------------------------------------------
[Please enter your report here]

Subject: IO::Socket::INET nonblocking mode fails on Win32 - here is the fix

Ignore the "Site configuration information" below. this bug is present in
all IO::Socket::INET distributions up to and including 5.8.3

As per the subject - "Blocking" doesn't work under Win32. Specifically,
this call fails:-

$sockets{$ip}=IO::Socket::INET->new(PeerAddr=>$ip, PeerPort=>$p, 
       Proto=>$Proto, Type=>$Type, ReuseAddr=>1, Blocking=>0)

(exactly *how* it fails differs between perl versions, but it always 
fails)

In summary -

1. the Win32 "$sock->blocking($arg->{Blocking})" call succeeds,
   despite the fact that it appears to come back with an error code
   under Win32.  So this line, although it actually works fine,
   wrongly stops the show:-

   defined $sock->blocking($arg->{Blocking})
     or return _error($sock, $!, "$!");

2. You've got to do these 2 things immediately before calling
   connect() otherwise it will block anyway (despite the above)

   setsockopt($sock, SOL_SOCKET, SO_DONTLINGER, 1); # Dont block on close

   and
   
   my $temp = 1; ioctl($sock, 0x8004667E, \$temp); # Don't let it block us.

3. The Win32 "connect()" call succeeds, although once again it appears
   to come back with an error code, so the show gets stopped wrongly
   again, unless you add this line after it (to return the correctly
   connected socket handle):

   return $sock if(($sock) &&( $arg->{Blocking} == 0 )); # Win32 requires this line

If you want to email me - cnd@spamcop.net - the source code of the
most recent INET.pm you've got lying around, I'll fix and test it
under Win32 and Linux and send it back.
   
Below is a test script.

I fixed the "INET.pm" module - here is an MS-DOS "fc" output showing
what you need to alter to make non-blocking work.  "inet583.pm" is 
your original file. "INET582.PM" is my fixed version.



Comparing files inet583.pm and INET582.PM
***** inet583.pm
        if (defined $arg->{Blocking}) {
            defined $sock->blocking($arg->{Blocking})
                or return _error($sock, $!, "$!");
        }
***** INET582.PM
        if (defined $arg->{Blocking}) {
          # defined $sock->blocking($arg->{Blocking}) # <-- this line always "fails" on Win32
          $sock->blocking(0) if($arg->{Blocking}==0); # Blocking=>1 is already the default anyhow.
        }
*****

***** inet583.pm

        undef $@;
        if ($sock->connect(pack_sockaddr_in($rport, $raddr))) {
#            ${*$sock}{'io_socket_timeout'} = $timeout;
            return $sock;
        }
***** INET582.PM

        # these 13 lines contributed by Chris Drake:-
        if(defined $arg->{Blocking}) {
          if($arg->{Blocking}) {
            $sock->blocking($arg->{Blocking})
          } else {
            if($^O =~/Win32/i) {
              setsockopt($sock, SOL_SOCKET, SO_DONTLINGER, 1); # Dont block on close 
            } else {
              $sock->blocking(0);
            }
            my $temp = 1; ioctl($sock, 0x8004667E, \$temp); # Don't let it block us.
          }
        }
*****

***** inet583.pm

        return _error($sock, $!, $@ || "Timeout")
***** INET582.PM

        undef $@;
        if ($sock->connect(pack_sockaddr_in($rport, $raddr))) {
#            ${*$sock}{'io_socket_timeout'} = $timeout;
            return $sock;
        }

        return $sock if(($sock) &&( $arg->{Blocking} == 0 )); # Win32 requires this line

        return _error($sock, $!, $@ || "Timeout")
*****

***** inet583.pm

***** INET582.PM
*****







Here is my test script.  It will fail under Win32 until you make the above
corrections, and then it will work nicely.









#!/usr/bin/perl

# This file is "block.pl" by Chris Drake.

use strict;
use bytes;
use Time::HiRes qw(time);
use IO::Socket;         # For the server



my %sockets;
# my $ip="203.2.192.76";
my $ip="65.54.190.230";   # This is a hotmail mail server - change to some other IP to experiment with blocking
my $p=25;
my $Proto='tcp';
my $Type=SOCK_STREAM;
my $Timeout=3;

# if ($sockets{$ip}=IO::Socket::INET->new(PeerAddr=>$ip, PeerPort=>$p, Proto=>$Proto, Type=>$Type, ReuseAddr=>1 ) ) {
if ($sockets{$ip}=IO::Socket::INET->new(PeerAddr=>$ip, PeerPort=>$p, Proto=>$Proto, Type=>$Type, ReuseAddr=>1, Blocking=>0) ) {
  warn "yes";
} else {
  warn "no";
}

warn "s='$sockets{$ip}' e=$!";

my($b)='';
vec($b,fileno($sockets{$ip}),1)=1;

my($r,$w,$e);

while(1) {
  my $n=select($r=$b,$w=$b,$e=$b,$Timeout);
  my $rp=unpack("B*",$r);
  my $wp=unpack("B*",$w);
  my $ep=unpack("B*",$e);
  print "n=$n r=$rp w=$wp e=$ep\n";
  if(vec($r,fileno($sockets{$ip}),1)==1) {
    my $buff;
    sysread($sockets{$ip},$buff,16384);
    print "buff:-\n$buff\n";
    close($sockets{$ip});
    exit(0);
  }
}



#######################################################################

=head2 FirstSocket

Connects to every supplied IP address, returning the first one that accepts us.
you cn use 'ip:port' in the list - if no :port, uses $PeerPort by default.

B<Input Paramaters>

        $Proto          # 'tcp' usually (anything else is untested)
        $Type           # SOCK_STREAM usually (anything else is untested)
        $Timeout        # max number of seconds to wait before giving up on them all
        $PeerPort       # default port (used if not specified in the list)
        @ips            # list of IP addresses to try. (see ValidEmail(,2));

B<Output>       (3 element list of...)

        open socket glob
        ip address we used
        first 16k of data read from the open socket

=cut
#######################################################################
sub FirstSocket {
  my($Proto,$Type,$Timeout,$PeerPort,@ips)=@_;
  undef %sockets; my($now)=time; my($some,$bits_server,$null_server,$r,$w,$e)=(0,'','');
  # my(%switch); #=('debug' => 1);
  my(%switch)=('debug' => 1);
  foreach my $ipp (@ips) {
    my($ip,$p)=split(':',$ipp,2); $p=$PeerPort unless($p);
    #NB: Blocking=>0 fails unless the latest/fixed IO/Socket/INET.pm is loaded (): this must be inside their while(1) loop:-
    #   defined $sock->blocking($arg->{Blocking})  (see) http://search.cpan.org/src/NWCLARK/perl-5.8.3/ext/IO/lib/IO/Socket/INET.pm
    $sockets{$ip}=IO::Socket::INET->new(PeerAddr=>$ip, PeerPort=>$p, Proto=>$Proto, Type=>$Type, ReuseAddr=>1, Blocking=>0);
    &write_log("FirstSocket trying $ip") if($switch{'debug'});
    $some++;
  }
  while(($some)&&((time-$now)<=$Timeout)) {
    $bits_server='';
    foreach my $ip (keys %sockets) {
      vec($bits_server,fileno($sockets{$ip}),1)=1 if($sockets{$ip});
    }
    #if(select($r=$bits_server,$w=$bits_server,$e=$bits_server,$Timeout)) { # Wait for read to be allowed}
    if(select($r=$bits_server,undef,$e=$bits_server,$Timeout)) { # Wait for read to be allowed
      foreach my $ip (keys %sockets) {
        if($sockets{$ip}) {
          if(vec($e,fileno($sockets{$ip}),1)) {         # Error
            close($sockets{$ip});undef $sockets{$ip};$some--;
            &write_log("FirstSocket connect error: $ip") if($switch{'debug'});
          } elsif(vec($r,fileno($sockets{$ip}),1)) {    # Reading is OK
            my($buff); recv($sockets{$ip}, $buff, 16384, 0); # Read upto 16K
            if(length($buff)==0) {                      # Error
              close($sockets{$ip});undef $sockets{$ip};$some--;
              &write_log("FirstSocket read error: $ip") if($switch{'debug'});
            } else {                                    # Great - got one!
              foreach my $ip2 (keys %sockets) {
                close($sockets{$ip2}) if(($sockets{$ip2})&&($ip ne $ip2));# Close all the others
              }
              &write_log("FirstSocket success: $ip") if($switch{'debug'});
              return ($sockets{$ip},$ip,$buff);
            }
          }
        }
      }
      &write_log("Waiting on $some ...") if($switch{'debug'});   
    }
  }
  &write_log("FirstSocket nothing worked in ". (time-$now) ." seconds") if($switch{'debug'});
  return(undef,undef,undef);
}


# Print out debugging info
sub write_log {
    my($message)=@_;
    my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
    my($date)=sprintf("%02d/%02d %02d:%02d.%02d",$mon+1,$mday,$hour,$min,$sec);
    print "$date $$ emailcheck.pl $message\n";
}

# chomp() on unix doesn't eat "\r"...
sub chompnl {
  chop $_[0] while((substr($_[0],-1) eq "\015")||(substr($_[0],-1) eq "\012"));
}

sub ServerName {
  return "hotmail.com";
}













[Please do not change anything below this line]
-----------------------------------------------------------------
---
Flags:
    category=core
    severity=low
---
Site configuration information for perl v5.6.1:

Configured by ActiveState at Mon Jun 17 21:32:50 2002.

Summary of my perl5 (revision 5 version 6 subversion 1) configuration:
  Platform:
    osname=MSWin32, osvers=4.0, archname=MSWin32-x86-multi-thread
    uname=''
    config_args='undef'
    hint=recommended, useposix=true, d_sigaction=undef
    usethreads=undef use5005threads=undef useithreads=define usemultiplicity=define
    useperlio=undef d_sfio=undef uselargefiles=undef usesocks=undef
    use64bitint=undef use64bitall=undef uselongdouble=undef
  Compiler:
    cc='cl', ccflags ='-nologo -O1 -MD -DNDEBUG -DWIN32 -D_CONSOLE -DNO_STRICT -DHAVE_DES_FCRYPT  -DPERL_IMPLICIT_CONTEXT -DPERL_IMPLICIT_SYS -DPERL_MSVCRT_READFIX',
    optimize='-O1 -MD -DNDEBUG',
    cppflags='-DWIN32'
    ccversion='', gccversion='', gccosandvers=''
    intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234
    d_longlong=undef, longlongsize=8, d_longdbl=define, longdblsize=10
    ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=4
    alignbytes=8, usemymalloc=n, prototype=define
  Linker and Libraries:
    ld='link', ldflags ='-nologo -nodefaultlib -release  -libpath:"C:/Perl\lib\CORE"  -machine:x86'
    libpth="C:\Program Files\Microsoft Visual Studio .NET\FrameworkSDK\Lib\" "C:\Perl\lib\CORE"
    libs=  oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib  comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib  netapi32.lib uuid.lib wsock32.lib mpr.lib winmm.lib  version.lib odbc32.lib odbccp32.lib msvcrt.lib
    perllibs=  oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib  comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib  netapi32.lib uuid.lib wsock32.lib mpr.lib winmm.lib  version.lib odbc32.lib odbccp32.lib msvcrt.lib
    libc=msvcrt.lib, so=dll, useshrplib=yes, libperl=perl56.lib
  Dynamic Linking:
    dlsrc=dl_win32.xs, dlext=dll, d_dlsymun=undef, ccdlflags=' '
    cccdlflags=' ', lddlflags='-dll -nologo -nodefaultlib -release  -libpath:"C:/Perl\lib\CORE"  -machine:x86'

Locally applied patches:
    ACTIVEPERL_LOCAL_PATCHES_ENTRY

---
@INC for perl v5.6.1:
    C:/Perl/lib
    C:/Perl/site/lib
    .

---
Environment for perl v5.6.1:
    HOME (unset)
    LANG (unset)
    LANGUAGE (unset)
    LD_LIBRARY_PATH (unset)
    LOGDIR (unset)
    PATH=C:\Perl\bin\;C:\WINDOWS\system32;C:\WINDOWS;C:\WINDOWS\System32\Wbem;C:\Program Files\ATI Technologies\ATI Control Panel;C:\Program Files\SecureCRT\;C:\DOS;C:\WINDOWS\ORANT\bin;C:\PROGRA~1\COMMON~1\MGISHA~1\Video;C:\PROGRA~1\COMMON~1\MGISHA~1\SHARED~1\Bin;C:\Program Files\Microsoft Visual Studio\Common\Tools\WinNT;C:\Program Files\Microsoft Visual Studio\Common\MSDev98\Bin;C:\Program Files\Microsoft Visual Studio\Common\Tools;C:\Program Files\Microsoft Visual Studio\VC98\bin
    PERLDB_OPTS=RemotePort=127.0.0.1:2000
    PERL_BADLANG (unset)
    SHELL (unset)

• [perl #27044] IO::Socket::INET nonblocking mode fails on Win32 - here is the fix by perlbug-followup