summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorgregor herrmann <gregoa@debian.org>2021-10-30 01:27:34 +0200
committergregor herrmann <gregoa@debian.org>2021-10-30 01:27:34 +0200
commit5f1d626f74c07027c892e97781fa7da0e38c4530 (patch)
tree471cecb47e827b3f04ef618b61522b083e19a373
parent5e947874d1e3d3f5a01f8a8b4b38d3e8870cebbf (diff)
parent68aeb6ae2abf95f36ce855f5f7dbfcb6de3ff2df (diff)
New upstream version 1.30
-rw-r--r--Changes26
-rw-r--r--LICENSE12
-rw-r--r--MANIFEST5
-rw-r--r--META.json8
-rw-r--r--META.yml6
-rw-r--r--Makefile.PL4
-rw-r--r--README8
-rw-r--r--lib/Proc/Background.pm524
-rw-r--r--lib/Proc/Background/Unix.pm211
-rw-r--r--lib/Proc/Background/Win32.pm211
-rw-r--r--t/10-io-redirect.t102
-rw-r--r--t/11-cwd.t66
-rw-r--r--t/12-autodie.t42
13 files changed, 921 insertions, 304 deletions
diff --git a/Changes b/Changes
index f1f1049..f2746b0 100644
--- a/Changes
+++ b/Changes
@@ -1,4 +1,28 @@
-Fri July 9 07:33:00 JST 2021
+Wed Oct 20 15:38:00 JST 2021
+
+ Version 1.30
+
+ * New options 'command','exe' dis-ambiguate the problems around
+ determining how to parse the command line and determine the
+ executable name. It also allows faking argv[0]. They can be
+ inspected after program launch via same-named attributes.
+ * New options 'stdin','stdout','stderr' allow initializing handles
+ of the child process.
+ * New option 'cwd' sets initial current directory of the child
+ * Renamed '->die' to '->terminate' and options 'die_upon_destroy'
+ to 'autoterminate' (but preserved back-compat)
+ * Option 'autoterminate' now has an attribute accessor and can be
+ toggled on the fly.
+ * New option 'autodie' throws exceptions from constructor instead
+ of returning undef.
+ * On Unix, use a pipe to capture error messages all the way through
+ to the exec() call. Reap exec() failures without exposing the
+ forked process to the user.
+ * Add methods ->suspend and ->resume
+ * Mitigate bug in timeout_system where a system clock change could
+ increase the wait-time indefinitely.
+
+Fri Jul 9 07:33:00 JST 2021
Version 1.22
diff --git a/LICENSE b/LICENSE
index 297d55d..d901a88 100644
--- a/LICENSE
+++ b/LICENSE
@@ -292,21 +292,21 @@ Definitions:
- "Package" refers to the collection of files distributed by the Copyright
Holder, and derivatives of that collection of files created through
- textual modification.
+ textual modification.
- "Standard Version" refers to such a Package if it has not been modified,
or has been modified in accordance with the wishes of the Copyright
- Holder.
+ Holder.
- "Copyright Holder" is whoever is named in the copyright or copyrights for
- the package.
+ the package.
- "You" is you, if you're thinking about copying or distributing this Package.
- "Reasonable copying fee" is whatever you can justify on the basis of media
cost, duplication charges, time of people involved, and so on. (You will
not be required to justify it to the Copyright Holder, but only to the
- computing community at large as a market that must bear the fee.)
+ computing community at large as a market that must bear the fee.)
- "Freely Available" means that no fee is charged for the item itself, though
there may be fees involved in handling the item. It also means that
recipients of the item may redistribute it under the same conditions they
- received it.
+ received it.
1. You may make and give away verbatim copies of the source form of the
Standard Version of this Package without restriction, provided that you
@@ -373,7 +373,7 @@ products derived from this software without specific prior written permission.
9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
-MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
The End
diff --git a/MANIFEST b/MANIFEST
index 9ba8f7a..2304b15 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,4 +1,4 @@
-# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.023.
+# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.024.
Changes
LICENSE
MANIFEST
@@ -13,5 +13,8 @@ lib/Proc/Background.pm
lib/Proc/Background/Unix.pm
lib/Proc/Background/Win32.pm
t/01proc.t
+t/10-io-redirect.t
+t/11-cwd.t
+t/12-autodie.t
t/sleep_exit.pl
weaver.ini
diff --git a/META.json b/META.json
index 8cb4296..8106832 100644
--- a/META.json
+++ b/META.json
@@ -5,7 +5,7 @@
"Michael Conrad <mike@nrdvana.net>"
],
"dynamic_config" : 1,
- "generated_by" : "Dist::Zilla version 6.023, CPAN::Meta::Converter version 2.150010",
+ "generated_by" : "Dist::Zilla version 6.024, CPAN::Meta::Converter version 2.150010",
"license" : [
"perl_5"
],
@@ -32,14 +32,14 @@
"web" : "https://github.com/nrdvana/perl-proc-background"
}
},
- "version" : "1.22",
+ "version" : "1.30",
"x_contributors" : [
"Florian Schlichting <fsfs@debian.org>",
"Kevin Ryde <user42@zip.com.au>",
"Salvador Fandi\u00f1o <sfandino@yahoo.com>"
],
- "x_generated_by_perl" : "v5.26.3",
- "x_serialization_backend" : "Cpanel::JSON::XS version 4.08",
+ "x_generated_by_perl" : "v5.34.0",
+ "x_serialization_backend" : "Cpanel::JSON::XS version 4.27",
"x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later"
}
diff --git a/META.yml b/META.yml
index 32f09e6..ebe8fde 100644
--- a/META.yml
+++ b/META.yml
@@ -7,7 +7,7 @@ build_requires: {}
configure_requires:
ExtUtils::MakeMaker: '0'
dynamic_config: 1
-generated_by: 'Dist::Zilla version 6.023, CPAN::Meta::Converter version 2.150010'
+generated_by: 'Dist::Zilla version 6.024, CPAN::Meta::Converter version 2.150010'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -16,11 +16,11 @@ name: Proc-Background
resources:
bugtracker: https://github.com/nrdvana/perl-proc-background/issues
repository: https://github.com/nrdvana/perl-proc-background.git
-version: '1.22'
+version: '1.30'
x_contributors:
- 'Florian Schlichting <fsfs@debian.org>'
- 'Kevin Ryde <user42@zip.com.au>'
- 'Salvador Fandiño <sfandino@yahoo.com>'
-x_generated_by_perl: v5.26.3
+x_generated_by_perl: v5.34.0
x_serialization_backend: 'YAML::Tiny version 1.73'
x_spdx_expression: 'Artistic-1.0-Perl OR GPL-1.0-or-later'
diff --git a/Makefile.PL b/Makefile.PL
index 1144c5e..9778e8d 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -1,5 +1,5 @@
# This Makefile.PL for Proc-Background was generated by
-# Dist::Zilla::Plugin::MakeMaker::Awesome 0.48.
+# Dist::Zilla::Plugin::MakeMaker::Awesome 0.49.
# Don't edit it but the dist.ini and plugins used to construct it.
use strict;
@@ -31,7 +31,7 @@ my %WriteMakefileArgs = (
"LICENSE" => "perl",
"NAME" => "Proc::Background",
"PREREQ_PM" => {},
- "VERSION" => "1.22",
+ "VERSION" => "1.30",
"test" => {
"TESTS" => "t/*.t"
}
diff --git a/README b/README
index 2091bf0..5692e6f 100644
--- a/README
+++ b/README
@@ -1,4 +1,4 @@
-Package Proc::Background Version 1.21
+Package Proc::Background Version 1.30
This is the Proc::Background package. It provides a generic interface
to running background processes. Through this interface, users can
@@ -10,12 +10,14 @@ methods are provided to users of the Proc::Background package:
new: start a new background process.
alive: test to see if the process is still alive.
- die: reliably try to kill the process.
+ suspend: pause the process
+ resume: resume a paused process
+ terminate: reliably try to kill the process.
wait: wait for the process to exit and return the exit status.
start_time: return the time that the process started.
end_time: return the time when the exit status was retrieved.
-A generic function, timed-system, is also included that lets a
+A generic function, timed_system, is also included that lets a
background process run for a specified amount of time, and if the
process did not exit, then the process is killed.
diff --git a/lib/Proc/Background.pm b/lib/Proc/Background.pm
index c2fe963..6d8e434 100644
--- a/lib/Proc/Background.pm
+++ b/lib/Proc/Background.pm
@@ -1,6 +1,6 @@
package Proc::Background;
-$Proc::Background::VERSION = '1.22';
-# ABSTRACT: Generic interface to background process management
+$Proc::Background::VERSION = '1.30';
+# ABSTRACT: Generic interface to Unix and Win32 background process management
require 5.004_04;
use strict;
@@ -49,7 +49,7 @@ if ($is_windows) {
sub _resolve_path {
my $command = shift;
- return unless length $command;
+ return ( undef, 'empty command string' ) unless length $command;
# Make the path to the progam absolute if it isn't already. If the
# path is not absolute and if the path contains a directory element
@@ -66,9 +66,7 @@ sub _resolve_path {
last;
}
}
- unless (defined $path) {
- warn "$0: no executable program located at $command\n";
- }
+ return defined $path? ( $path, undef ) : ( undef, "no executable program located at $command" );
} else {
my $cwd = cwd;
if ($command =~ /$has_dir_element_re/o) {
@@ -95,12 +93,20 @@ sub _resolve_path {
last if defined $path;
}
}
- unless (defined $path) {
- warn "$0: cannot find absolute location of $command\n";
- }
+ return defined $path? ( $path, undef ) : ( undef, "cannot find absolute location of $command" );
}
+}
- $path;
+# Define the set of allowed options, to warn about unknown ones.
+# Make it a method so subclasses can override it.
+%Proc::Background::_available_options= (
+ autodie => 1, command => 1, exe => 1,
+ cwd => 1, stdin => 1, stdout => 1, stderr => 1,
+ autoterminate => 1, die_upon_destroy => 1,
+);
+
+sub _available_options {
+ return \%Proc::Background::_available_options;
}
# We want the created object to live in Proc::Background instead of
@@ -108,26 +114,76 @@ sub _resolve_path {
sub new {
my $class = shift;
+ # The parameters are an optional %options hashref followed by any number
+ # of arguments to become the @argv for exec(). If options are given, check
+ # the keys for typos.
my $options;
- if (@_ and defined $_[0] and UNIVERSAL::isa($_[0], 'HASH')) {
- $options = shift;
+ if (@_ and ref $_[0] eq 'HASH') {
+ $options= shift;
+ my $known= $class->_available_options;
+ my @unknown= grep !$known->{$_}, keys %$options;
+ carp "Unknown options: ".join(', ', @unknown)
+ if @unknown;
+ }
+ else {
+ $options= {};
}
- unless (@_ > 0) {
- confess "Proc::Background::new called with insufficient number of arguments";
+ my $self= bless {}, $class;
+ $self->{_autodie}= 1 if $options->{autodie};
+
+ # Resolve any confusion between the 'command' option and positional @argv params.
+ # Store the command in $self->{_command} so that the ::Unix and ::Win32 don't have
+ # to deal with it redundantly.
+ my $cmd= $options->{command};
+ if (defined $cmd) {
+ croak "Can't use both 'command' option and command argument list"
+ if @_;
+ # Can be an arrayref or a single string
+ croak "command must be a non-empty string or an arrayref of strings"
+ unless (ref $cmd eq 'ARRAY' && defined $cmd->[0] && length $cmd->[0])
+ or (!ref $cmd && defined $cmd && length $cmd);
+ }
+ else {
+ # Back-compat: maintain original API quirks
+ confess "Proc::Background::new called with insufficient number of arguments"
+ unless @_;
+ return $self->_fatal('command is undefined') unless defined $_[0];
+
+ # Interpret the parameters as an @argv if there is more than one,
+ # or if the 'exe' option was given.
+ $cmd= (@_ > 1 || defined $options->{exe})? [ @_ ] : $_[0];
}
- return unless defined $_[0];
+ $self->{_command}= $cmd;
+ $self->{_exe}= $options->{exe} if defined $options->{exe};
- my $self = $class->SUPER::_new(@_) or return;
+ # Also back-compat: failing to fork or CreateProcess returns undef
+ return unless $self->_start($options);
- # Save the start time of the class.
+ # Save the start time
$self->{_start_time} = time;
- # Handle the specific options.
- if ($options) {
- if ($options->{die_upon_destroy}) {
- $self->{_die_upon_destroy} = 1;
+ if ($options->{autoterminate} || $options->{die_upon_destroy}) {
+ $self->autoterminate(1);
+ }
+
+ return $self;
+}
+
+# The original API returns undef from the constructor in case of various errors.
+# The autodie option converts these undefs into exceptions.
+sub _fatal {
+ my ($self, $message)= @_;
+ croak $message if $self->{_autodie};
+ warn "$0: $message";
+ return undef;
+}
+
+sub autoterminate {
+ my ($self, $newval)= @_;
+ if (@_ > 1 and ($newval xor $self->{_die_upon_destroy})) {
+ if ($newval) {
# Global destruction can break this feature, because there are no guarantees
# on which order object destructors are called. In order to avoid that, need
# to run all the ->die methods during END{}, and that requires weak
@@ -137,9 +193,12 @@ sub new {
# could warn about it for earlier perl... but has been broken for 15 years and
# who is still using < 5.8 anyway?
}
+ else {
+ delete $Proc::Background::_die_upon_destroy{$self+0};
+ }
+ $self->{_die_upon_destroy}= $newval? 1 : 0;
}
-
- bless $self, $class;
+ $self->{_die_upon_destroy} || 0
}
sub DESTROY {
@@ -148,7 +207,7 @@ sub DESTROY {
# During a mainline exit() $? is the prospective exit code from the
# parent program. Preserve it across any waitpid() in die()
local $?;
- $self->die;
+ $self->terminate;
delete $Proc::Background::_die_upon_destroy{$self+0};
}
}
@@ -156,7 +215,10 @@ sub DESTROY {
END {
# Child processes need killed before global destruction, else the
# Win32::Process objects might get destroyed first.
- $_->die for grep defined, values %Proc::Background::_die_upon_destroy;
+ for (grep defined, values %Proc::Background::_die_upon_destroy) {
+ $_->terminate;
+ delete $_->{_die_upon_destroy}
+ }
%Proc::Background::_die_upon_destroy= ();
}
@@ -203,12 +265,34 @@ sub alive {
!$self->_reap(0);
}
+sub suspended {
+ $_[0]->{_suspended}? 1 : 0
+}
+
+sub suspend {
+ my $self= shift;
+ return $self->_fatal("can't suspend, process has exited")
+ if !$self->{_os_obj};
+ $self->{_suspended} = 1 if $self->_suspend;
+ return $self->{_suspended};
+}
+
+sub resume {
+ my $self= shift;
+ return $self->_fatal("can't resume, process has exited")
+ if !$self->{_os_obj};
+ $self->{_suspended} = 0 if $self->_resume;
+ return !$self->{_suspended};
+}
+
sub wait {
my ($self, $timeout_seconds) = @_;
# If $self->{_exit_value} exists, then we already waited.
return $self->{_exit_value} if exists($self->{_exit_value});
+ carp "calling ->wait on a suspended process" if $self->{_suspended};
+
# If neither _os_obj or _exit_value are set, then something is wrong.
return undef if !exists($self->{_os_obj});
@@ -216,21 +300,30 @@ sub wait {
return $self->_reap(1, $timeout_seconds)? $self->{_exit_value} : undef;
}
+sub terminate { shift->die(@_) }
sub die {
my $self = shift;
+ croak "process is already terminated" if $self->{_autodie} && !$self->{_os_obj};
+
# See if the process has already died.
return 1 unless $self->alive;
- croak '->die(@kill_sequence) should have an even number of arguments'
- if @_ & 1;
# Kill the process using the OS specific method.
- $self->_die(@_? ([ @_ ]) : ());
+ $self->_terminate(@_? ([ @_ ]) : ());
# See if the process is still alive.
!$self->alive;
}
+sub command {
+ $_[0]->{_command};
+}
+
+sub exe {
+ $_[0]->{_exe}
+}
+
sub start_time {
$_[0]->{_start_time};
}
@@ -266,13 +359,21 @@ sub timeout_system {
my $proc = Proc::Background->new(@_) or return;
my $end_time = $proc->start_time + $timeout;
my $delay= $timeout;
- while ($delay > 0 && !defined $proc->exit_code) {
- $proc->wait($delay);
- $delay= $end_time - time;
+ while ($delay > 0 && defined $proc->{_os_obj}) {
+ last if defined $proc->wait($delay);
+ # If it times out, it's likely that wait() already waited the entire duration.
+ # But, if it got interrupted, there might be time remaining.
+ # But, if the system clock changes, this could break horribly. Constrain it to a sane value.
+ my $t= time;
+ if ($t < $end_time - $delay) { # time moved backward!
+ $end_time= $t + $delay;
+ } else {
+ $delay= $end_time - $t;
+ }
}
my $alive = $proc->alive;
- $proc->die if $alive;
+ $proc->terminate if $alive;
if (wantarray) {
return ($proc->wait, $alive);
@@ -291,27 +392,40 @@ __END__
=head1 NAME
-Proc::Background - Generic interface to background process management
+Proc::Background - Generic interface to Unix and Win32 background process management
=head1 SYNOPSIS
- use Proc::Background;
- timeout_system($seconds, $command, $arg1);
- timeout_system($seconds, "$command $arg1");
-
- my $proc1 = Proc::Background->new($command, $arg1, $arg2);
- my $proc2 = Proc::Background->new("$command $arg1 1>&2");
- $proc1->alive;
- $proc1->die;
+ use Proc::Background;
+ timeout_system($seconds, $command, $arg1, $arg2);
+ timeout_system($seconds, "$command $arg1 $arg2");
+
+ my $proc1 = Proc::Background->new($command, $arg1, $arg2) || die "failed";
+ my $proc2 = Proc::Background->new("$command $arg1 1>&2") || die "failed";
+ if ($proc1->alive) {
+ $proc1->terminate;
$proc1->wait;
- my $time1 = $proc1->start_time;
- my $time2 = $proc1->end_time;
-
- # Add an option to kill the process with die when the variable is
- # DESTROYed.
- my $opts = {'die_upon_destroy' => 1};
- my $proc3 = Proc::Background->new($opts, $command, $arg1, $arg2);
- $proc3 = undef;
+ }
+ say 'Ran for ' . ($proc1->end_time - $proc1->start_time) . ' seconds';
+
+ Proc::Background->new({
+ autodie => 1, # Throw exceptions instead of returning undef
+ cwd => 'some/path/', # Set working directory for the new process
+ exe => 'busybox', # Specify executable different from argv[0]
+ command => [ $command ] # resolve ambiguity of command line vs. argv[0]
+ });
+
+ # Set initial file handles
+ Proc::Background->new({
+ stdin => undef, # /dev/null or NUL
+ stdout => '/append/to/fname', # will try to open()
+ stderr => $log_fh, # use existing handle
+ command => \@command,
+ });
+
+ # Automatically kill the process if the object gets destroyed
+ my $proc4 = Proc::Background->new({ autoterminate => 1 }, $command);
+ $proc4 = undef; # calls ->terminate
=head1 DESCRIPTION
@@ -319,11 +433,7 @@ This is a generic interface for placing processes in the background on
both Unix and Win32 platforms. This module lets you start, kill, wait
on, retrieve exit values, and see if background processes still exist.
-=head1 NAME
-
-Proc::Background - Generic interface to Unix and Win32 background process management
-
-=head1 METHODS
+=head1 CONSTRUCTOR
=over 4
@@ -331,67 +441,111 @@ Proc::Background - Generic interface to Unix and Win32 background process manage
=item B<new> [options] 'I<command> [I<arg> [I<arg> ...]]'
-This creates a new background process. As exec() or system() may be
-passed an array with a single single string element containing a
-command to be passed to the shell or an array with more than one
-element to be run without calling the shell, B<new> has the same
-behavior.
-
-In certain cases B<new> will attempt to find I<command> on the system
-and fail if it cannot be found.
-
-For Win32 operating systems:
-
- The Win32::Process module is always used to spawn background
- processes on the Win32 platform. This module always takes a
- single string argument containing the executable's name and
- any option arguments. In addition, it requires that the
- absolute path to the executable is also passed to it. If
- only a single argument is passed to new, then it is split on
- whitespace into an array and the first element of the split
- array is used at the executable's name. If multiple
- arguments are passed to new, then the first element is used
- as the executable's name.
-
- If the executable's name is an absolute path, then new
- checks to see if the executable exists in the given location
- or fails otherwise. If the executable's name is not
- absolute, then the executable is searched for using the PATH
- environmental variable. The input executable name is always
- replaced with the absolute path determined by this process.
-
- In addition, when searching for the executable, the
- executable is searched for using the unchanged executable
- name and if that is not found, then it is checked by
- appending `.exe' to the name in case the name was passed
- without the `.exe' suffix.
-
- Finally, the argument array is placed back into a single
- string and passed to Win32::Process::Create.
-
-For non-Win32 operating systems, such as Unix:
-
- If more than one argument is passed to new, then new
- assumes that the command will not be passed through the
- shell and the first argument is the executable's relative
- or absolute path. If the first argument is an absolute
- path, then it is checked to see if it exists and can be
- run, otherwise new fails. If the path is not absolute,
- then the PATH environmental variable is checked to see if
- the executable can be found. If the executable cannot be
- found, then new fails. These steps are taking to prevent
- exec() from failing after an fork() without the caller of
- new knowing that something failed.
-
-The first argument to B<new> I<options> may be a reference to a hash
-which contains key/value pairs to modify Proc::Background's behavior.
-Currently the only key understood by B<new> is I<die_upon_destroy>.
-When this value is set to true, then when the Proc::Background object
-is being DESTROY'ed for any reason (i.e. the variable goes out of
-scope) the process is killed via the die() method.
-
-If anything fails, then new returns an empty list in a list context,
-an undefined value in a scalar context, or nothing in a void context.
+This creates a new background process. Just like C<system()>, you can
+supply a single string of the entire command line, or individual
+arguments. The first argument may be a hashref of named options.
+To resolve the ambiguity between a command line vs. a single-element
+argument list, see the C<command> option below.
+
+By default, the constructor returns an empty list on failure,
+except for a few cases of invalid arguments which call C<croak>.
+
+For platform-specific details, see L<Proc::Background::Unix/IMPLEMENTATION>
+or L<Proc::Background::Win32/IMPLEMENTATION>, but in short:
+
+=over 7
+
+=item Unix
+
+This implementation uses C<fork>/C<exec>. If you supply a single-string
+command line, it is passed to the shell. If you supply multiple arguments,
+they are passed to C<exec>. In the multi-argument case, it will also check
+that the executable exists before calling C<fork>.
+
+=item Win32
+
+This implementation uses the L<Windows CreateProcess API|Win32::Process/METHODS>.
+If you supply a single-string command line, it derives the executable by
+parsing the command line and looking for the first element in the C<PATH>,
+appending C<".exe"> if needed. If you supply multiple arguments, the
+first is used as the C<exe> and the command line is built using
+L<Win32::ShellQuote>.
+
+=back
+
+B<Options:>
+
+=over
+
+=item C<autodie>
+
+This module traditionally has returned C<undef> if the child could not
+be started. Modern Perl recommends the use of exceptions for things
+like this. This option, like Perl's L<autodie> pragma, causes all
+fatal errors in starting the process to die with exceptions instead of
+returning undef.
+
+=item C<command>
+
+You may specify the command as an option instead of passing the command
+as a list. A string value is considered a command line, and an arrayref
+value is considered an argument list. This can resolve the ambiguity
+between a command line vs. single-element argument list.
+
+=item C<exe>
+
+Specify the executable. This can serve two purposes:
+on Win32 it avoids the parsing of the commandline, and on Unix it can be
+used to run an executable while passing a different value for C<$ARGV[0]>.
+
+=item C<stdin>, C<stdout>, C<stderr>
+
+Specify one or more overrides for the standard handles of the child.
+The value should be a Perl filehandle with an underlying system C<fileno>
+value. As a convenience, you can pass C<undef> to open the C<NUL> device
+on Win32 or C</dev/null> on Unix. You may also pass a plain-scalar file
+name which this module will attmept to open for reading or appending.
+
+(for anything more elaborate, see L<IPC::Run> instead)
+
+Note that on Win32, none of the parent's handles are inherited by default,
+which is the opposite on Unix. When you specify any of these handles on
+Win32 the default will change to inherit them from the parent.
+
+=item C<cwd>
+
+Specify a path which should become the child process's current working
+directory. The path must already exist.
+
+=item C<autoterminate>
+
+If you pass a true value for this option, then destruction of the
+Proc::Background object (going out of scope, or script-end) will kill the
+process via C<< ->terminate >>. Without this option, the child process
+continues running. C<die_upon_destroy> is an alias for this option, used
+by previous versions of this module.
+
+=back
+
+=back
+
+=head1 ATTRIBUTES
+
+=over
+
+=item B<command>
+
+The command (string or arrayref) that was passed to the constructor.
+
+=item B<exe>
+
+The path to the executable that was passed as an option to the constructor,
+or derived from the C<command>.
+
+=item B<start_time>
+
+Return the value that the Perl function time() returned when the
+process was started.
=item B<pid>
@@ -400,29 +554,44 @@ even if the process has already finished.
=item B<alive>
-Return 1 if the process is still active, 0 otherwise.
+Return 1 if the process is still active, 0 otherwise. This makes a
+non-blocking call to C<wait> to check the real status of the process if it
+has not been reaped yet.
-=item B<die>, B<die(@kill_sequence)>
+=item B<suspended>
-Reliably try to kill the process. Returns 1 if the process no longer
-exists once B<die> has completed, 0 otherwise. This will also return
-1 if the process has already died.
+Boolean whether the process is thought to be stopped. This does not actually
+consult the operating system, and just returns the last known status from a
+call to C<suspend> or C<resume>. It is always false if C<alive> is false.
-C<@kill_sequence> is a list of actions and seconds-to-wait for that
-action to end the process. The default is C< TERM 2 TERM 8 KILL 3 KILL 7 >.
-On Unix this sends SIGTERM and SIGKILL; on Windows it just calls
-TerminateProcess (graceful termination is still a TODO).
+=item B<exit_code>
-Note that C<die()> on Proc::Background 1.10 and earlier on Unix called a
-sequence of:
+Returns the exit code of the process, assuming it exited cleanly.
+Returns C<undef> if the process has not exited yet, and 0 if the
+process exited with a signal (or TerminateProcess). Since 0 is
+ambiguous, check for C<exit_signal> first.
- ->die( ( HUP => 1 )x5, ( QUIT => 1 )x5, ( INT => 1 )x5, ( KILL => 1 )x5 );
+=item B<exit_signal>
+
+Returns the value of the signal the process exited with, assuming it
+died on a signal. Returns C<undef> if it has not exited yet, and 0
+if it did not die to a signal.
+
+=item B<end_time>
+
+Return the value that the Perl function time() returned when the exit
+status was obtained from the process.
+
+=item B<autoterminate>
-which didn't particularly make a lot of sense, since SIGHUP is open to
-interpretation, and QUIT is almost always immediately fatal and generates
-an unneeded coredump. The new default should accomodate programs that
-acknowledge a second SIGTERM, and give enough time for it to exit on a laggy
-system while still not holding up the main script too much.
+This writeable attribute lets you enable or disable the autoterminate
+option, which could also be passed to the constructor.
+
+=back
+
+=head1 METHODS
+
+=over
=item B<wait>
@@ -444,28 +613,44 @@ so it may not be compatible with scripts that use alarm() for other
purposes, or systems/perls that resume system calls after a signal.
In the event of a timeout, the return will be undef.
-=item B<exit_code>
+=item B<suspend>
-Returns the exit code of the process, assuming it exited cleanly.
-Returns C<undef> if the process has not exited yet, and 0 if the
-process exited with a signal (or TerminateProcess). Since 0 is
-ambiguous, check for C<exit_signal> first.
+Pause the process. This returns true if the process is stopped afterward.
+This throws an excetion if the process is not C<alive> and C<autodie> is
+enabled.
-=item B<exit_signal>
+=item B<resume>
-Returns the value of the signal the process exited with, assuming it
-died on a signal. Returns C<undef> if it has not exited yet, and 0
-if it did not die to a signal.
+Resume a paused process. This returns true if the process is not stopped
+afterward. This throws an exception if the process is not C<alive> and
+C<autodie> is enabled.
-=item B<start_time>
+=item B<terminate>, B<terminate(@kill_sequence)>
-Return the value that the Perl function time() returned when the
-process was started.
+Reliably try to kill the process. Returns 1 if the process no longer
+exists once B<terminate> has completed, 0 otherwise. This will also return
+1 if the process has already exited.
-=item B<end_time>
+C<@kill_sequence> is a list of actions and seconds-to-wait for that
+action to end the process. The default is C< TERM 2 TERM 8 KILL 3 KILL 7 >.
+On Unix this sends SIGTERM and SIGKILL; on Windows it just calls
+TerminateProcess (graceful termination is still a TODO).
-Return the value that the Perl function time() returned when the exit
-status was obtained from the process.
+Note that C<terminate()> (formerly named C<die()>) on Proc::Background 1.10
+and earlier on Unix called a sequence of:
+
+ ->die( ( HUP => 1 )x5, ( QUIT => 1 )x5, ( INT => 1 )x5, ( KILL => 1 )x5 );
+
+which wasn't what most people need, since SIGHUP is open to interpretation,
+and QUIT is almost always immediately fatal and generates a coredump.
+The new default should accomodate programs that acknowledge a second
+SIGTERM, and give enough time for it to exit on a laggy system while still
+not holding up the main script too much.
+
+C<die> is preserved as an alias for C<terminate>.
+
+This throws an exception if the process has been reaped and C<autodie> is
+enabled.
=back
@@ -478,12 +663,7 @@ status was obtained from the process.
=item B<timeout_system> 'I<timeout> I<command> [I<arg> [I<arg>...]]'
Run a command for I<timeout> seconds and if the process did not exit,
-then kill it. While the timeout is implemented using sleep(), this
-function makes sure that the full I<timeout> is reached before killing
-the process. B<timeout_system> does not wait for the complete
-I<timeout> number of seconds before checking if the process has
-exited. Rather, it sleeps repeatidly for 1 second and checks to see
-if the process still exists.
+then kill it.
In a scalar context, B<timeout_system> returns the exit status from
the process. In an array context, B<timeout_system> returns a two
@@ -501,36 +681,6 @@ scalar context, or nothing in a void context.
=back
-=head1 IMPLEMENTATION
-
-I<Proc::Background> comes with two modules, I<Proc::Background::Unix>
-and I<Proc::Background::Win32>. Currently, on Unix platforms
-I<Proc::Background> uses the I<Proc::Background::Unix> class and on
-Win32 platforms it uses I<Proc::Background::Win32>, which makes use of
-I<Win32::Process>.
-
-The I<Proc::Background> assigns to @ISA either
-I<Proc::Background::Unix> or I<Proc::Background::Win32>, which does
-the OS dependent work. The OS independent work is done in
-I<Proc::Background>.
-
-Proc::Background uses two variables to keep track of the process.
-$self->{_os_obj} contains the operating system object to reference the
-process. On a Unix systems this is the process id (pid). On Win32,
-it is an object returned from the I<Win32::Process> class. When
-$self->{_os_obj} exists, then the process is running. When the
-process dies, this is recorded by deleting $self->{_os_obj} and saving
-the exit value $self->{_exit_value}.
-
-Anytime I<alive> is called, a waitpid() is called on the process and
-the return status, if any, is gathered and saved for a call to
-I<wait>. This module does not install a signal handler for SIGCHLD.
-If for some reason, the user has installed a signal handler for
-SIGCHLD, then, then when this module calls waitpid(), the failure will
-be noticed and taken as the exited child, but it won't be able to
-gather the exit status. In this case, the exit status will be set to
-0.
-
=head1 SEE ALSO
=over
@@ -547,11 +697,9 @@ and should be more reliable for simple needs.
=item L<Win32::ShellQuote>
-If you are running on Win32, this article by helps describe the problem you
-are up against for passing argument lists:
-
+If you are running on Win32, this article by Daniel Colascione helps
+describe the problem you are up against for passing argument lists:
L<Everyone quotes command line arguments the wrong way|https://blogs.msdn.microsoft.com/twistylittlepassagesallalike/2011/04/23/everyone-quotes-command-line-arguments-the-wrong-way/>
-by Daniel Colascione.
This module gives you parsing / quoting per the standard
CommandLineToArgvW behavior. But, if you need to pass arguments to be
@@ -595,7 +743,7 @@ Salvador Fandiño <sfandino@yahoo.com>
=head1 VERSION
-version 1.22
+version 1.30
=head1 COPYRIGHT AND LICENSE
diff --git a/lib/Proc/Background/Unix.pm b/lib/Proc/Background/Unix.pm
index eb606ff..e937ee1 100644
--- a/lib/Proc/Background/Unix.pm
+++ b/lib/Proc/Background/Unix.pm
@@ -1,74 +1,161 @@
package Proc::Background::Unix;
-$Proc::Background::Unix::VERSION = '1.22';
+$Proc::Background::Unix::VERSION = '1.30';
# ABSTRACT: Unix-specific implementation of process create/wait/kill
require 5.004_04;
use strict;
use Exporter;
use Carp;
-use POSIX qw(:errno_h :sys_wait_h);
+use POSIX qw( :errno_h :sys_wait_h );
+
+# Test for existence of FD_CLOEXEC, needed for child-error-through-pipe trick
+my ($FD_CLOEXEC);
+eval {
+ require Fcntl;
+ $FD_CLOEXEC= Fcntl::FD_CLOEXEC();
+};
+
# For un-explained mysterious reasons, Time::HiRes::alarm seem to misbehave on 5.10 and earlier
-if ($] >= 5.012) {
- require Time::HiRes;
- Time::HiRes->import('alarm');
-}
-else {
- *alarm= sub {
- # round up to whole seconds
+# but core alarm works fine.
+my $alarm= ($] >= 5.012)? do { require Time::HiRes; \&Time::HiRes::alarm; }
+ : sub {
+ # round up to whole seconds
CORE::alarm(POSIX::ceil($_[0]));
};
-}
@Proc::Background::Unix::ISA = qw(Exporter);
# Start the background process. If it is started sucessfully, then record
# the process id in $self->{_os_obj}.
-sub _new {
- my $class = shift;
-
- unless (@_ > 0) {
- confess "Proc::Background::Unix::_new called with insufficient number of arguments";
+sub _start {
+ my ($self, $options)= @_;
+
+ # There are three main scenarios for how-to-exec:
+ # * single-string command, to be handled by shell
+ # * arrayref command, to be handled by execve
+ # * arrayref command with 'exe' (fake argv0)
+ # and one that isn't logical:
+ # * single-string command with exe
+ # throw an error for that last one rather than trying something awkward
+ # like splitting the command string.
+
+ my @argv;
+ my $cmd= $self->{_command};
+ my $exe= $self->{_exe};
+
+ if (ref $cmd eq 'ARRAY') {
+ @argv= @$cmd;
+ ($exe, my $err) = Proc::Background::_resolve_path(defined $exe? $exe : $argv[0]);
+ return $self->_fatal($err) unless defined $exe;
+ $self->{_exe}= $exe;
+ } elsif (defined $exe) {
+ croak "Can't combine 'exe' option with single-string 'command', use arrayref 'command' instead.";
}
- return unless defined $_[0];
-
- # If there is only one element in the @_ array, then it may be a
- # command to be passed to the shell and should not be checked, in
- # case the command sets environmental variables in the beginning,
- # i.e. 'VAR=arg ls -l'. If there is more than one element in the
- # array, then check that the first element is a valid executable
- # that can be found through the PATH and find the absolute path to
- # the executable. If the executable is found, then replace the
- # first element it with the absolute path.
- my @args = @_;
- if (@_ > 1) {
- $args[0] = Proc::Background::_resolve_path($args[0]) or return;
+ if (defined $options->{cwd}) {
+ -d $options->{cwd}
+ or return $self->_fatal("directory does not exist: '$options->{cwd}'");
}
- my $self = bless {}, $class;
+ my ($new_stdin, $new_stdout, $new_stderr);
+ $new_stdin= _resolve_file_handle($options->{stdin}, '<', \*STDIN)
+ if exists $options->{stdin};
+ $new_stdout= _resolve_file_handle($options->{stdout}, '>>', \*STDOUT)
+ if exists $options->{stdout};
+ $new_stderr= _resolve_file_handle($options->{stderr}, '>>', \*STDERR)
+ if exists $options->{stderr};
# Fork a child process.
+ my ($pipe_r, $pipe_w);
+ if (defined $FD_CLOEXEC) {
+ # use a pipe for the child to report exec() errors
+ pipe $pipe_r, $pipe_w or return $self->_fatal("pipe: $!");
+ # This pipe needs to be in the non-preserved range that doesn't exist after exec().
+ # In the edge case where a pipe received a FD less than $^F, the CLOEXEC flag isn't set.
+ # Try again on higher descriptors, then close the lower ones.
+ my @rejects;
+ while (fileno $pipe_r <= $^F or fileno $pipe_w <= $^F) {
+ push @rejects, $pipe_r, $pipe_w;
+ pipe $pipe_r, $pipe_w or return $self->_fatal("pipe: $!");
+ }
+ }
my $pid;
{
if ($pid = fork()) {
# parent
$self->{_os_obj} = $pid;
$self->{_pid} = $pid;
+ if (defined $pipe_r) {
+ close $pipe_w;
+ # wait for child to reply or close the pipe
+ local $SIG{PIPE}= sub {};
+ my $msg= '';
+ while (0 < read $pipe_r, $msg, 1024, length $msg) {}
+ close $pipe_r;
+ # If child wrote anything to the pipe, it failed to exec.
+ # Reap it before dying.
+ if (length $msg) {
+ waitpid $pid, 0;
+ return $self->_fatal($msg);
+ }
+ }
last;
} elsif (defined $pid) {
# child
- exec @_ or croak "$0: exec failed: $!\n";
+ # Make absolutely sure nothing in this block interacts with the rest of the
+ # process state, and that flow control never skips the _exit().
+ eval {
+ local $SIG{__DIE__}= undef;
+ eval {
+ chdir($options->{cwd}) or die "chdir($options->{cwd}): $!\n"
+ if defined $options->{cwd};
+
+ open STDIN, '<&', $new_stdin or die "Can't redirect STDIN: $!\n"
+ if defined $new_stdin;
+ open STDOUT, '>&', $new_stdout or die "Can't redirect STDOUT: $!\n"
+ if defined $new_stdout;
+ open STDERR, '>&', $new_stderr or die "Can't redirect STDERR: $!\n"
+ if defined $new_stderr;
+
+ if (defined $exe) {
+ exec { $exe } @argv or die "$0: exec failed: $!\n";
+ } else {
+ exec $cmd or die "$0: exec failed: $!\n";
+ }
+ };
+ if (defined $pipe_w) {
+ print $pipe_w $@;
+ close $pipe_w; # force it to flush. Nothing else needs closed because we are about to _exit
+ } else {
+ print STDERR $@;
+ }
+ };
+ POSIX::_exit(1);
} elsif ($! == EAGAIN) {
sleep 5;
redo;
} else {
- return;
+ return $self->_fatal("fork: $!");
}
}
$self;
}
+sub _resolve_file_handle {
+ my ($thing, $mode, $default)= @_;
+ if (!defined $thing) {
+ open my $fh, $mode, '/dev/null' or croak "open(/dev/null): $!";
+ return $fh;
+ } elsif (ref $thing) {
+ # use 'undef' to mean no-change
+ return (fileno($thing) == fileno($default))? undef : $thing;
+ } else {
+ open my $fh, $mode, $thing or croak "open($thing): $!";
+ return $fh;
+ }
+}
+
# Wait for the child.
# (0, exit_value) : sucessfully waited on.
# (1, undef) : process already reaped and exit value lost.
@@ -82,9 +169,9 @@ sub _waitpid {
my $result= 0;
if ($blocking && $wait_seconds) {
local $SIG{ALRM}= sub { die "alarm\n" };
- alarm($wait_seconds);
+ $alarm->($wait_seconds);
eval { $result= waitpid($self->{_os_obj}, 0); };
- alarm(0);
+ $alarm->(0);
}
else {
$result= waitpid($self->{_os_obj}, $blocking? 0 : WNOHANG);
@@ -92,6 +179,7 @@ sub _waitpid {
# Process finished. Grab the exit value.
if ($result == $self->{_os_obj}) {
+ delete $self->{_suspended};
return (0, $?);
}
# Process already reaped. We don't know the exist status.
@@ -108,7 +196,15 @@ sub _waitpid {
return 0;
}
-sub _die {
+sub _suspend {
+ kill STOP => $_[0]->{_os_obj};
+}
+
+sub _resume {
+ kill CONT => $_[0]->{_os_obj};
+}
+
+sub _terminate {
my $self = shift;
my @kill_sequence= @_ && ref $_[0] eq 'ARRAY'? @{ $_[0] } : qw( TERM 2 TERM 8 KILL 3 KILL 7 );
# Try to kill the process with different signals. Calling alive() will
@@ -117,6 +213,7 @@ sub _die {
my $sig= shift @kill_sequence;
my $delay= shift @kill_sequence;
kill($sig, $self->{_os_obj});
+ next unless defined $delay;
last if $self->_reap(1, $delay); # block before sending next signal
}
}
@@ -133,19 +230,47 @@ __END__
Proc::Background::Unix - Unix-specific implementation of process create/wait/kill
-=head1 SYNOPSIS
-
-Do not use this module directly.
-
=head1 DESCRIPTION
-This is a process management class designed specifically for Unix
-operating systems. It is not meant used except through the
-I<Proc::Background> class. See L<Proc::Background> for more information.
+This module does not have a public interface. Use L<Proc::Background>.
=head1 NAME
-Proc::Background::Unix - Unix interface to process management
+Proc::Background::Unix - Implementation of process management for Unix systems
+
+=head1 IMPLEMENTATION
+
+=head2 Command vs. Exec
+
+Unix systems start a new process by creating a mirror of the current process
+(C<fork>) and then having it alter its own state to prepare for the new
+program, and then calling C<exec> to replace the running code with code loaded
+from a new file. However, there is a second common method where the user
+wants to specify a command line string as they would type it in their shell.
+In this case, the actual program being executed is the shell, and the command
+line is given as one element of its argument list.
+
+Perl already supports both methods, such that if you pass one string to C<exec>
+containing shell characters, it calls the shell, and if you pass multiple
+arguments, it directly invokes C<exec>.
+
+This module mostly just lets Perl's C<exec> do its job, but also checks for
+the existence of the executable first, to make errors easier to catch. This
+check is skipped if there is a single-string command line.
+
+Unix lets you run a different executable than what is listed in the first
+argument. (this feature lets one Unix executable behave as multiple
+different programs depending on what name it sees in the first argument)
+You can use that feature by passing separate options of C<exe> and C<command>
+to this module's constructor instead of a simple argument list. But, you
+can't mix a C<exe> option with a shell-interpreted command line string.
+
+=head2 Errors during Exec
+
+If the C<autodie> option is enabled, and the system supports C<FD_CLOEXEC>,
+this module uses a trick where the forked child relays any errors through
+a pipe so that the parent can throw and handle the exception directly instead
+of creating a child process that is dead-on-arrival with the error on STDERR.
=head1 AUTHORS
@@ -163,7 +288,7 @@ Michael Conrad <mike@nrdvana.net>
=head1 VERSION
-version 1.22
+version 1.30
=head1 COPYRIGHT AND LICENSE
diff --git a/lib/Proc/Background/Win32.pm b/lib/Proc/Background/Win32.pm
index 2dbb912..41b8a00 100644
--- a/lib/Proc/Background/Win32.pm
+++ b/lib/Proc/Background/Win32.pm
@@ -1,40 +1,36 @@
package Proc::Background::Win32;
-$Proc::Background::Win32::VERSION = '1.22';
+$Proc::Background::Win32::VERSION = '1.30';
# ABSTRACT: Windows-specific implementation of process create/wait/kill
require 5.004_04;
use strict;
use Exporter;
use Carp;
+use Win32;
use Win32::Process qw( NORMAL_PRIORITY_CLASS INFINITE );
use Win32::ShellQuote ();
@Proc::Background::Win32::ISA = qw(Exporter);
-sub _new {
- my $class = shift;
+sub _start {
+ my ($self, $options)= @_;
+ my ($exe, $cmd, $cmdline)= ( $self->{_exe}, $self->{_command}, undef );
- unless (@_ > 0) {
- confess "Proc::Background::Win32::_new called with insufficient number of arguments";
- }
-
- return unless defined $_[0];
-
- # If there is only one argument, treat it as system() would and assume
+ # If 'command' is a single string, treat it as system() would and assume
# it should be split into arguments. The first argument is then the
- # application executable.
- my ($exe, $cmdline);
- if (@_ == 1) {
- $cmdline= $_[0];
- ($exe) = Win32::ShellQuote::unquote_native($cmdline);
+ # application executable, if not already specified as an option.
+ if (ref $cmd ne 'ARRAY') {
+ $cmdline= $cmd;
+ ($exe) = Win32::ShellQuote::unquote_native($cmdline)
+ unless defined $exe;
}
# system() would treat a list of arguments as an un-quoted ARGV
# for the program, so concatenate them into a command line appropriate
# for Win32 CommandLineToArgvW to decode back to what we started with.
# Preserve the first un-quoted argument for use as lpApplicationName.
else {
- $exe = $_[0];
- $cmdline= Win32::ShellQuote::quote_native(@_);
+ $exe = $cmd->[0] unless defined $exe;
+ $cmdline= Win32::ShellQuote::quote_native(@$cmd);
}
# Find the absolute path to the program. If it cannot be found,
@@ -42,27 +38,86 @@ sub _new {
# Win32::Process::Create cannot start a process when the full
# pathname has a space in it, convert the full pathname to the
# Windows short 8.3 format which contains no spaces.
- $exe = Proc::Background::_resolve_path($exe) or return;
+ ($exe, my $err) = Proc::Background::_resolve_path($exe);
+ return $self->_fatal($err) unless defined $exe;
$exe = Win32::GetShortPathName($exe);
+
+ my $cwd= '.';
+ if (defined $options->{cwd}) {
+ -d $options->{cwd}
+ or return $self->_fatal("directory does not exist: '$options->{cwd}'");
+ $cwd= $options->{cwd};
+ }
+
+ # On Strawberry Perl, CreateProcess will inherit the current process STDIN/STDOUT/STDERR,
+ # but there is no way to specify them without altering the current process.
+ # So, redirect handles, then create process, then revert them.
+ my ($inherit, $new_stdin, $old_stdin, $new_stdout, $old_stdout, $new_stderr, $old_stderr);
+ if (exists $options->{stdin}) {
+ $inherit= 1;
+ $new_stdin= _resolve_file_handle($options->{stdin}, '<', \*STDIN);
+ open $old_stdin, '<&', \*STDIN or croak "Can't save STDIN: $!\n"
+ if defined $new_stdin;
+ }
+ if (exists $options->{stdout}) {
+ $inherit= 1;
+ $new_stdout= _resolve_file_handle($options->{stdout}, '>>', \*STDOUT);
+ open $old_stdout, '>&', \*STDOUT or croak "Can't save STDOUT: $!\n"
+ if defined $new_stdout;
+ }
+ if (exists $options->{stderr}) {
+ $inherit= 1;
+ $new_stderr= _resolve_file_handle($options->{stderr}, '>>', \*STDERR);
+ open $old_stderr, '>&', \*STDERR or croak "Can't save STDERR: $!\n"
+ if defined $new_stderr;
+ }
+
+ {
+ local $@;
+ eval {
+ open STDIN, '<&', $new_stdin or die "Can't redirect STDIN: $!\n"
+ if defined $new_stdin;
+ open STDOUT, '>&', $new_stdout or die "Can't redirect STDOUT: $!\n"
+ if defined $new_stdout;
+ open STDERR, '>&', $new_stderr or die "Can't redirect STDERR: $!\n"
+ if defined $new_stderr;
+
+ # Perl 5.004_04 cannot run Win32::Process::Create on a nonexistant
+ # hash key.
+ my $os_obj = 0;
+
+ # Create the process.
+ Win32::Process::Create($os_obj, $exe, $cmdline, $inherit, NORMAL_PRIORITY_CLASS, $cwd)
+ or die Win32::FormatMessage( Win32::GetLastError() )."\n";
+ $self->{_pid} = $os_obj->GetProcessID;
+ $self->{_os_obj} = $os_obj;
+ };
+ chomp($err= $@);
+ # Now restore handles before throwing exception
+ open STDERR, '>&', $old_stderr or warn "Can't restore STDERR: $!\n"
+ if defined $old_stderr;
+ open STDOUT, '>&', $old_stdout or warn "Can't restore STDOUT: $!\n"
+ if defined $old_stdout;
+ open STDIN, '<&', $old_stdin or warn "Can't restore STDIN: $!\n"
+ if defined $old_stdin;
+ }
+ if ($self->{_os_obj}) {
+ return 1;
+ } else {
+ return $self->_fatal($err);
+ }
+}
- my $self = bless {}, $class;
-
- # Perl 5.004_04 cannot run Win32::Process::Create on a nonexistant
- # hash key.
- my $os_obj = 0;
-
- # Create the process.
- if (Win32::Process::Create($os_obj,
- $exe,
- $cmdline,
- 0,
- NORMAL_PRIORITY_CLASS,
- '.')) {
- $self->{_pid} = $os_obj->GetProcessID;
- $self->{_os_obj} = $os_obj;
- return $self;
+sub _resolve_file_handle {
+ my ($thing, $mode, $default)= @_;
+ if (!defined $thing) {
+ open my $fh, $mode, 'NUL' or croak "open(NUL): $!";
+ return $fh;
+ } elsif (ref $thing) {
+ return fileno($thing) == fileno($default)? undef : $thing;
} else {
- return;
+ open my $fh, $mode, $thing or croak "open($thing): $!";
+ return $fh;
}
}
@@ -77,6 +132,7 @@ sub _waitpid {
my $result = $self->{_os_obj}->Wait($wait_seconds? int($wait_seconds * 1000) : $blocking ? INFINITE : 0);
# Process finished. Grab the exit value.
if ($result == 1) {
+ delete $self->{_suspended};
my $exit_code;
$self->{_os_obj}->GetExitCode($exit_code);
if ($exit_code == 256 && $self->{_called_terminateprocess}) {
@@ -93,7 +149,15 @@ sub _waitpid {
return (0, 1<<8);
}
-sub _die {
+sub _suspend {
+ $_[0]->{_os_obj}->Suspend();
+}
+
+sub _resume {
+ $_[0]->{_os_obj}->Resume();
+}
+
+sub _terminate {
my $self = shift;
my @kill_sequence= @_ && ref $_[0] eq 'ARRAY'? @{ $_[0] } : qw( TERM 2 TERM 8 KILL 3 KILL 7 );
@@ -102,28 +166,29 @@ sub _die {
while (@kill_sequence and $self->alive) {
my $sig= shift @kill_sequence;
my $delay= shift @kill_sequence;
- $sig eq 'KILL'? $self->_send_sigkill : $self->_send_sigterm;
+ # TODO: fix _taskkill, then re-enable: $sig eq 'KILL'? $self->_terminateprocess : $self->_taskkill;
+ $self->_terminateprocess;
+ next unless defined $delay;
last if $self->_reap(1, $delay); # block before sending next signal
}
}
# Use taskkill.exe as a sort of graceful SIGTERM substitute.
-sub _send_sigterm {
+sub _taskkill {
my $self = shift;
# TODO: This doesn't work reliably. Disabled for now, and continue to be heavy-handed
# using TerminateProcess. The right solution would either be to do more elaborate setup
# to make sure the correct taskkill.exe is used (and available), or to dig much deeper
# into Win32 API to enumerate windows or threads and send WM_QUIT, or whatever other APIs
# processes might be watching on Windows. That should probably be its own module.
- # my $pid= $self->{_pid};
- # my $out= `taskkill.exe /PID $pid`;
+ my $pid= $self->{_pid};
+ my $out= `taskkill.exe /PID $pid`;
# If can't run taskkill, fall back to TerminateProcess
- # $? == 0 or
- $self->_send_sigkill;
+ $self->_terminateprocess unless $? == 0;
}
# Win32 equivalent of SIGKILL is TerminateProcess()
-sub _send_sigkill {
+sub _terminateprocess {
my $self = shift;
$self->{_os_obj}->Kill(256); # call TerminateProcess, essentially SIGKILL
$self->{_called_terminateprocess} = 1;
@@ -141,23 +206,63 @@ __END__
Proc::Background::Win32 - Windows-specific implementation of process create/wait/kill
-=head1 SYNOPSIS
-
-Do not use this module directly.
-
=head1 DESCRIPTION
-This is a process management class designed specifically for Win32
-operating systems. It is not meant used except through the
-I<Proc::Background> class. See L<Proc::Background> for more information.
+This module does not have a public interface. Use L<Proc::Background>.
=head1 NAME
-Proc::Background::Win32 - Interface to process management on Win32 systems
+Proc::Background::Win32 - Implementation of process management for Win32 systems
=head1 IMPLEMENTATION
-This package uses the Win32::Process class to manage the objects.
+=head2 Perl Fork Limitations
+
+When Perl is built as a native Win32 application, the C<fork> and C<exec> are
+a broken approximation of their Unix counterparts. Calling C<fork> creates a
+I<thread> instead of a process, and there is no way to exit the thread without
+running Perl cleanup code, which could damage the parent in unpredictable
+ways, like closing file handles. Calling C<POSIX::_exit> will kill both
+parent and child (the whole process), and even calling C<exec> in the child
+still runs global destruction. File handles are shared between parent and
+child, so any file handle redirection you perform in the forked child will
+affect the parent and vice versa.
+
+In short, B<never> call C<fork> or C<exec> on native Win32 Perl.
+
+=head2 Command Line
+
+This module implements background processes using C<Win32::Process>, which
+uses the Windows API's concepts of C<CreateProcess>, C<TerminateProces>,
+C<WaitForSingleObject>, C<GetExitCode>, and so on.
+
+Windows CreateProcess expects an executable name and a command line; breaking
+the command line into an argument list is left to each individual application,
+most of which use the library function C<CommandLineToArgvW>. This module
+C<Win32::ShellQuote> to parse and format Windows command lines.
+
+If you supply a single-string command line, and don't specify the executable
+with the C<'exe'> option, it splits the command line and uses the first
+argument. Then it looks for that argument in the C<PATH>, searching again
+with a suffix of C<".exe"> if the original wasn't found.
+
+If you supply a command of multiple arguments, they are combined into a command
+line using C<Win32::ShellQuote>. The first argument is used as the executable
+(unless you specified the C<'exe'> option), and gets the same path lookup.
+
+=head2 Initial File Handles
+
+When no options are specified, the new process does not inherit any file handles
+of the current process. This differs from the Unix implementation, but I'm
+leaving it this way for back-compat. If you specify any of stdin, stdout, or
+stderr, this module delivers them to the new process by temporarily redirecting
+STDIN, STDOUT, and STDERR of the current process, which the child process then
+inherits. Any handle not specified will be inherited as-is. If you wish to
+redirect a handle to NUL, set the option to C<undef>:
+
+ stdin => undef, # stdin will read from NUL device
+ stdout => $some_fh, # stdout will write to a file handle
+ stderr => \*STDERR, # stderr will go to the same STDERR of the current process
=head1 AUTHORS
@@ -175,7 +280,7 @@ Michael Conrad <mike@nrdvana.net>
=head1 VERSION
-version 1.22
+version 1.30
=head1 COPYRIGHT AND LICENSE
diff --git a/t/10-io-redirect.t b/t/10-io-redirect.t
new file mode 100644
index 0000000..04f1aab
--- /dev/null
+++ b/t/10-io-redirect.t
@@ -0,0 +1,102 @@
+use strict;
+use Test;
+BEGIN { plan tests => 7; }
+use FindBin;
+use File::Spec::Functions qw( catfile tmpdir );
+use Proc::Background;
+
+=head1 DESCRIPTION
+
+This tests the options 'stdin','stdout','stderr' that assign the file
+handles of the child process. It writes a unique string to a temp file,
+then runs a child process that reads stdin and echoes to stdout and stderr,
+then it checks that stdout and stderr files have the correct content.
+
+=cut
+
+sub open_or_die {
+ open my $fh, $_[0], $_[1] or die "open($_[2]): $!";
+ $fh;
+}
+sub readfile {
+ my $fh= open_or_die('<:raw', $_[0]);
+ local $/= undef;
+ scalar <$fh>;
+}
+sub writefile {
+ my $fh= open_or_die('>:raw', $_[0]);
+ print $fh $_[1] or die "print: $!";
+ close $fh or die "close: $!";
+}
+
+my $tmp_prefix= $FindBin::Script;
+$tmp_prefix =~ s/-.*//;
+
+my $stdin_fname= catfile(tmpdir, "$tmp_prefix-stdin-$$.txt" );
+my $stdout_fname= catfile(tmpdir, "$tmp_prefix-stdout-$$.txt");
+my $stderr_fname= catfile(tmpdir, "$tmp_prefix-stderr-$$.txt");
+
+# Write something to the stdin file. Then run the script which reads it and echoes to both stdout and stderr.
+my ($stdin, $stdout, $stderr);
+my $content= "Time = ".time."\r\n";
+writefile($stdin_fname, $content);
+
+my $proc= Proc::Background->new({
+ stdin => open_or_die('<', $stdin_fname),
+ stdout => open_or_die('>', $stdout_fname),
+ stderr => open_or_die('>', $stderr_fname),
+ command => [ $^X, '-we', <<'END' ],
+use strict;
+binmode STDIN;
+binmode STDOUT;
+binmode STDERR;
+$/= undef;
+my $content= <STDIN>;
+print STDOUT $content;
+print STDERR $content;
+END
+});
+ok( !!$proc, 1, 'started child' ); # 1
+$proc->wait;
+ok( $proc->exit_code, 0, 'exit_code' ); # 2
+ok( readfile($stdout_fname), $content, 'stdout content' ); # 3
+ok( readfile($stderr_fname), $content, 'stderr content' ); # 4
+
+# Test redirection to Win32 NUL or unix /dev/null
+
+$proc= Proc::Background->new({
+ stdin => undef,
+ stdout => undef,
+ stderr => undef,
+ command => [ $^X, '-we', <<'END' ],
+use strict;
+print "Nobody should see this\n";
+print STDERR "Nobody should see this\n";
+END
+});
+ok( !!$proc, 1, 'started child' ); # 5
+$proc->wait;
+ok( $proc->exit_code, 0, 'exit_code' ); # 6
+
+# Let the child process write the final 'ok' message
+
+$|= 1;
+$proc= Proc::Background->new({
+ stdin => undef,
+ stdout => \*STDOUT,
+ stderr => $stderr_fname,
+ command => [ $^X, '-we', <<'END' ],
+use strict;
+binmode STDERR;
+print STDERR "appended a line\n";
+print "ok 7\r\n";
+END
+});
+$proc->wait;
+$proc->exit_code == 0 or die "Final test exited with ".$proc->exit_code;
+my $err= readfile($stderr_fname);
+$err eq $content."appended a line\n" or die "Final test wrong stderr: $err";
+
+unlink $stdin_fname;
+unlink $stdout_fname;
+unlink $stderr_fname;
diff --git a/t/11-cwd.t b/t/11-cwd.t
new file mode 100644
index 0000000..5a6db7b
--- /dev/null
+++ b/t/11-cwd.t
@@ -0,0 +1,66 @@
+use strict;
+use Test;
+BEGIN { plan tests => 6; }
+use FindBin;
+use File::Spec::Functions qw( catfile tmpdir );
+use Cwd qw( abs_path getcwd );
+use Proc::Background;
+
+=head1 DESCRIPTION
+
+This tests the option 'cwd' that runs the child in a different directory.
+
+=cut
+
+sub open_or_die {
+ open my $fh, $_[0], $_[1] or die "open($_[2]): $!";
+ $fh;
+}
+sub readfile {
+ my $fh= open_or_die('<:raw', $_[0]);
+ local $/= undef;
+ scalar <$fh>;
+}
+sub writefile {
+ my $fh= open_or_die('>:raw', $_[0]);
+ print $fh $_[1] or die "print: $!";
+ close $fh or die "close: $!";
+}
+
+my $tmp_prefix= $FindBin::Script;
+$tmp_prefix =~ s/-.*//;
+
+my $script_fname= catfile(tmpdir, "$tmp_prefix-echodir-$$.pl");
+writefile($script_fname, <<'END');
+use strict;
+use Cwd;
+binmode STDOUT;
+print STDOUT getcwd()."\r\n";
+END
+
+my $stdout_fname= catfile(tmpdir, "$tmp_prefix-stdout-$$.txt");
+
+# Run the script in the current directory
+my $proc= Proc::Background->new({
+ stdout => open_or_die('>', $stdout_fname),
+ cwd => '.',
+ command => [ $^X, '-w', $script_fname ],
+});
+ok( !!$proc, 1, 'started child' ); # 1
+$proc->wait;
+ok( $proc->exit_code, 0, 'exit_code' ); # 2
+ok( readfile($stdout_fname), getcwd()."\r\n", 'stdout content' ); # 3
+
+# Now run the script in the tmp directory
+$proc= Proc::Background->new({
+ stdout => open_or_die('>', $stdout_fname),
+ cwd => abs_path(tmpdir),
+ command => [ $^X, '-w', $script_fname ],
+});
+ok( !!$proc, 1, 'started child' ); # 1
+$proc->wait;
+ok( $proc->exit_code, 0, 'exit_code' ); # 2
+ok( readfile($stdout_fname), abs_path(tmpdir)."\r\n", 'stdout content' ); # 3
+
+unlink $stdout_fname;
+unlink $script_fname;
diff --git a/t/12-autodie.t b/t/12-autodie.t
new file mode 100644
index 0000000..da74cc2
--- /dev/null
+++ b/t/12-autodie.t
@@ -0,0 +1,42 @@
+use strict;
+use Test;
+BEGIN { plan tests => 7; }
+use FindBin;
+use Cwd qw( abs_path getcwd );
+use Proc::Background;
+
+=head1 DESCRIPTION
+
+This tests the option 'cwd' that runs the child in a different directory.
+
+=cut
+
+sub new_and_catch {
+ my @args= @_;
+ local $@;
+ my ($proc, $err);
+ unless (eval {
+ $proc= Proc::Background->new(@args);
+ 1;
+ }) { $err= $@; }
+ #use DDP; &p([$proc, $err, $@]);
+ return ($proc, $err);
+}
+
+my ($proc, $err)= new_and_catch('command_that_does_not_exist', '');
+ok( $proc, undef ); # 1
+ok( $err, undef ); # 2
+
+($proc, $err)= new_and_catch({ autodie => 1 }, 'command_that_does_not_exist', '');
+$proc->wait if defined $proc;
+ok( $err ); # 3
+
+($proc, $err)= new_and_catch({ cwd => 'path_that_does_not_exist' }, $^X, '-v' );
+ok( $proc, undef ); # 4
+$proc->wait if defined $proc;
+ok( $err, undef ); # 5
+
+($proc, $err)= new_and_catch({ autodie => 1, cwd => 'path_that_does_not_exist' }, $^X, '-v' );
+ok( $proc, undef ); # 6
+$proc->wait if defined $proc;
+ok( $err ); # 7