develooper Front page | perl.perl5.porters | Postings from February 2014

Re: [perl #121230] process group kill on Win32 broken in 5.17.2,regression 5.18

Thread Previous | Thread Next
From:
Brian Fraser
Date:
February 27, 2014 11:01
Subject:
Re: [perl #121230] process group kill on Win32 broken in 5.17.2,regression 5.18
Message ID:
CA+nL+nbsr=B7itr=wbHjfePpNq1JRdZFd_QD49wVxru6Kr-1hQ@mail.gmail.com
On Thu, Feb 27, 2014 at 10:07 AM, bulk88 via RT
<perlbug-followup@perl.org>wrote:

> On Wed Feb 26 23:06:03 2014, bulk88 wrote:
> >
> > This patch is broken. Fails manifest.t and I forgot perldelta.pod. I
> > have manifest.t fixed, but I am having a perldelta.pod and podcheck.t
> > problem that is being addressed in a separate ML thread. So wait until
> > I have a new patch.
>
> New patch attached.
>
> --
> bulk88 ~ bulk88 at hotmail.com
>
> ---
> via perlbug:  queue: perl5 status: open
> https://rt.perl.org/Ticket/Display.html?id=121230
>
> From dc146462729d13b3038d9a58ac6291bc2e09f77f Mon Sep 17 00:00:00 2001
> From: bulk88 <bulk88@hotmail.com>
> Date: Thu, 27 Feb 2014 04:00:43 -0500
> Subject: [PATCH] RT #121230, create tests for process group kill on Win32
>
> ---
>  MANIFEST          |    3 ++-
>  pod/perldelta.pod |    9 +++++++--
>  t/op/kill0.t      |   41 ++++++++++++++++++++++++++++++++++++++++-
>  t/op/kill0_child  |    9 +++++++++
>  4 files changed, 58 insertions(+), 4 deletions(-)
>  create mode 100644 t/op/kill0_child
>
> diff --git a/MANIFEST b/MANIFEST
> index 9fcb518..e7ab59a 100644
> --- a/MANIFEST
> +++ b/MANIFEST
> @@ -5238,7 +5238,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 ab26873..f298d47 100644
> --- a/pod/perldelta.pod
> +++ b/pod/perldelta.pod
> @@ -319,11 +319,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.17.2. 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].
>

Better to use 5.18.0 here -- the vast majority of users have no reason to
care about dev releases.


>
>  =back
>
> diff --git a/t/op/kill0.t b/t/op/kill0.t
> index d3ef8f7..4012761 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,41 @@ for my $case ( @bad_pids ) {
>    $x =~ /(\d+)/;
>    ok(eval { kill 0, $1 }, "can kill a number string in a magic variable");
>  }
> +
> +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, and an
> inner one
> +  #created by outer this allows the test to fail if only the outer one was
> +  #killed, since the inner will stay around and eventually print failed
> and
> +  #out of sequence TAP to harness
> +  unlink('killchildstarted');
> +  die q|can't unlink| if -e 'killchildstarted';
> +  eval q|END{unlink('killchildstarted');}|;
> +  my $pid = system(1, $^X, 'op/kill0_child', 'killchildstarted');
> +  die 'PID is 0' if !$pid;
> +  while( ! -e 'killchildstarted') {
> +    sleep 1; #a sleep 0 with $i++ will takes ~160 iterations here
> +  }
> +  #ways to break this test manually, change '-KILL' to 'KILL', change
> $pid to a
> +  #bogus number
> +  is(kill('-KILL', $pid), 1, 'process group kill, named signal');
> +
> +  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 q|A child proc wasn't killed and did cleanup on its own| if ! -e
> 'killchildstarted';
> +  unlink('killchildstarted');
> +  die q|can't unlink| if -e 'killchildstarted';
> +  #no END block, done earlier
> +  $pid = system(1, $^X, 'op/kill0_child', 'killchildstarted');
> +  die 'PID is 0' if !$pid;
> +  while( ! -e 'killchildstarted') {
> +    sleep 1; #a sleep 0 with $i++ will takes ~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..c3d5eb2
> --- /dev/null
> +++ b/t/op/kill0_child
> @@ -0,0 +1,9 @@
> +#$ARGV[0] is filename used to notify parent .t perl proc that all PIDs are
> +#started in the process tree
> +#number 9999/9998 is eye catching
> +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;
>

^ how thoroughly was this tested? <10 second waits tend to fail on VMs
quite often.


> +#execution won't be reached if test successful
> +print "not ok 9998 - outer child process wasn\'t killed\n";
> +unlink($ARGV[0]);
> --
> 1.7.9.msysgit.0
>
>
>

Thread Previous | Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About