[libsystem-command-perl] 01/01: Imported Upstream version 1.106
Salvatore Bonaccorso
carnil at debian.org
Sat Oct 12 23:01:04 UTC 2013
This is an automated email from the git hooks/post-receive script.
carnil pushed a commit to annotated tag upstream/1.106
in repository libsystem-command-perl.
commit 65bbfd1e5c3e4053299a5b7c9f13094e46e9f22b
Author: Salvatore Bonaccorso <carnil at debian.org>
Date: Sun Oct 13 00:43:52 2013 +0200
Imported Upstream version 1.106
---
Changes | 10 +++
MANIFEST | 2 +-
META.yml | 3 +-
Makefile.PL | 3 +-
lib/System/Command.pm | 77 +++++------------
lib/System/Command/Reaper.pm | 197 ++++++++++++++++++++++++++++++++++++++++++
t/000-report-versions-tiny.t | 1 +
t/15-scope.t | 38 +++++---
t/20-zombie.t | 7 +-
t/manifest.t | 13 ---
10 files changed, 258 insertions(+), 93 deletions(-)
diff --git a/Changes b/Changes
index 1f004e6..432fd28 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,15 @@
Revision history for System-Command
+1.106 Sat Oct 12 2013
+ [ENHANCEMENTS]
+ - brought back System::Command::Reaper, which properly deals
+ with zombies
+ - execute the command in its own process group whenever possible
+ (thanks to Vincent Pit)
+ [TESTS]
+ - test for the zombie processes is not TODO anymore
+ - tests for the timely destruction of the reaper are back
+
1.105 Sat Oct 5 2013
[TESTS]
- add a TODO test for the zombie processes created in certain cases
diff --git a/MANIFEST b/MANIFEST
index 0bb9739..3d0667d 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -6,6 +6,7 @@ Makefile.PL
README
dist.ini
lib/System/Command.pm
+lib/System/Command/Reaper.pm
t/00-load.t
t/000-report-versions-tiny.t
t/01-load.t
@@ -18,7 +19,6 @@ t/90-output.t
t/fail.pl
t/info.pl
t/lines.pl
-t/manifest.t
t/release-distmeta.t
t/release-pod-coverage.t
t/release-pod-syntax.t
diff --git a/META.yml b/META.yml
index 411dca1..76d435e 100644
--- a/META.yml
+++ b/META.yml
@@ -26,6 +26,7 @@ requires:
IPC::Run: 0
List::Util: 0
POSIX: 0
+ Scalar::Util: 0
Symbol: 0
constant: 0
perl: 5.006
@@ -34,4 +35,4 @@ requires:
resources:
bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=System-Command
repository: http://github.com/book/System-Command.git
-version: 1.105
+version: 1.106
diff --git a/Makefile.PL b/Makefile.PL
index f7b24eb..da94342 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -34,12 +34,13 @@ my %WriteMakefileArgs = (
"IPC::Run" => 0,
"List::Util" => 0,
"POSIX" => 0,
+ "Scalar::Util" => 0,
"Symbol" => 0,
"constant" => 0,
"strict" => 0,
"warnings" => 0
},
- "VERSION" => "1.105",
+ "VERSION" => "1.106",
"test" => {
"TESTS" => "t/*.t"
}
diff --git a/lib/System/Command.pm b/lib/System/Command.pm
index 1268c88..0f4e6b8 100644
--- a/lib/System/Command.pm
+++ b/lib/System/Command.pm
@@ -1,6 +1,6 @@
package System::Command;
{
- $System::Command::VERSION = '1.105';
+ $System::Command::VERSION = '1.106';
}
use warnings;
@@ -12,11 +12,10 @@ use Cwd qw( cwd );
use IO::Handle;
use Symbol ();
use List::Util qw( reduce );
+use System::Command::Reaper;
use Config;
use Fcntl qw( F_GETFD F_SETFD FD_CLOEXEC );
-use POSIX ":sys_wait_h";
-use constant STATUS => qw( exit signal core );
# MSWin32 support
use constant MSWin32 => $^O eq 'MSWin32';
@@ -116,6 +115,9 @@ my $_spawn = sub {
close $out;
close $err;
+ # setup process group if possible
+ setpgrp 0, 0 if $Config{d_setpgrp};
+
# close $stat_w on exec
my $flags = fcntl( $stat_w, F_GETFD, 0 )
or croak "fcntl GETFD failed: $!";
@@ -150,11 +152,6 @@ my $_spawn = sub {
return ( $pid, $in, $out, $err );
};
-# this is necessary, because kill(0,pid) is misimplemented in perl core
-my $_is_alive = MSWin32
- ? sub { return `tasklist /FO CSV /NH /fi "PID eq $_[0]"` =~ /^"/ }
- : sub { return kill 0, $_[0]; };
-
# module methods
sub new {
my ( $class, @cmd ) = @_;
@@ -221,6 +218,10 @@ sub new {
( _ipc_run => $pid )x!! MSWin32,
}, $class;
+ # create the subprocess reaper and link the handles and command to it
+ ${*$in} = ${*$out} = ${*$err} = $self->{reaper} # typeglobs FTW
+ = System::Command::Reaper->new($self);
+
return $self;
}
@@ -229,52 +230,9 @@ sub spawn {
return @{ $class->new(@cmd) }{qw( pid stdin stdout stderr )};
}
-sub is_terminated {
- my ($self) = @_;
- my $pid = $self->{pid};
-
- # Zed's dead, baby. Zed's dead.
- return $pid if !$_is_alive->($pid) and exists $self->{exit};
-
- # If that is a re-animated body, we're gonna have to kill it.
- return $self->_reap(WNOHANG);
-}
-
-sub _reap {
- my ( $self, @flags ) = @_;
- my $pid = $self->{pid};
-
- if ( my $reaped = waitpid( $pid, @flags ) and !exists $self->{exit} ) {
- my $zed = $reaped == $pid;
- carp "Child process already reaped, check for a SIGCHLD handler"
- if !$zed && !$QUIET;
-
- @{$self}{ STATUS() }
- = $zed
- ? ( $? >> 8, $? & 127, $? & 128 )
- : ( -1, -1, -1 );
-
- return $reaped; # It's dead, Jim!
- }
-
- # Look! It's moving. It's alive. It's alive...
- return;
-}
-
-sub close {
- my ($self) = @_;
-
- # close all pipes
- my ( $in, $out, $err ) = @{$self}{qw( stdin stdout stderr )};
- $in and $in->opened and $in->close || carp "error closing stdin: $!";
- $out and $out->opened and $out->close || carp "error closing stdout: $!";
- $err and $err->opened and $err->close || carp "error closing stderr: $!";
-
- # and wait for the child (if any)
- $self->_reap();
-
- return $self;
-}
+# delegate those to the reaper
+sub is_terminated { $_[0]{reaper}->is_terminated() }
+sub close { $_[0]{reaper}->close() }
1;
@@ -288,7 +246,7 @@ System::Command - Object for running system commands
=head1 VERSION
-version 1.105
+version 1.106
=head1 SYNOPSIS
@@ -309,7 +267,7 @@ version 1.105
# find out if the child process died
if ( $cmd->is_terminated() ) {
# the handles are not closed yet
- # but $cmd->exit() et al. are available
+ # but $cmd->exit() et al. are available if it's dead
}
# done!
@@ -394,7 +352,7 @@ Returns a true value if the underlying process was terminated.
If the process was indeed terminated, collects exit status, etc.
and defines the same attributes as C<close()>, but does B<not> close
-all pipes to the child process,
+all pipes to the child process.
=head2 spawn( @cmd )
@@ -511,6 +469,11 @@ weren't related to Git.
Thanks to Christian Walde (MITHALDU) for his help in making this
module work better under Win32.
+The L<System::Command::Reaper> class was added after the addition
+of Git::Repository::Command::Reaper in L<Git::Repository::Command> 1.11.
+It was later removed from L<System::Command> version 1.03, and brought
+back from the dead to deal with the zombie apocalypse in version 1.106.
+
=head1 BUGS
Please report any bugs or feature requests to C<bug-system-command at rt.cpan.org>, or through
diff --git a/lib/System/Command/Reaper.pm b/lib/System/Command/Reaper.pm
new file mode 100644
index 0000000..30e1e5c
--- /dev/null
+++ b/lib/System/Command/Reaper.pm
@@ -0,0 +1,197 @@
+package System::Command::Reaper;
+{
+ $System::Command::Reaper::VERSION = '1.106';
+}
+
+use strict;
+use warnings;
+use 5.006;
+
+use Carp;
+use Scalar::Util qw( weaken );
+
+use POSIX ":sys_wait_h";
+
+use constant MSWin32 => $^O eq 'MSWin32';
+use constant HANDLES => qw( stdin stdout stderr );
+use constant STATUS => qw( exit signal core );
+
+sub new {
+ my ($class, $command) = @_;
+ my $self = bless { command => $command }, $class;
+
+ # copy/weaken the important keys
+ @{$self}{ pid => HANDLES } = @{$command}{ pid => HANDLES };
+ weaken $self->{$_} for ( command => HANDLES );
+
+ return $self;
+}
+
+# this is necessary, because kill(0,pid) is misimplemented in perl core
+my $_is_alive = MSWin32
+ ? sub { return `tasklist /FO CSV /NH /fi "PID eq $_[0]"` =~ /^"/ }
+ : sub { return kill 0, $_[0]; };
+
+sub is_terminated {
+ my ($self) = @_;
+ my $pid = $self->{pid};
+
+ # Zed's dead, baby. Zed's dead.
+ return $pid if !$_is_alive->($pid) and exists $self->{command}{exit};
+
+ # If that is a re-animated body, we're gonna have to kill it.
+ return $self->_reap(WNOHANG);
+}
+
+sub _reap {
+ my ( $self, @flags ) = @_;
+ my $pid = $self->{pid};
+
+ if ( my $reaped = waitpid( $pid, @flags )
+ and !exists $self->{command}{exit} )
+ {
+ my $zed = $reaped == $pid;
+ carp "Child process already reaped, check for a SIGCHLD handler"
+ if !$zed && !$System::Command::QUIET;
+
+ @{$self}{ STATUS() }
+ = $zed
+ ? ( $? >> 8, $? & 127, $? & 128 )
+ : ( -1, -1, -1 );
+
+ # does our creator still exist?
+ @{ $self->{command} }{ STATUS() } = @{$self}{ STATUS() }
+ if defined $self->{command};
+
+ return $reaped; # It's dead, Jim!
+ }
+
+ # Look! It's moving. It's alive. It's alive...
+ return;
+}
+
+sub close {
+ my ($self) = @_;
+
+ # close all pipes
+ my ( $in, $out, $err ) = @{$self}{qw( stdin stdout stderr )};
+ $in and $in->opened and $in->close || carp "error closing stdin: $!";
+ $out and $out->opened and $out->close || carp "error closing stdout: $!";
+ $err and $err->opened and $err->close || carp "error closing stderr: $!";
+
+ # and wait for the child (if any)
+ $self->_reap();
+
+ return $self;
+}
+
+sub DESTROY {
+ my ($self) = @_;
+ $self->close if !exists $self->{exit};
+}
+
+1;
+
+
+
+=pod
+
+=head1 NAME
+
+System::Command::Reaper
+
+=head1 VERSION
+
+version 1.106
+
+=head1 SYNOPSIS
+
+This class is used for internal purposes.
+Move along, nothing to see here.
+
+=head1 DESCRIPTION
+
+The L<System::Command> objects delegate the reaping of child
+processes to System::Command::Reaper objects. This allows a user
+to create a L<System::Command> and discard it after having obtained
+one or more references to its handles connected to the child process.
+
+The typical use case looks like this:
+
+ my $fh = System::Command->new( @cmd )->stdout();
+
+The child process is reaped either through a direct call to C<close()>
+or when the command object and all its handles have been destroyed,
+thus avoiding zombies (which would be reaped by the system at the end
+of the main program).
+
+This is possible thanks to the following reference graph:
+
+ System::Command
+ | | | ^|
+ v v v !|
+ in out err !|
+ ^| ^| ^| !|
+ !v !v !v !v
+ System::Command::Reaper
+
+Legend:
+ | normal ref
+ ! weak ref
+
+The System::Command::Reaper object acts as a sentinel, that takes
+care of reaping the child process when the original L<System::Command>
+and its filehandles have been destroyed (or when L<System::Command>
+C<close()> method is being called).
+
+=head1 NAME
+
+System::Command::Reaper - Reap processes started by System::Command
+
+=head1 METHODS
+
+System::Command::Reaper supports the following methods:
+
+=head2 new( $command )
+
+Create a new System::Command::Reaper object attached to the
+L<System::Command> object passed as a parameter.
+
+=head2 close()
+
+Close all the opened filehandles of the main L<System::Command> object,
+reaps the child process, and updates the main object with the status
+information of the child process.
+
+C<DESTROY> calls C<close()> when the sentinel is being destroyed.
+
+=head2 is_terminated()
+
+Returns a true value if the underlying process was terminated.
+
+If the process was indeed terminated, collects exit status, etc.
+
+=head1 AUTHOR
+
+Philippe Bruhat (BooK), C<< <book at cpan.org> >>
+
+=head1 ACKNOWLEDGEMENTS
+
+This scheme owes a lot to Vincent Pit who on #perlfr provided the
+general idea (use a proxy to delay object destruction and child process
+reaping) with code examples, which I then adapted to my needs.
+
+=head1 COPYRIGHT
+
+Copyright 2010-2013 Philippe Bruhat (BooK), all rights reserved.
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+
+__END__
+
diff --git a/t/000-report-versions-tiny.t b/t/000-report-versions-tiny.t
index 2c5469d..cc64e8a 100644
--- a/t/000-report-versions-tiny.t
+++ b/t/000-report-versions-tiny.t
@@ -61,6 +61,7 @@ eval { $v .= pmver('IO::Handle','any version') };
eval { $v .= pmver('IPC::Run','any version') };
eval { $v .= pmver('List::Util','any version') };
eval { $v .= pmver('POSIX','any version') };
+eval { $v .= pmver('Scalar::Util','any version') };
eval { $v .= pmver('Symbol','any version') };
eval { $v .= pmver('Test::More','0.88') };
eval { $v .= pmver('constant','any version') };
diff --git a/t/15-scope.t b/t/15-scope.t
index a87126d..5548056 100644
--- a/t/15-scope.t
+++ b/t/15-scope.t
@@ -18,37 +18,42 @@ my @cmd = ( $^X, File::Spec->catfile( t => 'lines.pl' ) );
my @destroyed;
{
no strict 'refs';
- my $class = "System::Command";
+ for my $suffix ( '', '::Reaper' ) {
+ my $class = "System::Command$suffix";
my $destroy = *{"$class\::DESTROY"}{CODE};
*{"$class\::DESTROY"} = sub {
diag "DESTROY $_[0]";
push @destroyed, refaddr $_[0];
$destroy->(@_) if $destroy;
};
+ }
}
# test various scope situations and object destruction time
-my ( $cmd_addr );
+my ( $cmd_addr, $reap_addr );
# test 1
-BEGIN { $tests += 5 }
+BEGIN { $tests += 6 }
{
my $cmd = System::Command->new(@cmd);
$cmd_addr = refaddr $cmd;
+ $reap_addr = refaddr $cmd->{reaper};
my ( $out, $err ) = ( $cmd->stdout, $cmd->stderr );
ok( eof $out, 'No output' );
ok( eof $err, 'No errput' );
is( scalar @destroyed, 0, "Destroyed no object yet" );
}
-is( scalar @destroyed, 1, "Destroyed 1 object" );
+is( scalar @destroyed, 2, "Destroyed 2 objects" );
is( shift @destroyed, $cmd_addr, "... command object was destroyed" );
+is( shift @destroyed, $reap_addr, "... reaper object was destroyed" );
@destroyed = ();
# test 2
-BEGIN { $tests += 5 }
+BEGIN { $tests += 6 }
{
my $cmd = System::Command->new( @cmd, 1, 1, 1 );
$cmd_addr = refaddr $cmd;
+ $reap_addr = refaddr $cmd->{reaper};
{
my $fh = $cmd->stdout;
@@ -62,35 +67,37 @@ BEGIN { $tests += 5 }
}
is( scalar @destroyed, 0, "Destroyed no object yet" );
}
-is( scalar @destroyed, 1, "Destroyed 1 objects" );
+is( scalar @destroyed, 2, "Destroyed 2 objects" );
is( shift @destroyed, $cmd_addr, "... command object was destroyed" );
+is( shift @destroyed, $reap_addr, "... reaper object was destroyed" );
@destroyed = ();
# test 3
BEGIN { $tests += 3 }
{
my $fh = System::Command->new( @cmd, 1 )->stdout;
- is( scalar @destroyed, 1, "Destroyed 1 object" );
+ is( scalar @destroyed, 1, "Destroyed 1 object (command)" );
@destroyed = ();
my $ln = <$fh>;
is( $ln, "STDOUT line 1\n", 'scope: { $fh = cmd->fh }' );
}
-is( scalar @destroyed, 0, "Destroyed no object" );
+is( scalar @destroyed, 1, "Destroyed 1 object (reaper)" );
@destroyed = ();
# test 4
BEGIN { $tests += 1 }
System::Command->new(@cmd);
-is( scalar @destroyed, 1, "Destroyed 1 object (command)" );
+is( scalar @destroyed, 2, "Destroyed 2 objects (command + reaper)" );
@destroyed = ();
# test 5
-BEGIN { $tests += 4 }
+BEGIN { $tests += 5 }
{
my $fh;
{
my $cmd = System::Command->new( @cmd, 2 );
$cmd_addr = refaddr $cmd;
+ $reap_addr = refaddr $cmd->{reaper};
$fh = $cmd->stdout;
}
is( scalar @destroyed, 1, "Destroyed 1 object (command)" );
@@ -102,14 +109,16 @@ STDOUT line 1
STDOUT line 2
OUT
}
-is( scalar @destroyed, 0, "Destroyed no objects (reaper)" );
+is( scalar @destroyed, 1, "Destroyed 1 objects (reaper)" );
+is( shift @destroyed, $reap_addr, "... reaper object was destroyed" );
@destroyed = ();
# test 6
-BEGIN { $tests += 5 }
+BEGIN { $tests += 6 }
{
my $cmd = System::Command->new( @cmd, 1, 2, 2, 1 );
$cmd_addr = refaddr $cmd;
+ $reap_addr = refaddr $cmd->{reaper};
{
my $fh = $cmd->stdout;
@@ -131,8 +140,9 @@ ERR
}
is( scalar @destroyed, 0, "Destroyed no object yet" );
}
-is( scalar @destroyed, 1, "Destroyed 1 objects" );
+is( scalar @destroyed, 2, "Destroyed 2 objects" );
is( shift @destroyed, $cmd_addr, "... command object was destroyed" );
+is( shift @destroyed, $reap_addr, "... reaper object was destroyed" );
@destroyed = ();
# test 7
@@ -154,6 +164,6 @@ STDERR line 2
STDERR line 3
ERR
}
-is( scalar @destroyed, 0, "Destroyed neaper object" );
+is( scalar @destroyed, 1, "Destroyed reaper object" );
@destroyed = ();
diff --git a/t/20-zombie.t b/t/20-zombie.t
index 2cccf55..e2ef567 100644
--- a/t/20-zombie.t
+++ b/t/20-zombie.t
@@ -150,12 +150,7 @@ BEGIN { $tests += 4 }
$fh->close;
}
-TODO: {
- local $TODO = $win32
- ? '' # no zombies on Win32
- : 'zombies are roaming around if we lose the object'; # zombie!
- ok( !$_is_alive->($pid), "process $pid should be dead" );
- }
+ ok( !$_is_alive->($pid), "process $pid should be dead" );
}
# don't confuse Test::More
diff --git a/t/manifest.t b/t/manifest.t
deleted file mode 100644
index 45eb83f..0000000
--- a/t/manifest.t
+++ /dev/null
@@ -1,13 +0,0 @@
-#!perl -T
-
-use strict;
-use warnings;
-use Test::More;
-
-unless ( $ENV{RELEASE_TESTING} ) {
- plan( skip_all => "Author tests not required for installation" );
-}
-
-eval "use Test::CheckManifest 0.9";
-plan skip_all => "Test::CheckManifest 0.9 required" if $@;
-ok_manifest();
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libsystem-command-perl.git
More information about the Pkg-perl-cvs-commits
mailing list