r2428 - in packages: . libproc-background-perl
libproc-background-perl/branches
libproc-background-perl/branches/upstream
libproc-background-perl/branches/upstream/current
libproc-background-perl/branches/upstream/current/bin
libproc-background-perl/branches/upstream/current/lib
libproc-background-perl/branches/upstream/current/lib/Proc
libproc-background-perl/branches/upstream/current/lib/Proc/Background
libproc-background-perl/branches/upstream/current/t
Niko Tyni
ntyni-guest at costa.debian.org
Fri Mar 17 22:52:43 UTC 2006
Author: ntyni-guest
Date: 2006-03-17 22:52:05 +0000 (Fri, 17 Mar 2006)
New Revision: 2428
Added:
packages/libproc-background-perl/
packages/libproc-background-perl/branches/
packages/libproc-background-perl/branches/upstream/
packages/libproc-background-perl/branches/upstream/current/
packages/libproc-background-perl/branches/upstream/current/Changes
packages/libproc-background-perl/branches/upstream/current/MANIFEST
packages/libproc-background-perl/branches/upstream/current/Makefile.PL
packages/libproc-background-perl/branches/upstream/current/README
packages/libproc-background-perl/branches/upstream/current/bin/
packages/libproc-background-perl/branches/upstream/current/bin/timed-process.PL
packages/libproc-background-perl/branches/upstream/current/lib/
packages/libproc-background-perl/branches/upstream/current/lib/Proc/
packages/libproc-background-perl/branches/upstream/current/lib/Proc/Background.pm
packages/libproc-background-perl/branches/upstream/current/lib/Proc/Background/
packages/libproc-background-perl/branches/upstream/current/lib/Proc/Background/Unix.pm
packages/libproc-background-perl/branches/upstream/current/lib/Proc/Background/Win32.pm
packages/libproc-background-perl/branches/upstream/current/t/
packages/libproc-background-perl/branches/upstream/current/t/01proc.t
packages/libproc-background-perl/branches/upstream/current/t/sleep_exit.pl
packages/libproc-background-perl/tags/
Log:
[svn-inject] Installing original source of libproc-background-perl
Added: packages/libproc-background-perl/branches/upstream/current/Changes
===================================================================
--- packages/libproc-background-perl/branches/upstream/current/Changes 2006-03-17 22:47:49 UTC (rev 2427)
+++ packages/libproc-background-perl/branches/upstream/current/Changes 2006-03-17 22:52:05 UTC (rev 2428)
@@ -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 at 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 at 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 at orcaware.com> Blair Zajac
+
+ * Release version 1.07.
+
+Sat Apr 20 18:55:46 PDT 2002 <blair at orcaware.com> Blair Zajac
+
+ * lib/Proc/Background/Win32.pm: Fix a bug spotted by John
+ Kingsley <johnk at 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 at orcaware.com> Blair Zajac
+
+ * lib/Proc/Background.pm: Fix a bug spotted by Ruben Diez
+ <rdiez at 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 at 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 at orcaware.com> Blair Zajac
+
+ * Release version 1.06.
+
+Sat Sep 8 12:19:39 PDT 2001 <blair at 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 at orcaware.com> Blair Zajac
+
+ * Release version 1.05.
+
+Tue Aug 28 12:34:15 PDT 2001 <blair at 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 at orcaware.com> Blair Zajac
+
+ * Release version 1.04.
+
+Thu Aug 16 14:29:14 PDT 2001 <blair at 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 at 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 at 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 at 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 at 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 at orcaware.com> Blair Zajac
+
+ * Release version 1.03.
+
+Sun Feb 4 11:50:15 PST 2001 <blair at 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 at 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 at orcaware.com> Blair Zajac
+
+ * Release version 1.02.
+
+Mon Jan 15 10:32:59 PST 2001 <blair at 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 at orcaware.com> Blair Zajac
+
+ * Release version 1.01.
+
+Wed Jun 21 09:47:33 PDT 2000 <blair at 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 at orcaware.com> Blair Zajac
+
+ * Release version 1.00.
+
+Thu Apr 20 14:40:11 PDT 2000 <blair at 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 at orcaware.com> Blair Zajac
+
+ * Release version 0.03.
+
+Wed Apr 19 14:47:58 PDT 2000 <blair at 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 at orcaware.com> Blair Zajac
+
+ * Release version 0.02.
+
+Tue Jun 23 15:13:13 PDT 1998 <blair at 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 at 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 at orcaware.com> Blair Zajac
+
+ * Version 0.01
Added: packages/libproc-background-perl/branches/upstream/current/MANIFEST
===================================================================
--- packages/libproc-background-perl/branches/upstream/current/MANIFEST 2006-03-17 22:47:49 UTC (rev 2427)
+++ packages/libproc-background-perl/branches/upstream/current/MANIFEST 2006-03-17 22:52:05 UTC (rev 2428)
@@ -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
Added: packages/libproc-background-perl/branches/upstream/current/Makefile.PL
===================================================================
--- packages/libproc-background-perl/branches/upstream/current/Makefile.PL 2006-03-17 22:47:49 UTC (rev 2427)
+++ packages/libproc-background-perl/branches/upstream/current/Makefile.PL 2006-03-17 22:52:05 UTC (rev 2428)
@@ -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";
+}
+ at 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'
+ },
+);
Added: packages/libproc-background-perl/branches/upstream/current/README
===================================================================
--- packages/libproc-background-perl/branches/upstream/current/README 2006-03-17 22:47:49 UTC (rev 2427)
+++ packages/libproc-background-perl/branches/upstream/current/README 2006-03-17 22:52:05 UTC (rev 2428)
@@ -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.
Added: packages/libproc-background-perl/branches/upstream/current/bin/timed-process.PL
===================================================================
--- packages/libproc-background-perl/branches/upstream/current/bin/timed-process.PL 2006-03-17 22:47:49 UTC (rev 2427)
+++ packages/libproc-background-perl/branches/upstream/current/bin/timed-process.PL 2006-03-17 22:52:05 UTC (rev 2428)
@@ -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";
+}
+
+ at ARGV > 1 or usage;
+
+my @result = timeout_system(@ARGV);
+
+if ($result[1]) {
+ exit $exit_status;
+} else {
+ exit $result[0] >> 8;
+}
+
+!NO!SUBS!
Added: packages/libproc-background-perl/branches/upstream/current/lib/Proc/Background/Unix.pm
===================================================================
--- packages/libproc-background-perl/branches/upstream/current/lib/Proc/Background/Unix.pm 2006-03-17 22:47:49 UTC (rev 2427)
+++ packages/libproc-background-perl/branches/upstream/current/lib/Proc/Background/Unix.pm 2006-03-17 22:52:05 UTC (rev 2428)
@@ -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);
+ at 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 at 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
Added: packages/libproc-background-perl/branches/upstream/current/lib/Proc/Background/Win32.pm
===================================================================
--- packages/libproc-background-perl/branches/upstream/current/lib/Proc/Background/Win32.pm 2006-03-17 22:47:49 UTC (rev 2427)
+++ packages/libproc-background-perl/branches/upstream/current/lib/Proc/Background/Win32.pm 2006-03-17 22:52:05 UTC (rev 2428)
@@ -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);
+ at 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 at 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
Added: packages/libproc-background-perl/branches/upstream/current/lib/Proc/Background.pm
===================================================================
--- packages/libproc-background-perl/branches/upstream/current/lib/Proc/Background.pm 2006-03-17 22:47:49 UTC (rev 2427)
+++ packages/libproc-background-perl/branches/upstream/current/lib/Proc/Background.pm 2006-03-17 22:52:05 UTC (rev 2428)
@@ -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);
+ at ISA = qw(Exporter);
+ at 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 at 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
Added: packages/libproc-background-perl/branches/upstream/current/t/01proc.t
===================================================================
--- packages/libproc-background-perl/branches/upstream/current/t/01proc.t 2006-03-17 22:47:49 UTC (rev 2427)
+++ packages/libproc-background-perl/branches/upstream/current/t/01proc.t 2006-03-17 22:52:05 UTC (rev 2428)
@@ -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);
+ at 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);
+ at 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
+
+ at result = System(@t_args, 1, "@sleep_exit 10 27");
+ok($result[0] == 255); # 36
+ok($result[1] == 0); # 37
+ok($result[2] == 0); # 38
+
+ at 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
+ }
+}
Added: packages/libproc-background-perl/branches/upstream/current/t/sleep_exit.pl
===================================================================
--- packages/libproc-background-perl/branches/upstream/current/t/sleep_exit.pl 2006-03-17 22:47:49 UTC (rev 2427)
+++ packages/libproc-background-perl/branches/upstream/current/t/sleep_exit.pl 2006-03-17 22:52:05 UTC (rev 2428)
@@ -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;
More information about the Pkg-perl-cvs-commits
mailing list