Hi,
Here is a patch that fixes the issue :
--- SocketFactory.orig 2005-05-20 22:05:27.000000000 +0200
+++ SocketFactory.pm 2005-05-20 22:05:41.000000000 +0200
@@ -46,55 +46,6 @@
# Provide dummy constants for systems that don't have them.
BEGIN {
- if ($^O eq 'MSWin32') {
-
- # Constants are evaluated first so they exist when the code uses
- # them.
- eval( '*F_GETFL = sub { 0 };' .
- '*F_SETFL = sub { 0 };' .
-
- # Garrett Goebel's patch to support non-blocking connect()
- # or MSWin32 follows. His notes on the matter:
- #
- # As my patch appears to turn on the overlapped attributes
- # for all successive sockets... it might not be the optimal
- # solution. But it works for me ;)
- #
- # A better Win32 approach would probably be to:
- # o create a dummy socket
- # o cache the value of SO_OPENTYPE
- # o set the overlapped io attribute
- # o close dummy socket
- #
- # o create our sock
- #
- # o create a dummy socket
- # o restore previous value of SO_OPENTYPE
- # o close dummy socket
- #
- # This way we'd only be turning on the overlap attribute for
- # the socket we created... and not all subsequent sockets.
-
- '*SO_OPENTYPE = sub () { 0x7008 };' .
- '*SO_SYNCHRONOUS_ALERT = sub () { 0x10 };' .
- '*SO_SYNCHRONOUS_NONALERT = sub () { 0x20 };'
- );
- die if $@;
-
- # Turn on socket overlapped IO attribute per MSKB: Q181611. This
- # concludes Garrett's patch.
-
- eval( 'socket(POE, AF_INET, SOCK_STREAM, getprotobyname("tcp"))' .
- 'or die "socket failed: $!";' .
- 'my $opt = unpack("I", getsockopt(POE, SOL_SOCKET, SO_OPENTYPE));' .
- '$opt &= ~(SO_SYNCHRONOUS_ALERT|SO_SYNCHRONOUS_NONALERT);' .
- 'setsockopt(POE, SOL_SOCKET, SO_OPENTYPE, $opt);' .
- 'close POE;'
-
- # End of Garrett's patch.
- );
- die if $@;
- }
unless (exists $INC{"Socket6.pm"}) {
eval "*Socket6::AF_INET6 = sub () { ~0 }";
@@ -579,6 +530,37 @@
$default_socket_type{$abstract_domain}->{$protocol_name};
}
+ my $win32_socket_opt;
+ # o create a dummy socket
+ # o cache the value of SO_OPENTYPE in $win32_socket_opt
+ # o set the overlapped io attribute
+ # o close dummy socket
+ if ( POE::Kernel::RUNNING_IN_HELL) {
+
+ # Constants are evaluated first so they exist when the code uses
+ # them.
+ eval {
+ *SO_OPENTYPE = sub () { 0x7008 };
+ *SO_SYNCHRONOUS_ALERT = sub () { 0x10 };
+ *SO_SYNCHRONOUS_NONALERT = sub () { 0x20 };
+ };
+ die "Could not install SO constants [EMAIL PROTECTED]" if $@;
+
+ # Turn on socket overlapped IO attribute per MSKB: Q181611.
+
+ eval {
+ socket(POE, AF_INET, SOCK_STREAM, getprotobyname("tcp"))
+ or die "socket failed: $!";
+ my $opt = unpack("I", getsockopt(POE, SOL_SOCKET, SO_OPENTYPE()));
+ $win32_socket_opt = $opt;
+ $opt &= ~(SO_SYNCHRONOUS_ALERT()|SO_SYNCHRONOUS_NONALERT());
+ setsockopt(POE, SOL_SOCKET, SO_OPENTYPE(), $opt);
+ close POE;
+ };
+
+ die if $@;
+ }
+
# Create the socket.
unless (socket( $socket_handle, $self->[MY_SOCKET_DOMAIN],
$self->[MY_SOCKET_TYPE], $self->[MY_SOCKET_PROTOCOL]
@@ -590,6 +572,23 @@
return $self;
}
+ # o create a dummy socket
+ # o restore previous value of SO_OPENTYPE
+ # o close dummy socket
+ #
+ # This way we'd only be turning on the overlap attribute for
+ # the socket we created... and not all subsequent sockets.
+ if ( POE::Kernel::RUNNING_IN_HELL) {
+
+ eval {
+ socket(POE, AF_INET, SOCK_STREAM, getprotobyname("tcp"))
+ or die "socket failed: $!";
+ setsockopt(POE, SOL_SOCKET, SO_OPENTYPE(), $win32_socket_opt);
+ close POE;
+ };
+
+ die if $@;
+ }
DEBUG && warn "socket";
#------------------#
And here is a test program:
#!/ms/dist/perl5/bin/perl5.8 -w
use POE;
$|=1;
my $obj = new MyDebug;
POE::Session->create(
object_states => [ $obj => [ '_start', 'next', 'reaper', 'output' ]]);
POE::Kernel->run;
exit(0);
# ------------------------------------------------
# Now define our class which does all of the work.
# ------------------------------------------------
package MyDebug;
use POE;
use POE::Wheel::Run;
use POE::Wheel::SocketFactory; # Just adding this line breaks the
# program, the child will die
# prematurely
use IO::Handle;
use File::Spec;
use POSIX qw(dup);
sub new {
my $class = shift;
return bless {};
}
sub _start {
my ($self, $heap, $kernel) = @_[OBJECT, HEAP, KERNEL];
warn "_start\n";
$kernel->sig(CHLD => 'reaper');
$self->{subprocess} = POE::Wheel::Run->new(Program =>
sub {
my $buffer;
my $input_stream = IO::Handle::->new_from_fd(dup(fileno(STDIN)),
"r");
my $output_stream = IO::Handle::->new_from_fd(dup(fileno(STDOUT)),
"w");
my $devnull = File::Spec->devnull();
open(STDIN, "$devnull");
open(STDOUT, "> $devnull");
open(STDERR, "> $devnull");
while (sysread($input_stream, $buffer, 1024 * 32)) {
last if substr($buffer, 0, 4) eq 'kill';
syswrite($output_stream, "child [$$] read: $buffer");
}
}, StdoutEvent => 'output');
warn "have a subprocess\n" if $self->{subprocess};
$heap->{counter} = 3;
$kernel->delay_set('next', 3);
}
sub output {
my ($self, $output) = @_[OBJECT, ARG0];
chomp $output;
warn "received data from subprocess: [$output]\n";
}
sub reaper {
my ($self, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP];
if ($heap->{counter}) {
warn "child has died prematurely\n";
} else {
warn "child has completed when the counter ran out\n";
}
$self->{subprocess} = undef;
$kernel->sig_handled;
}
sub next {
my ($self, $kernel, $heap) = @_[OBJECT, KERNEL, HEAP];
warn "next [" . $heap->{counter}. "]\n";
if ($self->{subprocess}) {
$self->{subprocess}->put("Can you hear me $heap->{counter}");
}
if (--$heap->{counter}) {
$kernel->delay_set('next', 4)
} else {
if ($self->{subprocess}) {
warn "Trying to kill [" . $self->{subprocess}->PID . "]\n";
kill $self->{subprocess}->put("kill");
}
}
}
--
Merijn Broeren | Sometime in the middle ages, God got fed up with us
Software Geek | and put earth at sol.milky-way.univ in his kill-file.
| Pray all you want, it just gets junked.
