diff options
| -rw-r--r-- | Changes | 248 | ||||
| -rw-r--r-- | MANIFEST | 10 | ||||
| -rw-r--r-- | Makefile.PL | 63 | ||||
| -rw-r--r-- | README | 101 | ||||
| -rw-r--r-- | bin/timed-process.PL | 81 | ||||
| -rw-r--r-- | lib/Proc/Background.pm | 477 | ||||
| -rw-r--r-- | lib/Proc/Background/Unix.pm | 138 | ||||
| -rw-r--r-- | lib/Proc/Background/Win32.pm | 157 | ||||
| -rw-r--r-- | t/01proc.t | 213 | ||||
| -rw-r--r-- | t/sleep_exit.pl | 19 |
10 files changed, 1507 insertions, 0 deletions
@@ -0,0 +1,248 @@ +Sat Dec 7 09:41:58 PST 2002 + + * Release version 1.08. + +Sat Dec 7 09:33:53 PST 2002 <blair@orcaware.com> Blair Zajac + + * lib/Proc/Background/Win32.pm (_new): When more than one + argument is passed to _new in @_, each array element may be + quoted to protect whitespace so that the final assembly of + the individual arguments into one string, using "@_", that + is passed to Win32::Process::Create works. An empty string + was not being protected and was lost from the command line + arguments. Bug fix by Jim Hahn <jrh3@att.com>. + * README: Note that this package is hosted in a Subversion + repository and give its URL. + * Changes: Renamed from CHANGES. + +Sat Apr 20 19:27:53 PDT 2002 <blair@orcaware.com> Blair Zajac + + * Release version 1.07. + +Sat Apr 20 18:55:46 PDT 2002 <blair@orcaware.com> Blair Zajac + + * lib/Proc/Background/Win32.pm: Fix a bug spotted by John + Kingsley <johnk@magma.ca> on Windows platforms where if + Proc::Background->new is passed an absolute pathname to a + program containing whitespace, then Win32::Process::Create + will not be able to create the new process. The solution is + use Win32::GetShortPathName to convert the long pathname + into a short pathname with no spaces. Also eval "use + Win32' to load Win32::GetShortPathName. + +Sat Apr 20 18:35:57 PDT 2002 <blair@orcaware.com> Blair Zajac + + * lib/Proc/Background.pm: Fix a bug spotted by Ruben Diez + <rdiez@activenav.com> in _resolve_path where if one of the + directories in the PATH had a directory with the same name + as the program being searched for, the directory would be + used because they typically have execute permissions. Now + check for a file and the execute permissions before using + the file. + +Sat Apr 20 18:19:27 PDT 2002 <blair@orcaware.com> Blair Zajac + + * lib/Proc/Background.pm: Fix all cases where a string + containing '0' would fail a test even though it should pass. + * lib/Proc/Background/Unix.pm: Ditto. + * lib/Proc/Background/Win32.pm: Ditto. + +Sat Sep 8 12:20:01 PDT 2001 <blair@orcaware.com> Blair Zajac + + * Release version 1.06. + +Sat Sep 8 12:19:39 PDT 2001 <blair@orcaware.com> Blair Zajac + + * t/01proc.t: On Cygwin test 46 fails intermittently when it + tries to see if the spawned process is running by using + kill(0, $pid). It's not clear why this would happen, but + sometimes kill returns 0, even though the process should be + running. Maybe it's the Cygwin layer that is causing the + problem. Adding a one second sleep before calling kill + seems to cause the test to pass. + * t/sleep_exit.t: The sleep argument was being set to 1 even + if the command line argument was 0 because $sleep was + checked for trueness, not if it was defined. Now check + $sleep and $exit_status for being defined before setting + them. + * README: Update the instructions for checking and installing + Win32::Process for Perl on Windows. + +Tue Aug 28 12:54:44 PDT 2001 <blair@orcaware.com> Blair Zajac + + * Release version 1.05. + +Tue Aug 28 12:34:15 PDT 2001 <blair@orcaware.com> Blair Zajac + + * lib/Proc/Background.pm: The $VERSION variable was being set + using + + $VERSION = substr q$Revision: 1.05 $, 10;' + + which did not properly set $VERSION to a numeric value in + Perl 5.6.1 probably due to the trailing ' ' character after + the number. This resulted in 'use Proc::Background + 1.04' failing to force Perl to use version 1.04 or newer of + Proc::Background even if 1.03 or older was installed because + $VERSION was set using substr and Perl would not consider + $VERSION to be set. Now use the longer but effective: + + $VERSION = sprintf '%d.%02d', '$Revision: 1.05 $' =~ /(\d+)\.(\d+)/; + + * lib/Proc/Background/Unix.pm: Ditto. + * lib/Proc/Background/Win32.pm: Ditto. + +Thu Aug 16 14:36:39 PDT 2001 <blair@orcaware.com> Blair Zajac + + * Release version 1.04. + +Thu Aug 16 14:29:14 PDT 2001 <blair@orcaware.com> Blair Zajac + + * lib/Proc/Background.pm: When new is passed an incorrect + number of arguments, do confess using the class passed to + new, rather use the hardwired Proc::Background class which + will make error messages easier to understand since module + complaining about the error will be the correct one. + * lib/Proc/Background/Unix.pm: Ditto, except for _new, not + new. + * lib/Proc/Background/Win32.pm: Ditto, except for _new, not + new. + +Thu Aug 16 14:00:41 PDT 2001 <blair@orcaware.com> Blair Zajac + + * lib/Proc/Background.pm: Proc::Background::new can accept a + reference to a hash as its first argument which contains + key/value pairs to modify Proc::Background's behavior. + Currently the only key understood is `die_upon_destroy' + which has the process killed via die() when the + Proc::Background object is being DESTROY'ed. + * t/01proc.t: Add tests to test the new options behavior. + +Thu Aug 16 13:30:23 PDT 2001 <blair@orcaware.com> Blair Zajac + + * lib/Proc/Background.pm: No longer use cluck and return undef + to warn about invalid arguments to function calls. Instead + just call confess to print the call stack and quit the + script. + * lib/Proc/Background/Unix.pm: Ditto. + * lib/Proc/Background/Win32.pm: Ditto. + +Tue Aug 14 22:50:14 PDT 2001 <blair@orcaware.com> Blair Zajac + + * lib/Proc/Background/Win32.pm: Remove an unnecessary loop + label in _die. + * lib/Proc/Background.pm: Update the documentation to be + clearer. + * README: Remove the reference to my FTP site, as it is no + longer being used. + * README: Update all references to Blair Zajac's email + addresses to blair@orcaware.com. + * CHANGES: Ditto. + * lib/Proc/Background/Unix.pm: Ditto. + * lib/Proc/Background/Win32.pm: Ditto. + * lib/Proc/Background.pm: Ditto. + +Sun Feb 4 13:54:37 PST 2001 <blair@orcaware.com> Blair Zajac + + * Release version 1.03. + +Sun Feb 4 11:50:15 PST 2001 <blair@orcaware.com> Blair Zajac + + * Add a new command line option to timed-process, -e, that + takes an integer argument. This value sets the exit value + timed-process uses for its exit call when it has to kill the + given program because the timeout elapsed. This value is + not used if the process exits before the timeout expires. + * t/01proc.t: Add tests for for the timed-process script. + +Sat Feb 3 14:21:32 PST 2001 <blair@orcaware.com> Blair Zajac + + * Change all occurrences of Proc::Generic, which was the + original name of this module, with Proc::Background in every + file in the module. This includes fixing the timed-process + script which used Proc::Generic instead of Proc::Background. + +Mon Jan 15 16:05:04 PST 2001 <blair@orcaware.com> Blair Zajac + + * Release version 1.02. + +Mon Jan 15 10:32:59 PST 2001 <blair@orcaware.com> Blair Zajac + + * Make Proc::Background::new flexible enough to behave in the + same manner as exec() or system() do when passed either a + single or multiple arguments. When the command to put in + the background run is passed as an array with two or more + elements, run the command directly without passing the + command through the shell. When a single argument is passed + to Proc::Background::new, pass the command through the + shell. Add a new test to the test suite to check a command + passed as a single argument to Proc::Background::new. + * Remove 'Unrecognized escape \w passed through at + Background.pm line 30' warning when using Perl 5.6.0. + +Wed Jun 21 09:51:37 PDT 2000 <blair@orcaware.com> Blair Zajac + + * Release version 1.01. + +Wed Jun 21 09:47:33 PDT 2000 <blair@orcaware.com> Blair Zajac + + * Proc::Background::Win32 used to only protect arguments that + contained he space character by placing "'s around the + argument. Now, make sure that each individual argument to + Proc::Backgrond ends up going to the Windows shell in such a + way that the shell sees the argument as a single + argument. This means escaping "'s that are not already + escaped and placing "'s around the argument if it matches + \s. This will protect the string if it finds a \s in it and + not just a space. + +Thu Apr 20 14:46:31 PDT 2000 <blair@orcaware.com> Blair Zajac + + * Release version 1.00. + +Thu Apr 20 14:40:11 PDT 2000 <blair@orcaware.com> Blair Zajac + + * In certain circumstances on older Perls, Proc::Background + would complain that @_ could not be modified since it is a + read only variable. Make a copy of @_ and modify that. + +Wed Apr 19 19:50:51 PDT 2000 <blair@orcaware.com> Blair Zajac + + * Release version 0.03. + +Wed Apr 19 14:47:58 PDT 2000 <blair@orcaware.com> Blair Zajac + + * Relax the requirement that the path to the program has to be + absolute. If it is not absolute, then look for the absolute + location of the program. + + * Add a new method named pid that returns the process ID of + the new process. + +Sun Jun 28 12:43:39 PDT 1998 <blair@orcaware.com> Blair Zajac + + * Release version 0.02. + +Tue Jun 23 15:13:13 PDT 1998 <blair@orcaware.com> Blair Zajac + + * Restructure the die method. Keep the OS independent code + for killing a process in Proc::Background and the OS + dependent killing code in Proc::Background::*. + * Update the POD for Proc::Background to be more explicit + about what start_time and end_time return. + * Fix bugs in Proc::Background::Win32. + * Update Makefile.PL to check for Win32::Process installed on + Win32 systems. + +Thu Jun 18 14:52:01 PDT 1998 <blair@orcaware.com> Blair Zajac + + * Update the README to indicate that libwin32 is only needed + on Win32 systems. + * Remove calls to croak or die. Call cluck instead. + * Fix the implementation documentation. + * Remove Proc::Background::Win32::alive since + Proc::Background::alive works. + +Thu Apr 24 12:00:00 PDT 1998 <blair@orcaware.com> Blair Zajac + + * Version 0.01 diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..a61ca76 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,10 @@ +Changes +MANIFEST +README +Makefile.PL +lib/Proc/Background.pm +lib/Proc/Background/Unix.pm +lib/Proc/Background/Win32.pm +bin/timed-process.PL +t/01proc.t +t/sleep_exit.pl diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..1353a45 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,63 @@ +# This -*- perl -*- script writes the Makefile for this package. + +require 5.004_04; +use strict; + +# Subroutine to check for installed modules. +sub check_version +{ + my ($pkg, $wanted, $msg) = @_; + + local($|) = 1; + print "Checking for $pkg..."; + + eval { my $p; ($p = $pkg . ".pm") =~ s#::#/#g; require $p; }; + + no strict 'refs'; + + my $vstr = ${"${pkg}::VERSION"} ? "found v" . ${"${pkg}::VERSION"} + : "not found"; + my $vnum = ${"${pkg}::VERSION"} || 0; + + print $vnum >= $wanted ? "ok\n" : " " . $vstr . "\n"; + + $vnum >= $wanted; +} + +# Check for needed modules. +if ($^O eq 'MSWin32') { + check_version('Win32::Process' => '0.04') or + die "\n" + . "*** For Proc:Background you require version 0.04, or later, of\n" + . " Win32::Process from CPAN/authors/id/GSAR/libwin32-x.x.tar.gz\n\n"; +} + +#--- Configuration section --- + +my @programs_to_install = qw(timed-process); + +#--- End Configuration - You should not have to change anything below this line + +# Allow us to suppress all program installation with the -n (library only) +# option. This is for those that don't want to mess with the configuration +# section of this file. +use Getopt::Std; +use vars qw($opt_n); +unless (getopts('n')) { + die "Usage: $0 [-n]\n"; +} +@programs_to_install = () if $opt_n; + +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'Proc::Background', + VERSION_FROM => 'lib/Proc/Background.pm', + PL_FILES => { map {("bin/$_.PL" => "bin/$_")} @programs_to_install }, + EXE_FILES => [map {"bin/$_"} @programs_to_install ], + 'clean' => {FILES => '$(EXE_FILES)' }, + 'dist' => { + 'COMPRESS' => 'gzip', + 'SUFFIX' => 'gz' + }, +); @@ -0,0 +1,101 @@ +Package Proc::Background Version 1.08 + +This is the Proc::Background package. It provides a generic interface +to running background processes. Through this interface, users can +run background processes on different operating systems without +concerning themselves about the specifics of doing this. Users of +this package create new Proc::Background objects that provide an +object oriented interface to process management. The following +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. + 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 +background process run for a specified amount of time, and if the +process did not exit, then the process is killed. + +AVAILABILITY + +The latest released version of this package is available from a CPAN +archive near you in + + http://www.perl.com/CPAN/authors/id/B/BZ/BZAJAC/ + +The latest beta version of this package is hosted in a Subversion +repository located at + + http://svn.orcaware.com:8000/repos/trunk/proc_background/ + +Subversion is an open-source source code management system designed to +replace CVS. To get Subversion, see + + http://subversion.tigris.org/ + +and for an overview of Subversion, see + + http://www.orcaware.com/svn/Subversion-Blair_Zajac.ppt + +INSTALLATION + +In order to use this package you will need Perl version 5.004_04 or +better. + +On Win32 systems Proc::Background requires the Win32::Process module. +To check if your Perl has Win32::Process installed on it, run + + perl Makefile.PL + +If this command does not complain about missing Win32::Process, then +you have the module installed. If you receive an error message, you +can do two things to resolve this. If you have not performed +extensive customization and installation of modules into your Perl, +the easier path is to upgrade to the latest version of ActiveState +Perl at + + http://aspn.activestate.com/ASPN/Downloads/ActivePerl/ + +which includes Win32::Process. If you want to use your current Perl +installation, then download the latest version of the libwin32 package +by Gurusamy Sarathy available at: + + http://www.perl.com/CPAN/authors/id/GSAR/ + +Once that is completed, you install Proc::Background as you would +install any perl module library, by running these commands: + + perl Makefile.PL + make + make test + make install + +You can edit the configuration section of Makefile.PL to select which +programs to install in addition to the library itself. If you don't +want to install any programs (only the library files) and don't want +to mess with the Makefile.PL then pass the '-n' option to Makefile.PL: + + perl Makefile.PL -n + +If you want to install a private copy of this package in some other +directory, then you should try to produce the initial Makefile with +something like this command: + + perl Makefile.PL LIB=~/perl + +DOCUMENTATION + +See the CHANGES file for a list of recent changes. POD style +documentation is included in all modules and scripts. These are +normally converted to manual pages end installed as part of the "make +install" process. You should also be able to use the 'perldoc' +utility to extract documentation from the module files directly. + +COPYRIGHT + +Copyright (C) 1998-2002 Blair Zajac. All rights reserved. This +package is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. diff --git a/bin/timed-process.PL b/bin/timed-process.PL new file mode 100644 index 0000000..f6ca4df --- /dev/null +++ b/bin/timed-process.PL @@ -0,0 +1,81 @@ +use Config; +use File::Basename qw(basename dirname); +chdir(dirname($0)); +($file = basename($0)) =~ s/\.PL$//; +$file =~ s/\.pl$// + if ($Config{'osname'} eq 'VMS' or + $Config{'osname'} eq 'OS2'); # "case-forgiving" +open OUT,">$file" or die "Can't create $file: $!"; +chmod(0755, $file); +print "Extracting $file (with variable substitutions)\n"; + +print OUT <<"!GROK!THIS!"; +$Config{'startperl'} -w + +!GROK!THIS! + +print OUT <<'!NO!SUBS!'; +=head1 NAME + +timed-process - Run background process for limited amount of time + +=head1 SYNOPSIS + + timed-process [-e exit_status] timeout command [<arg> [<arg> ...]] + +=head1 DESCRIPTION + +This script runs I<command> for a specified amount of time and if it +doesn't finish, it kills the process. If I<command> runs and exits +before the given timeout, B<timed-process> returns the exit value of +I<command>. If I<command> did not exit before I<timeout> seconds, +then B<timed-process> will kill the process and returns an exit value +of 255, unless the -e command line option is set, which instructs +B<timed-process> to return a different exit value. This allows the +user of B<timed-process> to determine if the process ended normally or +was killed. + +=cut + +use strict; +use Proc::Background 1.04 qw(timeout_system); +use Getopt::Long; + +$0 =~ s:.*/::; + +sub usage { + print <<END; +usage: $0 [-e exit_status] timeout command [<arg> [<arg> ...]] + +This script runs command for a specified amount of time and if it +doesn't finish, it kills the process. If command runs and exits +before the given timeout, timed-process returns the exit value of +command. If command did not exit before timeout seconds, then +timed-process will kill the process and returns an exit value of 255, +unless the -e command line option is set, which instructs +timed-process to return a different exit value. This allows the user +of timed-process to determine if the process ended normally or was +killed. +END + exit 1; +} + +my $exit_status = 255; +Getopt::Long::Configure('require_order'); +GetOptions('exit-status=i', => \$exit_status) or + usage; +if ($exit_status < 0) { + die "$0: exit status value `$exit_status' cannot be negative.\n"; +} + +@ARGV > 1 or usage; + +my @result = timeout_system(@ARGV); + +if ($result[1]) { + exit $exit_status; +} else { + exit $result[0] >> 8; +} + +!NO!SUBS! diff --git a/lib/Proc/Background.pm b/lib/Proc/Background.pm new file mode 100644 index 0000000..75c7d32 --- /dev/null +++ b/lib/Proc/Background.pm @@ -0,0 +1,477 @@ +# Proc::Background: Generic interface to background process management. +# +# Copyright (C) 1998-2002 Blair Zajac. All rights reserved. + +package Proc::Background; + +require 5.004_04; + +use strict; +use Exporter; +use Carp; +use Cwd; + +use vars qw(@ISA $VERSION @EXPORT_OK); +@ISA = qw(Exporter); +@EXPORT_OK = qw(timeout_system); +$VERSION = sprintf '%d.%02d', '$Revision: 1.08 $' =~ /(\d+)\.(\d+)/; + +# Determine if the operating system is Windows. +my $is_windows = $^O eq 'MSWin32'; + +# Set up a regular expression that tests if the path is absolute and +# if it has a directory separator in it. Also create a list of file +# extensions of append to the programs name to look for the real +# executable. +my $is_absolute_re; +my $has_dir_element_re; +my @extensions = (''); +if ($is_windows) { + $is_absolute_re = '^(?:(?:[a-zA-Z]:[\\\\/])|(?:[\\\\/]{2}\w+[\\\\/]))'; + $has_dir_element_re = "[\\\\/]"; + push(@extensions, '.exe'); +} else { + $is_absolute_re = "^/"; + $has_dir_element_re = "/"; +} + +# Make this class a subclass of Proc::Win32 or Proc::Unix. Any +# unresolved method calls will go to either of these classes. +if ($is_windows) { + require Proc::Background::Win32; + unshift(@ISA, 'Proc::Background::Win32'); +} else { + require Proc::Background::Unix; + unshift(@ISA, 'Proc::Background::Unix'); +} + +# Take either a relative or absolute path to a command and make it an +# absolute path. +sub _resolve_path { + my $command = shift; + + return 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 + # separator, then only prepend the current working to it. If the + # path is not absolute, then look through the PATH environment to + # find the executable. In all cases, look for the programs with any + # extensions added to the original path name. + my $path; + if ($command =~ /$is_absolute_re/o) { + foreach my $ext (@extensions) { + my $p = "$command$ext"; + if (-f $p and -x _) { + $path = $p; + last; + } + } + unless (defined $path) { + warn "$0: no executable program located at $command\n"; + } + } else { + my $cwd = cwd; + if ($command =~ /$has_dir_element_re/o) { + my $p1 = "$cwd/$command"; + foreach my $ext (@extensions) { + my $p2 = "$p1$ext"; + if (-f $p2 and -x _) { + $path = $p2; + last; + } + } + } else { + foreach my $dir (split($is_windows ? ';' : ':', $ENV{PATH})) { + next unless length $dir; + $dir = "$cwd/$dir" unless $dir =~ /$is_absolute_re/o; + my $p1 = "$dir/$command"; + foreach my $ext (@extensions) { + my $p2 = "$p1$ext"; + if (-f $p2 and -x _) { + $path = $p2; + last; + } + } + last if defined $path; + } + } + unless (defined $path) { + warn "$0: cannot find absolute location of $command\n"; + } + } + + $path; +} + +# We want the created object to live in Proc::Background instead of +# the OS specific class so that generic method calls can be used. +sub new { + my $class = shift; + + my $options; + if (@_ and defined $_[0] and UNIVERSAL::isa($_[0], 'HASH')) { + $options = shift; + } + + unless (@_ > 0) { + confess "Proc::Background::new called with insufficient number of arguments"; + } + + return unless defined $_[0]; + + my $self = $class->SUPER::_new(@_) or return; + + # Save the start time of the class. + $self->{_start_time} = time; + + # Handle the specific options. + if ($options) { + $self->{_die_upon_destroy} = $options->{die_upon_destroy}; + } + + bless $self, $class; +} + +sub DESTROY { + my $self = shift; + if ($self->{_die_upon_destroy}) { + $self->die; + } +} + +# Reap the child. If the first argument is 0 the wait should return +# immediately, 1 if it should wait forever. If this number is +# non-zero, then wait. If the wait was sucessful, then delete +# $self->{_os_obj} and set $self->{_exit_value} to the OS specific +# class return of _reap. Return 1 if we sucessfully waited, 0 +# otherwise. +sub _reap { + my $self = shift; + my $timeout = shift || 0; + + return 0 unless exists($self->{_os_obj}); + + # Try to wait on the process. Use the OS dependent wait call using + # the Proc::Background::*::waitpid call, which returns one of three + # values. + # (0, exit_value) : sucessfully waited on. + # (1, undef) : process already reaped and exist value lost. + # (2, undef) : process still running. + my ($result, $exit_value) = $self->_waitpid($timeout); + if ($result == 0 or $result == 1) { + $self->{_exit_value} = defined($exit_value) ? $exit_value : 0; + delete $self->{_os_obj}; + # Save the end time of the class. + $self->{_end_time} = time; + return 1; + } + return 0; +} + +sub alive { + my $self = shift; + + # If $self->{_os_obj} is not set, then the process is definitely + # not running. + return 0 unless exists($self->{_os_obj}); + + # If $self->{_exit_value} is set, then the process has already finished. + return 0 if exists($self->{_exit_value}); + + # Try to reap the child. If it doesn't reap, then it's alive. + !$self->_reap(0); +} + +sub wait { + my $self = shift; + + # If neither _os_obj or _exit_value are set, then something is wrong. + if (!exists($self->{_exit_value}) and !exists($self->{_os_obj})) { + return; + } + + # If $self->{_exit_value} exists, then we already waited. + return $self->{_exit_value} if exists($self->{_exit_value}); + + # Otherwise, wait forever for the process to finish. + $self->_reap(1); + return $self->{_exit_value}; +} + +sub die { + my $self = shift; + + # See if the process has already died. + return 1 unless $self->alive; + + # Kill the process using the OS specific method. + $self->_die; + + # See if the process is still alive. + !$self->alive; +} + +sub start_time { + $_[0]->{_start_time}; +} + +sub end_time { + $_[0]->{_end_time}; +} + +sub pid { + $_[0]->{_pid}; +} + +sub timeout_system { + unless (@_ > 1) { + confess "$0: timeout_system passed too few arguments.\n"; + } + + my $timeout = shift; + unless ($timeout =~ /^\d+(?:\.\d*)?$/ or $timeout =~ /^\.\d+$/) { + confess "$0: timeout_system passed a non-positive number first argument.\n"; + } + + my $proc = Proc::Background->new(@_) or return; + my $end_time = $proc->start_time + $timeout; + while ($proc->alive and time < $end_time) { + sleep(1); + } + + my $alive = $proc->alive; + if ($alive) { + $proc->die; + } + + if (wantarray) { + return ($proc->wait, $alive); + } else { + return $proc->wait; + } +} + +1; + +__END__ + +=pod + +=head1 NAME + +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; + $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 + # DETROYed. + my $opts = {'die_upon_destroy' => 1}; + my $proc3 = Proc::Background->new($opts, $command, $arg1, $arg2); + $proc3 = undef; + +=head1 DESCRIPTION + +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 METHODS + +=over 4 + +=item B<new> [options] I<command>, [I<arg>, [I<arg>, ...]] + +=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. + +=item B<pid> + +Returns the process ID of the created process. This value is saved +even if the process has already finished. + +=item B<alive> + +Return 1 if the process is still active, 0 otherwise. + +=item B<die> + +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. On Unix, the following signals are +sent to the process in one second intervals until the process dies: +HUP, QUIT, INT, KILL. + +=item B<wait> + +Wait for the process to exit. Return the exit status of the command +as returned by wait() on the system. To get the actual exit value, +divide by 256 or right bit shift by 8, regardless of the operating +system being used. If the process never existed, then return an empty +list in a list context, an undefined value in a scalar context, or +nothing in a void context. This function may be called multiple times +even after the process has exited and it will return the same exit +status. + +=item B<start_time> + +Return the value that the Perl function time() returned when the +process was started. + +=item B<end_time> + +Return the value that the Perl function time() returned when the exit +status was obtained from the process. + +=back + +=head1 FUNCTIONS + +=over 4 + +=item B<timeout_system> I<timeout>, I<command>, [I<arg>, [I<arg>...]] + +=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. + +In a scalar context, B<timeout_system> returns the exit status from +the process. In an array context, B<timeout_system> returns a two +element array, where the first element is the exist status from the +process and the second is set to 1 if the process was killed by +B<timeout_system> or 0 if the process exited by itself. + +The exit status is the value returned from the wait() call. If the +process was killed, then the return value will include the killing of +it. To get the actual exit value, divide by 256. + +If something failed in the creation of the process, the subroutine +returns an empty list in a list context, an undefined value in a +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 + +See also L<Proc::Background::Unix> and L<Proc::Background::Win32>. + +=head1 AUTHOR + +Blair Zajac <blair@orcaware.com> + +=head1 COPYRIGHT + +Copyright (C) 1998-2002 Blair Zajac. All rights reserved. This +package is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/lib/Proc/Background/Unix.pm b/lib/Proc/Background/Unix.pm new file mode 100644 index 0000000..a0f8567 --- /dev/null +++ b/lib/Proc/Background/Unix.pm @@ -0,0 +1,138 @@ +# Proc::Background::Unix: Unix interface to background process management. +# +# Copyright (C) 1998-2002 Blair Zajac. All rights reserved. + +package Proc::Background::Unix; + +require 5.004_04; + +use strict; +use Exporter; +use Carp; +use POSIX qw(:errno_h :sys_wait_h); + +use vars qw(@ISA $VERSION); +@ISA = qw(Exporter); +$VERSION = sprintf '%d.%02d', '$Revision: 1.08 $' =~ /(\d+)\.(\d+)/; + +# 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"; + } + + 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; + } + + my $self = bless {}, $class; + + # Fork a child process. + my $pid; + { + if ($pid = fork()) { + # parent + $self->{_os_obj} = $pid; + $self->{_pid} = $pid; + last; + } elsif (defined $pid) { + # child + exec @_ or croak "$0: exec failed: $!\n"; + } elsif ($! == EAGAIN) { + sleep 5; + redo; + } else { + return; + } + } + + $self; +} + +# Wait for the child. +sub _waitpid { + my $self = shift; + my $timeout = shift; + + { + # Try to wait on the process. + my $result = waitpid($self->{_os_obj}, $timeout ? 0 : WNOHANG); + # Process finished. Grab the exit value. + if ($result == $self->{_os_obj}) { + return (0, $?); + } + # Process already reaped. We don't know the exist status. + elsif ($result == -1 and $! == ECHILD) { + return (1, 0); + } + # Process still running. + elsif ($result == 0) { + return (2, 0); + } + # If we reach here, then waitpid caught a signal, so let's retry it. + redo; + } + return 0; +} + +sub _die { + my $self = shift; + + # Try to kill the process with different signals. Calling alive() will + # collect the exit status of the program. + SIGNAL: { + foreach my $signal (qw(HUP QUIT INT KILL)) { + my $count = 5; + while ($count and $self->alive) { + --$count; + kill($signal, $self->{_os_obj}); + last SIGNAL unless $self->alive; + sleep 1; + } + } + } +} + +1; + +__END__ + +=head1 NAME + +Proc::Background::Unix - Unix interface to process mangement + +=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. + +=head1 AUTHOR + +Blair Zajac <blair@orcaware.com> + +=head1 COPYRIGHT + +Copyright (C) 1998-2002 Blair Zajac. All rights reserved. This +package is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/lib/Proc/Background/Win32.pm b/lib/Proc/Background/Win32.pm new file mode 100644 index 0000000..d972f1a --- /dev/null +++ b/lib/Proc/Background/Win32.pm @@ -0,0 +1,157 @@ +# Proc::Background::Win32 Windows interface to background process management. +# +# Copyright (C) 1998-2002 Blair Zajac. All rights reserved. + +package Proc::Background::Win32; + +require 5.004_04; + +use strict; +use Exporter; +use Carp; + +use vars qw(@ISA $VERSION); +@ISA = qw(Exporter); +$VERSION = sprintf '%d.%02d', '$Revision: 1.08 $' =~ /(\d+)\.(\d+)/; + +BEGIN { + eval "use Win32"; + $@ and die "Proc::Background::Win32 needs Win32 from libwin32-?.??.zip to run.\n"; + eval "use Win32::Process"; + $@ and die "Proc::Background::Win32 needs Win32::Process from libwin32-?.??.zip to run.\n"; +} + +sub _new { + my $class = shift; + + unless (@_ > 0) { + confess "Proc::Background::Win32::_new called with insufficient number of arguments"; + } + + return unless defined $_[0]; + + # If there is only one element in the @_ array, then just split the + # argument by whitespace. If there is more than one element in @_, + # then assume that each argument should be properly protected from + # the shell so that whitespace and special characters are passed + # properly to the program, just as it would be in a Unix + # environment. This will ensure that a single argument with + # whitespace will not be split into multiple arguments by the time + # the program is run. Make sure that any arguments that are already + # protected stay protected. Then convert unquoted "'s into \"'s. + # Finally, check for whitespace and protect it. + my @args; + if (@_ == 1) { + @args = split(' ', $_[0]); + } else { + @args = @_; + for (my $i=1; $i<@args; ++$i) { + my $arg = $args[$i]; + $arg =~ s#\\\\#\200#g; + $arg =~ s#\\"#\201#g; + $arg =~ s#"#\\"#g; + $arg =~ s#\200#\\\\#g; + $arg =~ s#\201#\\"#g; + if (length($arg) == 0 or $arg =~ /\s/) { + $arg = "\"$arg\""; + } + $args[$i] = $arg; + } + } + + # Find the absolute path to the program. If it cannot be found, + # then return. To work around a problem where + # 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. + $args[0] = Proc::Background::_resolve_path($args[0]) or return; + $args[0] = Win32::GetShortPathName($args[0]); + + 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, + $args[0], + "@args", + 0, + NORMAL_PRIORITY_CLASS, + '.')) { + $self->{_pid} = $os_obj->GetProcessID; + $self->{_os_obj} = $os_obj; + return $self; + } else { + return; + } +} + +# Reap the child. +sub _waitpid { + my ($self, $timeout) = @_; + + # Try to wait on the process. + my $result = $self->{_os_obj}->Wait($timeout ? INFINITE : 0); + # Process finished. Grab the exit value. + if ($result == 1) { + my $_exit_status; + $self->{_os_obj}->GetExitCode($_exit_status); + return (0, $_exit_status<<8); + } + # Process still running. + elsif ($result == 0) { + return (2, 0); + } + # If we reach here, then something odd happened. + return (0, 1<<8); +} + +sub _die { + my $self = shift; + + # Try the kill the process several times. Calling alive() will + # collect the exit status of the program. + my $count = 5; + while ($count and $self->alive) { + --$count; + $self->{_os_obj}->Kill(1<<8); + last unless $self->alive; + sleep 1; + } +} + +1; + +__END__ + +=head1 NAME + +Proc::Background::Win32 - Interface to process mangement on Win32 systems + +=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. + +=head1 IMPLEMENTATION + +This package uses the Win32::Process class to manage the objects. + +=head1 AUTHOR + +Blair Zajac <blair@orcaware.com + +=head1 COPYRIGHT + +Copyright (C) 1998-2002 Blair Zajac. All rights reserved. This +package is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/t/01proc.t b/t/01proc.t new file mode 100644 index 0000000..2baf515 --- /dev/null +++ b/t/01proc.t @@ -0,0 +1,213 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +use strict; +use vars qw($loaded); + +BEGIN { $| = 1; print "1..47\n"; } +END {print "not ok 1\n" unless $loaded; } + +my $ok_count = 1; +sub ok { + shift or print "not "; + print "ok $ok_count\n"; + ++$ok_count; +} + +use Proc::Background qw(timeout_system); + +package EmptySubclass; +use Proc::Background; +use vars qw(@ISA); +@ISA = qw(Proc::Background); + +package main; + +# If we got here, then the package being tested was loaded. +$loaded = 1; +ok(1); # 1 + +# Find the lib directory. +my $lib; +foreach my $l (qw(lib ../lib)) { + if (-d $l) { + $lib = $l; + last; + } +} +$lib or die "Cannot find lib directory.\n"; + +# Find the sleep_exit.pl and timed-process scripts. The sleep_exit.pl +# script takes a sleep time and an exit value. timed-process takes a +# sleep time and a command to run. +my $sleep_exit; +my $timed_process; +foreach my $dir (qw(. ./bin ./t ../bin ../t Proc-Background/t)) { + unless ($sleep_exit) { + my $s = "$dir/sleep_exit.pl"; + $sleep_exit = $s if -r $s; + } + unless ($timed_process) { + my $t = "$dir/timed-process"; + $timed_process = $t if -r $t; + } +} +$sleep_exit or die "Cannot find sleep_exit.pl.\n"; +$timed_process or die "Cannot find timed-process.\n"; +my @sleep_exit = ($^X, '-w', $sleep_exit); +my @timed_process = ($^X, '-w', "-I$lib", $timed_process); + +# Test the alive and wait returns. +my $p1 = EmptySubclass->new(@sleep_exit, 2, 26); +ok($p1); # 2 +if ($p1) { + ok($p1->alive); # 3 + sleep 3; + ok(!$p1->alive); # 4 + ok(($p1->wait >> 8) == 26); # 5 +} else { + ok(0); # 3 + ok(0); # 4 + ok(0); # 5 +} + +# Test alive, wait, and die on already dead process. Also pass some +# bogus command line options to the program to make sure that the +# argument protecting code for Windows does not cause the shell any +# confusion. +my $p2 = EmptySubclass->new(@sleep_exit, + 2, + 5, + "\t", + '"', + '\" 10 \\" \\\\"'); +ok($p2); # 6 +if ($p2) { + ok($p2->alive); # 7 + ok(($p2->wait >> 8) == 5); # 8 + ok($p2->die); # 9 + ok(($p2->wait >> 8) == 5); # 10 +} else { + ok(0); # 7 + ok(0); # 8 + ok(0); # 9 + ok(0); # 10 +} + +# Test die on a live process and collect the exit value. The exit +# value should not be 0. +my $p3 = EmptySubclass->new(@sleep_exit, 10, 0); +ok($p3); # 11 +if ($p3) { + ok($p3->alive); # 12 + sleep 1; + ok($p3->die); # 13 + ok(!$p3->alive); # 14 + ok($p3->wait); # 15 + ok($p3->end_time > $p3->start_time); # 16 +} else { + ok(0); # 12 + ok(0); # 13 + ok(0); # 14 + ok(0); # 15 + ok(0); # 16 +} + +# Test the timeout_system function. In the first case, sleep_exit.pl +# should exit with 26 before the timeout, and in the other case, it +# should be killed and exit with a non-zero status. Do not check the +# wait return value when the process is killed, since the return value +# is different on Unix and Win32 platforms. +my $a = timeout_system(2, @sleep_exit, 0, 26); +my @a = timeout_system(2, @sleep_exit, 0, 26); +ok($a>>8 == 26); # 17 +ok(@a == 2); # 18 +ok($a[0]>>8 == 26); # 19 +ok($a[1] == 0); # 20 +$a = timeout_system(1, @sleep_exit, 4, 0); +@a = timeout_system(1, @sleep_exit, 4, 0); +ok($a); # 21 +ok(@a == 2); # 22 +ok($a[0]); # 23 +ok($a[1] == 1); # 24 + +# Test the code to find a program if the path to it is not absolute. +my $p4 = EmptySubclass->new(@sleep_exit, 0, 0); +ok($p4); # 25 +if ($p4) { + ok($p4->pid); # 26 + sleep 2; + ok(!$p4->alive); # 27 + ok(($p4->wait >> 8) == 0); # 28 +} else { + ok(0); # 26 + ok(0); # 27 + ok(0); # 28 +} + +# Test a command line entered as a single string. +my $p5 = EmptySubclass->new("@sleep_exit 2 26"); +ok($p5); # 29 +if ($p5) { + ok($p5->alive); # 30 + sleep 3; + ok(!$p5->alive); # 31 + ok(($p5->wait >> 8) == 26); # 32 +} else { + ok(0); # 30 + ok(0); # 31 + ok(0); # 32 +} + +sub System { + my $result = system(@_); + return ($? >> 8, $? & 127, $? & 128); +} + +# Test the timed-process script. First test a normal exit. +my @t_args = ($^X, '-w', "-I$lib", $timed_process); +my @result = System(@t_args, '-e', 153, 3, "@sleep_exit 0 237"); +ok($result[0] == 237); # 33 +ok($result[1] == 0); # 34 +ok($result[2] == 0); # 35 + +@result = System(@t_args, 1, "@sleep_exit 10 27"); +ok($result[0] == 255); # 36 +ok($result[1] == 0); # 37 +ok($result[2] == 0); # 38 + +@result = System(@t_args, '-e', 153, 1, "@sleep_exit 10 27"); +ok($result[0] == 153); # 39 +ok($result[1] == 0); # 40 +ok($result[2] == 0); # 41 + +# Test the ability to pass options to Proc::Background::new. +my %options; +my $p6 = EmptySubclass->new(\%options, @sleep_exit, 0, 43); +ok($p6); # 42 +if ($p6) { + ok(($p6->wait >> 8) == 43); # 43 +} else { + ok(0); # 43 +} + +# Test to make sure that the process is killed when the +# Proc::Background object goes out of scope. +$options{die_upon_destroy} = 1; +{ + my $p7 = EmptySubclass->new(\%options, @sleep_exit, 99999, 98); + ok($p7); # 44 + if ($p7) { + my $pid = $p7->pid; + ok(defined $pid); # 45 + sleep 1; + ok(kill(0, $pid) == 1); # 46 + $p7 = undef; + sleep 1; + ok(kill(0, $pid) == 0); # 47 + } else { + ok(0); # 45 + ok(0); # 46 + ok(0); # 47 + } +} diff --git a/t/sleep_exit.pl b/t/sleep_exit.pl new file mode 100644 index 0000000..1e06536 --- /dev/null +++ b/t/sleep_exit.pl @@ -0,0 +1,19 @@ +use strict; + +$| = 1; + +my ($sleep, $exit_status) = @ARGV; +$sleep = 1 unless defined $sleep; +$exit_status = 0 unless defined $exit_status; + +if ($ENV{VERBOSE}) { + print STDERR "$0: sleep $sleep and exit $exit_status.\n"; +} + +sleep $sleep; + +if ($ENV{VERBOSE}) { + print STDERR "$0 now exiting.\n"; +} + +exit $exit_status; |