In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/4c0e595c606032a1e1c0a922399a1e7bd2358ca9?hp=c899ae2d02e643a00e4504a6657f4d6d870b8169>
- Log ----------------------------------------------------------------- commit 4c0e595c606032a1e1c0a922399a1e7bd2358ca9 Author: David Mitchell <[email protected]> Date: Mon Mar 17 16:19:10 2014 +0000 tidy up kill0.t and kill0_child The previous commit added some tests to kill0.t, and added the auxiliary file kill0_child. Tidy up the new code to better match normal standards. In particular, improve the format, grammar and clarity of the comments, and replace q|...| with "..." where appropriate. Also, make the temporary filename a variable, and prefix it with "tmp-", so that if gets left around for any reason, it's more obvious that it's just an extraneous temporary file. (I haven't actually tested this commit on win32) M t/op/kill0.t M t/op/kill0_child commit af728ca1bc90608b25e3f73957c8493d013b753d Author: Daniel Dragan <[email protected]> Date: Mon Mar 17 15:29:52 2014 +0000 RT #121230, tests for process group kill on Win32 Add tests for 111f73b5d79, the fix for kill -SIG on win32, which was broken in 5.18.0 (A follow-up commit will clean this code up a bit) M MANIFEST M pod/perldelta.pod M t/op/kill0.t A t/op/kill0_child ----------------------------------------------------------------------- Summary of changes: MANIFEST | 3 ++- pod/perldelta.pod | 9 +++++++-- t/op/kill0.t | 58 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- t/op/kill0_child | 14 ++++++++++++++ 4 files changed, 80 insertions(+), 4 deletions(-) create mode 100644 t/op/kill0_child diff --git a/MANIFEST b/MANIFEST index 331606c..a6708e4 100644 --- a/MANIFEST +++ b/MANIFEST @@ -5240,7 +5240,8 @@ t/op/index.t See if index works t/op/index_thr.t See if index works in another thread t/op/int.t See if int works t/op/join.t See if join works -t/op/kill0.t See if kill(0, $pid) works +t/op/kill0_child Process tree script that is kill()ed +t/op/kill0.t See if kill works t/op/kvaslice.t See if index/value array slices work t/op/kvhslice.t See if key/value hash slices work t/op/lc.t See if lc, uc, lcfirst, ucfirst, quotemeta work diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 08c234c..ba59a42 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -390,11 +390,16 @@ and compilation changes or changes in portability/compatibility. However, changes within modules for platforms should generally be listed in the L</Modules and Pragmata> section. +=head3 Win32 + =over 4 -=item XXX-some-platform +=item * -XXX +Killing a process tree with L<perlfunc/kill> and a negative signal, was broken +starting in 5.18.0. In this bug, C<kill> always returned 0 for a negative +signal even for valid PIDs, and no processes were terminated. This has been +fixed [perl #121230]. =back diff --git a/t/op/kill0.t b/t/op/kill0.t index d3ef8f7..7f6e6ec 100644 --- a/t/op/kill0.t +++ b/t/op/kill0.t @@ -13,8 +13,9 @@ BEGIN { } use strict; +use Config; -plan tests => 6; +plan tests => 9; ok( kill(0, $$), 'kill(0, $pid) returns true if $pid exists' ); @@ -50,3 +51,58 @@ for my $case ( @bad_pids ) { $x =~ /(\d+)/; ok(eval { kill 0, $1 }, "can kill a number string in a magic variable"); } + + +# RT #121230: test process group kill on Win32 + +SKIP: { + skip 'custom process group kill() only on Win32', 3 if ($^O ne 'MSWin32'); + + # Create 2 child processes: an outer one created by kill0.t that runs + # the "op/kill0_child" script, and an inner one created by outer that + # just does 'sleep 5'. We then try to kill both of them as a single + # process group. If only the outer one is killed, the inner will stay + # around and eventually print "not ok 9999", presenting out of sequence + # TAP to harness. The outer child creates a temporary file when it is + # ready. + + my $killfile = 'tmp-killchildstarted'; + unlink($killfile); + die "can't unlink $killfile: $!" if -e $killfile; + eval q{END {unlink($killfile);}}; + + my $pid = system(1, $^X, 'op/kill0_child', $killfile); + die 'PID is 0' if !$pid; + while( ! -e $killfile) { + sleep 1; # a sleep 0 with $i++ would take ~160 iterations here + } + # (some ways to manually make this test fail: + # change '-KILL' to 'KILL'; + # change $pid to a bogus number) + is(kill('-KILL', $pid), 1, 'process group kill, named signal'); + + # create a mapping of signal names to numbers + + my ($i, %signo, @signame, $sig_name) = 0; + ($sig_name = $Config{sig_name}) || die "No signals?"; + foreach my $name (split(' ', $sig_name)) { + $signo{$name} = $i; + $signame[$i] = $name; + $i++; + } + ok(scalar keys %signo > 1 && exists $signo{KILL}, + '$Config{sig_name} parsed correctly'); + die "a child proc wasn't killed and did cleanup on its own" if ! -e $killfile; + unlink $killfile; + + # Now repeat the test with a numeric kill sigbal + + die "can't unlink" if -e $killfile; + # no need to create another END block: already done earlier + $pid = system(1, $^X, 'op/kill0_child', $killfile); + die 'PID is 0' if !$pid; + while( ! -e $killfile) { + sleep 1; # a sleep 0 with $i++ would take ~160 iterations here + } + is(kill(-$signo{KILL}, $pid), 1, 'process group kill, numeric signal'); +} diff --git a/t/op/kill0_child b/t/op/kill0_child new file mode 100644 index 0000000..f2a6604 --- /dev/null +++ b/t/op/kill0_child @@ -0,0 +1,14 @@ +# kill0_child: an auxiliary script called from t/op/kill0.t +# +# $ARGV[0] is the filename that is used to notify the parent .t perl +# process that all PIDs are started in the process tree. +# The numbers 9999s and 9998 are intended to be eye catching; they will +# only appear if we're not killed in time. + +system(1, $^X, '-e', 'sleep 5; print qq|not ok 9999 - inner child process wasn\'t killed\n|;'); +system('echo outer child started > "'.$ARGV[0].'"'); +sleep 5; + +# execution won't reach here if the test is successful +print "not ok 9998 - outer child process wasn\'t killed\n"; +unlink($ARGV[0]); -- Perl5 Master Repository
