Skip to content
Browse files

Merge branch 'win32'

WFM on strawberry and cygwin
  • Loading branch information...
2 parents e990eca + e2d94fa commit 28995fd9d3023c23df5eb9c928597b4c818259d8 @exodist committed Aug 26, 2010
Showing with 40 additions and 14 deletions.
  1. +4 −1 lib/Child.pm
  2. +1 −1 lib/Child/Link/Parent.pm
  3. +3 −0 lib/Child/Link/Proc.pm
  4. +32 −12 t/Child.t
View
5 lib/Child.pm
@@ -9,7 +9,7 @@ use Child::Link::Parent;
use Exporter 'import';
-our $VERSION = "0.008";
+our $VERSION = "0.009";
our @PROCS;
our @EXPORT_OK = qw/child/;
@@ -91,6 +91,9 @@ Child is an Object Oriented interface to fork. It provides a clean way to start
a child process, and manage it afterwords. It provides methods for running,
waiting, killing, checking, and even communicating with a child process.
+B<NOTE>: kill() is unpredictable on windows, strawberry perl sends the kill
+signal to the parent as well as the child.
+
=head1 SYNOPSIS
=head2 BASIC
View
2 lib/Child/Link/Parent.pm
@@ -41,7 +41,7 @@ Returns the parent process PID.
=item $proc->detach()
-Detach the from the parent. uses POSIX::setsid().
+Detach the from the parent. uses POSIX::setsid(). Not available in windows.
=back
View
3 lib/Child/Link/Proc.pm
@@ -99,6 +99,9 @@ Wait until child terminates, destroy remaining zombie process (blocking)
Send the $SIG signal to the child process.
+B<NOTE>: kill() is unpredictable on windows, strawberry perl sends the kill
+signal to the parent as well as the child.
+
=item $proc->pid()
Returns the process PID.
View
44 t/Child.t
@@ -30,24 +30,38 @@ ok( $proc->wait, "wait" );
ok( $proc->is_complete, "Complete" );
is( $proc->exit_status, 0, "Exit clean" );
-$proc = $CLASS->new( sub { sleep 100 } )->start;
+$proc = $CLASS->new( sub { sleep 15 } )->start;
my $ret = eval { $proc->say("XXX"); 1 };
ok( !$ret, "Died, no IPC" );
like( $@, qr/Child was created without IPC support./, "No IPC" );
-$proc->kill(2);
+if ( $^O eq 'MSWin32' ) {
+ diag( "on win32 we must wait on this process (15 seconds)" );
+ $proc->wait;
+}
+else {
+ $proc->kill(2);
+}
$proc = $CLASS->new( sub {
my $self = shift;
$SIG{INT} = sub { exit( 2 ) };
$self->say( "go" );
- sleep 100;
+ sleep 15;
+ exit 2;
}, pipe => 1 )->start;
$proc->read;
sleep 1;
-ok( $proc->kill(2), "Send signal" );
-ok( !$proc->wait, "wait" );
+
+if ( $^O eq 'MSWin32' ) {
+ diag( "on win32 we must wait on this process (15 seconds)" );
+ $proc->wait;
+}
+else {
+ ok( $proc->kill(2), "Send signal" );
+ ok( !$proc->wait, "wait" );
+}
ok( $proc->is_complete, "Complete" );
is( $proc->exit_status, 2, "Exit 2" );
ok( $proc->unix_exit > 2, "Real exit" );
@@ -70,12 +84,18 @@ my $end = time;
ok( $end - $start > 2, "No autoflush" );
-$proc = $CLASS->new( sub {
- my $self = shift;
- $self->detach;
- $self->say( $self->detached );
-}, pipe => 1 )->start;
-
-is( $proc->read(), $proc->pid . "\n", "Child detached" );
+SKIP: {
+ if ($^O eq 'MSWin32') {
+ skip "detach is not available on win32", 1;
+ }
+ else {
+ $proc = $CLASS->new( sub {
+ my $self = shift;
+ $self->detach;
+ $self->say( $self->detached );
+ }, pipe => 1 )->start;
+ is( $proc->read(), $proc->pid . "\n", "Child detached" );
+ }
+}
done_testing;

0 comments on commit 28995fd

Please sign in to comment.
Something went wrong with that request. Please try again.