Proc-Simple-1.31/000075500000000000000000000000001205447104500135705ustar00rootroot00000000000000Proc-Simple-1.31/.licensizer.yml000064400000000000000000000005621205447104500165430ustar00rootroot00000000000000# .licensizer.yml author: text: | 1996, Mike Schilli header: AUTHORS mode: verbatim license: text: | Copyright 1996-2011 by Mike Schilli, all rights reserved. This program is free software, you can redistribute it and/or modify it under the same terms as Perl itself. header: LEGALESE path_exclude: - t/ - blib/ Proc-Simple-1.31/Changes000064400000000000000000000113621205447104500150660ustar00rootroot00000000000000###################################################################### Proc::Simple CHANGES ###################################################################### 1.31 (2012/11/17) (ms) To better deal with the race condition in the previous release, kill the newly created child process first, then send a killpg to its process group and ignore the outcome. (ms) [RT 81203] Jim A Kessler reported a perl 5.16 issue with the "AutoLoader" line, so I went ahead and removed all references to "Exporter" and "AutoLoader", as Proc::Simple isn't using them at all. From 1.29: [RT 69782] Zefram reported race condition in t/sh-c.t, fixed by adding polling loop. Found that kill(-sig, pid) sometimes fails with 'process id not found' although a previous kill(0, pid) succeeded. This is a race condition condition caused by a newly forked child that hasn't called setsid() yet and therefore its new process group id doesn't exist yet, although the child responds to poll(). kill() now deals with this case. From 1.28: [RT 69103] Typo fix by Salvatore Bonaccorso Added support for processes called via 'sh -c' by system() (see "Shell Processes" note in the manpage). From 1.27: [RT 62802] Pod fix by Salvatore Bonaccorso [RT 63833] Applied patch to stop reaping PIDs of no longer existing processes (submitted by perlbotics). Added licensizer [RT 63833] (second part) Added cleanup() class method to delete timing data of reaped processes, avoiding infinite memory growth on long-running processes From 1.26: [RT 62285] Pod fix for redirect_output() Fixed github link from 1.25: Localize special variables so that the exit status from waitpid doesn't leak out, causing exit status to be incorrect (RT33440, fixed by Brad Cavanagh). from 1.24: Added copyright header from 1.23: Applied doc patch by Janne Chr. Schulz from 1.22: Applied patch by Jeff Holt, providing start and end time of the forked process via t0() and t1(). from 1.21: Added patch by Chip Capelik to provide a wait() method waiting for a process to terminate. from 1.20: Added patch by Tobias Jahn , to redirect STDOUT or STDERR of the child process upon request. from 1.19: Fixed bug which occurred on failed fork()s, as reported anonymously on the CPAN bug tracker. from 1.18: Added multi-arg start method (proposed by Clauss Strauch ) from 1.17: Fixed Version difference between Makefile.PL and Simple by using VERSION_FROM (thanks Andreas Koenig) from 1.16: Fixed bug with Proc::Simple instances which were DESTROYED before they were ever started. Many thanks to Russell Fulton (r.fulton@auckland.ac.nz) for pointing this out. from 1.15: Added %DESTROYED hash for processes which might still in zombie state right after their objects went out of business. THE_REAPER will take care of them. from 1.14: Added exit_status() method and a smart REAPER which reaps only processes we've started before. from 1.13: Replaced two erronous uses of 'exists' by 'defined'. Thanks to Rolf.Beutner@telekom.de for pointing this out. from 1.12: To fight problems with zombies, replaced the wait() function by a NOWAIT waitpid on systems that support it. Tim Jenness included kill_on_destroy/sig_on_destroy/pid methods. from 1.11: binkley's error: threw out waitpid, wait is performed by signal handler now. from 1.1: Process is now called Proc::Simple to fit in the CPAN namespace, corrections Andreas Koenig suggested. First Release: 05/22/96 Michael Schilli procsimple@perlmeister.com Proc-Simple-1.31/MANIFEST000064400000000000000000000005241205447104500147220ustar00rootroot00000000000000.licensizer.yml Changes eg/parproc.pl Makefile.PL MANIFEST MANIFEST.SKIP META.yml Module meta-data (added by MakeMaker) README Simple.pm t/bin/test-prog t/destroy.t t/esub.t t/exit.t t/muarg.t t/mult.t t/sh-c.t t/simple.t t/stdouterr.t t/time.t t/wait.t META.json Module JSON meta-data (added by MakeMaker) Proc-Simple-1.31/MANIFEST.SKIP000064400000000000000000000001541205447104500154660ustar00rootroot00000000000000.gz .git blib ^Makefile$ ^Makefile.old$ CVS .cvsignore docs MANIFEST.bak adm/release MYMETA.json MYMETA.yml Proc-Simple-1.31/META.json000064400000000000000000000017251205447104500152160ustar00rootroot00000000000000{ "abstract" : "unknown", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.120351", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Proc-Simple", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "IO::Handle" : "0", "Test::More" : "0" } } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "http://github.com/mschilli/proc-simple-perl" } }, "version" : "1.31" } Proc-Simple-1.31/META.yml000064400000000000000000000010151205447104500150360ustar00rootroot00000000000000--- abstract: unknown author: - unknown build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.120351' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Proc-Simple no_index: directory: - t - inc requires: IO::Handle: 0 Test::More: 0 resources: repository: http://github.com/mschilli/proc-simple-perl version: 1.31 Proc-Simple-1.31/Makefile.PL000064400000000000000000000007071205447104500155460ustar00rootroot00000000000000 use ExtUtils::MakeMaker; my $meta_merge = { META_MERGE => { resources => { repository => 'http://github.com/mschilli/proc-simple-perl', }, } }; WriteMakefile( 'VERSION_FROM' => "Simple.pm", 'NAME' => 'Proc::Simple', 'dist' => { COMPRESS=>"gzip", SUFFIX=>"gz" }, PREREQ_PM => { 'Test::More' => 0, 'IO::Handle' => 0, }, $ExtUtils::MakeMaker::VERSION >= 6.50 ? (%$meta_merge) : (), ); Proc-Simple-1.31/README000064400000000000000000000255611205447104500144610ustar00rootroot00000000000000###################################################################### Proc::Simple 1.31 ###################################################################### NAME Proc::Simple -- launch and control background processes SYNOPSIS use Proc::Simple; $myproc = Proc::Simple->new(); # Create a new process object $myproc->start("shell-command-line"); # Launch an external program $myproc->start("command", # Launch an external program "param", ...); # with parameters $myproc->start(sub { ... }); # Launch a perl subroutine $myproc->start(\&subroutine); # Launch a perl subroutine $myproc->start(\&subroutine, # Launch a perl subroutine $param, ...); # with parameters $running = $myproc->poll(); # Poll Running Process $exit_status = $myproc->wait(); # Wait until process is done $proc->kill_on_destroy(1); # Set kill on destroy $proc->signal_on_destroy("KILL"); # Specify signal to be sent # on destroy $myproc->kill(); # Kill Process (SIGTERM) $myproc->kill("SIGUSR1"); # Send specified signal $myproc->exit_status(); # Return exit status of process Proc::Simple::debug($level); # Turn debug on DESCRIPTION The Proc::Simple package provides objects mimicing real-life processes from a user's point of view. A new process object is created by $myproc = Proc::Simple->new(); Either external programs or perl subroutines can be launched and controlled as processes in the background. A 10-second sleep process, for example, can be launched as an external program as in $myproc->start("/bin/sleep 10"); # or $myproc->start("/bin/sleep", "10"); or as a perl subroutine, as in sub mysleep { sleep(shift); } # Define mysleep() $myproc->start(\&mysleep, 10); # Launch it. or even as $myproc->start(sub { sleep(10); }); The *start* Method returns immediately after starting the specified process in background, i.e. there's no blocking. It returns *1* if the process has been launched successfully and *0* if not. The *poll* method checks if the process is still running $running = $myproc->poll(); and returns *1* if it is, *0* if it's not. Finally, $myproc->kill(); terminates the process by sending it the SIGTERM signal. As an option, another signal can be specified. $myproc->kill("SIGUSR1"); sends the SIGUSR1 signal to the running process. *kill* returns *1* if it succeeds in sending the signal, *0* if it doesn't. The methods are discussed in more detail in the next section. A destructor is provided so that a signal can be sent to the forked processes automatically should the process object be destroyed or if the process exits. By default this behaviour is turned off (see the kill_on_destroy and signal_on_destroy methods). METHODS The following methods are available: new (Constructor) Create a new instance of this class by writing $proc = new Proc::Simple; or $proc = Proc::Simple->new(); It takes no arguments. start Launches a new process. The "start()" method can be used to launch both external programs (like "/bin/echo") or one of your self-defined subroutines (like "foo()") in a new process. For an external program to be started, call $status = $proc->start("program-name"); If you want to pass a couple of parameters to the launched program, there's two options: You can either pass them in one argument like in $status = $proc->start("/bin/echo hello world"); or in several arguments like in $status = $proc->start("/bin/echo", "hello", "world"); Just as in Perl's function "system()", there's a big difference between the two methods: If you provide one argument containing a blank-separated command line, your shell is going to process any meta-characters (if you choose to use some) before the process is actually launched: $status = $proc->start("/bin/ls -l /etc/initt*"); will expand "/etc/initt*" to "/etc/inittab" before running the "ls" command. If, on the other hand, you say $status = $proc->start("/bin/ls", "-l", "*"); the "*" will stay unexpanded, meaning you'll look for a file with the literal name "*" (which is unlikely to exist on your system unless you deliberately create confusingly named files :). For more info on this, look up "perldoc -f exec". If, on the other hand, you want to start a Perl subroutine in the background, simply provide the function reference like $status = $proc->start(\&your_function); or supply an unnamed subroutine: $status = $proc->start( sub { sleep(1) } ); You can also provide additional parameters to be passed to the function: $status = $proc->start(\&printme, "hello", "world"); The *start* Method returns immediately after starting the specified process in background, i.e. non-blocking mode. It returns *1* if the process has been launched successfully and *0* if not. poll The *poll* method checks if the process is still running $running = $myproc->poll(); and returns *1* if it is, *0* if it's not. kill The kill() method: $myproc->kill(); terminates the process by sending it the SIGTERM signal. As an option, another signal can be specified. $myproc->kill("SIGUSR1"); sends the SIGUSR1 signal to the running process. *kill* returns *1* if it succeeds in sending the signal, *0* if it doesn't. kill_on_destroy Set a flag to determine whether the process attached to this object should be killed when the object is destroyed. By default, this flag is set to false. The current value is returned. $current = $proc->kill_on_destroy; $proc->kill_on_destroy(1); # Set flag to true $proc->kill_on_destroy(0); # Set flag to false signal_on_destroy Method to set the signal that will be sent to the process when the object is destroyed (Assuming kill_on_destroy is true). Returns the current setting. $current = $proc->signal_on_destroy; $proc->signal_on_destroy("KILL"); redirect_output Redirects stdout and/or stderr output to a file. Specify undef to leave the stderr/stdout handles of the process alone. # stdout to a file, left stderr unchanged $proc->redirect_output ("/tmp/someapp.stdout", undef); # stderr to a file, left stdout unchanged $proc->redirect_output (undef, "/tmp/someapp.stderr"); # stdout and stderr to a separate file $proc->redirect_output ("/tmp/someapp.stdout", "/tmp/someapp.stderr"); Call this method before running the start method. pid Returns the pid of the forked process associated with this object $pid = $proc->pid; t0 Returns the start time() of the forked process associated with this object $t0 = $proc->t0(); t1 Returns the stop time() of the forked process associated with this object $t1 = $proc->t1(); DESTROY (Destructor) Object destructor. This method is called when the object is destroyed (eg with "undef" or on exiting perl). If kill_on_destroy is true the process associated with the object is sent the signal_on_destroy signal (SIGTERM if undefined). exit_status Returns the exit status of the process as the $! variable indicates. If the process is still running, "undef" is returned. wait The *wait* method: $exit_status = $myproc->wait(); waits until the process is done and returns its exit status. debug Switches debug messages on and off -- Proc::Simple::debug(1) switches them on, Proc::Simple::debug(0) keeps Proc::Simple quiet. cleanup Proc::Simple keeps around data of terminated processes, e.g. you can check via "t0()" and "t1()" how long a process ran, even if it's long gone. Over time, this data keeps occupying more and more memory and if you have a long-running program, you might want to run "Proc::Simple->cleanup()" every once in a while to get rid of data pertaining to processes no longer in use. NOTE Please keep in mind that there is no guarantee that the SIGTERM signal really terminates a process. Processes can have signal handlers defined that avoid the shutdown. If in doubt, whether a process still exists, check it repeatedly with the *poll* routine after sending the signal. Shell Processes If you pass a shell program to Proc::Simple, it'll use "exec()" to launch it. As noted in Perl's "exec()" manpage, simple commands for the one-argument version of "exec()" will be passed to "execvp()" directly, while commands containing characters like ";" or "*" will be passed to a shell to make sure those get the shell expansion treatment. This has the interesting side effect that if you launch something like $p->start("./womper *"); then you'll see two processes in your process list: $ ps auxww | grep womper mschilli 9126 11:21 0:00 sh -c ./womper * mschilli 9127 11:21 0:00 /usr/local/bin/perl -w ./womper ... A regular "kill()" on the process PID would only kill the first process, but Proc::Simple's "kill()" will use a negative signal and send it to the first process (9126). Since it has marked the process as a process group leader when it created it previously (via setsid()), this will cause both processes above to receive the signal sent by "kill()". Contributors Tim Jenness did kill_on_destroy/signal_on_destroy/pid Mark R. Southern worked on EXIT_STATUS tracking Tobias Jahn added redirection to stdout/stderr Clauss Strauch suggested the multi-arg start()-methods. Chip Capelik contributed a patch with the wait() method. Jeff Holt provided a patch for time tracking with t0() and t1(). Brad Cavanagh fixed RT33440 (unreliable $?) AUTHOR 1996, Mike Schilli LICENSE Copyright 1996-2011 by Mike Schilli, all rights reserved. This program is free software, you can redistribute it and/or modify it under the same terms as Perl itself. Proc-Simple-1.31/Simple.pm000064400000000000000000000612651205447104500153710ustar00rootroot00000000000000###################################################################### package Proc::Simple; ###################################################################### # Copyright 1996-2001 by Michael Schilli, all rights reserved. # # This program is free software, you can redistribute it and/or # modify it under the same terms as Perl itself. # # The newest version of this module is available on # http://perlmeister.com/devel # or on your favourite CPAN site under # CPAN/modules/by-author/id/MSCHILLI # ###################################################################### =head1 NAME Proc::Simple -- launch and control background processes =head1 SYNOPSIS use Proc::Simple; $myproc = Proc::Simple->new(); # Create a new process object $myproc->start("shell-command-line"); # Launch an external program $myproc->start("command", # Launch an external program "param", ...); # with parameters $myproc->start(sub { ... }); # Launch a perl subroutine $myproc->start(\&subroutine); # Launch a perl subroutine $myproc->start(\&subroutine, # Launch a perl subroutine $param, ...); # with parameters $running = $myproc->poll(); # Poll Running Process $exit_status = $myproc->wait(); # Wait until process is done $proc->kill_on_destroy(1); # Set kill on destroy $proc->signal_on_destroy("KILL"); # Specify signal to be sent # on destroy $myproc->kill(); # Kill Process (SIGTERM) $myproc->kill("SIGUSR1"); # Send specified signal $myproc->exit_status(); # Return exit status of process Proc::Simple::debug($level); # Turn debug on =head1 DESCRIPTION The Proc::Simple package provides objects mimicing real-life processes from a user's point of view. A new process object is created by $myproc = Proc::Simple->new(); Either external programs or perl subroutines can be launched and controlled as processes in the background. A 10-second sleep process, for example, can be launched as an external program as in $myproc->start("/bin/sleep 10"); # or $myproc->start("/bin/sleep", "10"); or as a perl subroutine, as in sub mysleep { sleep(shift); } # Define mysleep() $myproc->start(\&mysleep, 10); # Launch it. or even as $myproc->start(sub { sleep(10); }); The I Method returns immediately after starting the specified process in background, i.e. there's no blocking. It returns I<1> if the process has been launched successfully and I<0> if not. The I method checks if the process is still running $running = $myproc->poll(); and returns I<1> if it is, I<0> if it's not. Finally, $myproc->kill(); terminates the process by sending it the SIGTERM signal. As an option, another signal can be specified. $myproc->kill("SIGUSR1"); sends the SIGUSR1 signal to the running process. I returns I<1> if it succeeds in sending the signal, I<0> if it doesn't. The methods are discussed in more detail in the next section. A destructor is provided so that a signal can be sent to the forked processes automatically should the process object be destroyed or if the process exits. By default this behaviour is turned off (see the kill_on_destroy and signal_on_destroy methods). =cut require 5.003; use strict; use vars qw($VERSION %EXIT_STATUS %INTERVAL %DESTROYED); use POSIX; use IO::Handle; $VERSION = '1.31'; ###################################################################### # Globals: Debug and the mysterious waitpid nohang constant. ###################################################################### my $Debug = 0; my $WNOHANG = get_system_nohang(); ###################################################################### =head1 METHODS The following methods are available: =over 4 =item new (Constructor) Create a new instance of this class by writing $proc = new Proc::Simple; or $proc = Proc::Simple->new(); It takes no arguments. =cut ###################################################################### # $proc_obj=Proc::Simple->new(); - Constructor ###################################################################### sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = {}; # Init instance variables $self->{'kill_on_destroy'} = undef; $self->{'signal_on_destroy'} = undef; $self->{'pid'} = undef; $self->{'redirect_stdout'} = undef; $self->{'redirect_stderr'} = undef; bless($self, $class); } ###################################################################### =item start Launches a new process. The C method can be used to launch both external programs (like C) or one of your self-defined subroutines (like C) in a new process. For an external program to be started, call $status = $proc->start("program-name"); If you want to pass a couple of parameters to the launched program, there's two options: You can either pass them in one argument like in $status = $proc->start("/bin/echo hello world"); or in several arguments like in $status = $proc->start("/bin/echo", "hello", "world"); Just as in Perl's function C, there's a big difference between the two methods: If you provide one argument containing a blank-separated command line, your shell is going to process any meta-characters (if you choose to use some) before the process is actually launched: $status = $proc->start("/bin/ls -l /etc/initt*"); will expand C to C before running the C command. If, on the other hand, you say $status = $proc->start("/bin/ls", "-l", "*"); the C<*> will stay unexpanded, meaning you'll look for a file with the literal name C<*> (which is unlikely to exist on your system unless you deliberately create confusingly named files :). For more info on this, look up C. If, on the other hand, you want to start a Perl subroutine in the background, simply provide the function reference like $status = $proc->start(\&your_function); or supply an unnamed subroutine: $status = $proc->start( sub { sleep(1) } ); You can also provide additional parameters to be passed to the function: $status = $proc->start(\&printme, "hello", "world"); The I Method returns immediately after starting the specified process in background, i.e. non-blocking mode. It returns I<1> if the process has been launched successfully and I<0> if not. =cut ###################################################################### # $ret = $proc_obj->start("prg"); - Launch process ###################################################################### sub start { my $self = shift; my ($func, @params) = @_; # Reap Zombies automatically $SIG{'CHLD'} = \&THE_REAPER; # Fork a child process $self->{'pid'} = fork(); return 0 unless defined $self->{'pid'}; # return Error if fork failed if($self->{pid} == 0) { # Child # Mark it as process group leader, so that we can kill # the process group later. Note that there's a race condition # here because there's a window in time (while you're reading # this comment) between child startup and its new process group # id being defined. This means that killpg() to the child during # this time frame will fail. Proc::Simple's kill() method deals l # with it, see comments there. POSIX::setsid(); $self->dprt("setsid called ($$)"); if (defined $self->{'redirect_stderr'}) { $self->dprt("STDERR -> $self->{'redirect_stderr'}"); open(STDERR, ">$self->{'redirect_stderr'}") ; autoflush STDERR 1 ; } if (defined $self->{'redirect_stdout'}) { $self->dprt("STDOUT -> $self->{'redirect_stdout'}"); open(STDOUT, ">$self->{'redirect_stdout'}") ; autoflush STDOUT 1 ; } if(ref($func) eq "CODE") { $self->dprt("Launching code"); $func->(@params); exit 0; # Start perl subroutine } else { $self->dprt("Launching $func @params"); exec $func, @params; # Start shell process exit 0; # In case something goes wrong } } elsif($self->{'pid'} > 0) { # Parent: $INTERVAL{$self->{'pid'}}{'t0'} = time(); $self->dprt("START($self->{'pid'})"); # Register PID $EXIT_STATUS{$self->{'pid'}} = undef; $INTERVAL{$self->{'pid'}}{'t1'} = undef; return 1; # return OK } else { return 0; # this shouldn't occur } } ###################################################################### =item poll The I method checks if the process is still running $running = $myproc->poll(); and returns I<1> if it is, I<0> if it's not. =cut ###################################################################### # $ret = $proc_obj->poll(); - Check process status # 1="running" 0="not running" ###################################################################### sub poll { my $self = shift; $self->dprt("Polling"); # There's some weirdness going on with the signal handler. # It runs into timing problems, so let's have poll() call # the REAPER every time to make sure we're getting rid of # defuncts. $self->THE_REAPER(); if(defined($self->{pid})) { if(CORE::kill(0, $self->{pid})) { $self->dprt("POLL($self->{pid}) RESPONDING"); return 1; } else { $self->dprt("POLL($self->{pid}) NOT RESPONDING"); } } else { $self->dprt("POLL(NOT DEFINED)"); } 0; } ###################################################################### =item kill The kill() method: $myproc->kill(); terminates the process by sending it the SIGTERM signal. As an option, another signal can be specified. $myproc->kill("SIGUSR1"); sends the SIGUSR1 signal to the running process. I returns I<1> if it succeeds in sending the signal, I<0> if it doesn't. =cut ###################################################################### # $ret = $proc_obj->kill([SIGXXX]); - Send signal to process # Default-Signal: SIGTERM ###################################################################### sub kill { my $self = shift; my $sig = shift; # If no signal specified => SIGTERM-Signal $sig = POSIX::SIGTERM() unless defined $sig; # Use numeric signal if we get a string if( $sig !~ /^[-\d]+$/ ) { $sig =~ s/^SIG//g; $sig = eval "POSIX::SIG${sig}()"; } # Process initialized at all? if( !defined $self->{'pid'} ) { $self->dprt("No pid set"); return 0; } # Send signal if(CORE::kill($sig, $self->{'pid'})) { $self->dprt("KILL($sig, $self->{'pid'}) OK"); # now kill process group of process to make sure that shell # processes containing shell characters, which get launched via # "sh -c" are killed along with their launching shells. # This might fail because of the race condition explained in # start(), so we ignore the outcome. CORE::kill(-$sig, $self->{'pid'}); } else { $self->dprt("KILL($sig, $self->{'pid'}) failed ($!)"); return 0; } 1; } ###################################################################### =item kill_on_destroy Set a flag to determine whether the process attached to this object should be killed when the object is destroyed. By default, this flag is set to false. The current value is returned. $current = $proc->kill_on_destroy; $proc->kill_on_destroy(1); # Set flag to true $proc->kill_on_destroy(0); # Set flag to false =cut ###################################################################### # Method to set the kill_on_destroy flag ###################################################################### sub kill_on_destroy { my $self = shift; if (@_) { $self->{kill_on_destroy} = shift; } return $self->{kill_on_destroy}; } ###################################################################### =item signal_on_destroy Method to set the signal that will be sent to the process when the object is destroyed (Assuming kill_on_destroy is true). Returns the current setting. $current = $proc->signal_on_destroy; $proc->signal_on_destroy("KILL"); =cut ###################################################################### # Send a signal on destroy # undef means send the default signal (SIGTERM) ###################################################################### sub signal_on_destroy { my $self = shift; if (@_) { $self->{signal_on_destroy} = shift; } return $self->{signal_on_destroy}; } ###################################################################### =item redirect_output Redirects stdout and/or stderr output to a file. Specify undef to leave the stderr/stdout handles of the process alone. # stdout to a file, left stderr unchanged $proc->redirect_output ("/tmp/someapp.stdout", undef); # stderr to a file, left stdout unchanged $proc->redirect_output (undef, "/tmp/someapp.stderr"); # stdout and stderr to a separate file $proc->redirect_output ("/tmp/someapp.stdout", "/tmp/someapp.stderr"); Call this method before running the start method. =cut ###################################################################### sub redirect_output { ###################################################################### my $self = shift ; ($self->{'redirect_stdout'}, $self->{'redirect_stderr'}) = @_ ; 1 ; } ###################################################################### =item pid Returns the pid of the forked process associated with this object $pid = $proc->pid; =cut ###################################################################### sub pid { ###################################################################### my $self = shift; # Allow the pid to be set - assume this is only # done internally so don't document this behaviour in the # pod. if (@_) { $self->{'pid'} = shift; } return $self->{'pid'}; } ###################################################################### =item t0 Returns the start time() of the forked process associated with this object $t0 = $proc->t0(); =cut ###################################################################### sub t0 { ###################################################################### my $self = shift; return $INTERVAL{$self->{'pid'}}{'t0'}; } ###################################################################### =item t1 Returns the stop time() of the forked process associated with this object $t1 = $proc->t1(); =cut ###################################################################### sub t1 { ###################################################################### my $self = shift; return $INTERVAL{$self->{'pid'}}{'t1'}; } =item DESTROY (Destructor) Object destructor. This method is called when the object is destroyed (eg with "undef" or on exiting perl). If kill_on_destroy is true the process associated with the object is sent the signal_on_destroy signal (SIGTERM if undefined). =cut ###################################################################### # Destroy method # This is run automatically on undef # Should probably not bother if a poll shows that the process is not # running. ###################################################################### sub DESTROY { my $self = shift; # Localize special variables so that the exit status from waitpid # doesn't leak out, causing exit status to be incorrect. local( $., $@, $!, $^E, $? ); # Processes never started don't have to be cleaned up in # any special way. return unless $self->pid(); # If the kill_on_destroy flag is true then # We need to send a signal to the process if ($self->kill_on_destroy) { $self->dprt("Kill on DESTROY"); if (defined $self->signal_on_destroy) { $self->kill($self->signal_on_destroy); } else { $self->dprt("Sending KILL"); $self->kill; } } delete $EXIT_STATUS{ $self->pid }; if( $self->poll() ) { $DESTROYED{ $self->pid } = 1; } } ###################################################################### =item exit_status Returns the exit status of the process as the $! variable indicates. If the process is still running, C is returned. =cut ###################################################################### # returns the exit status of the child process, undef if the child # hasn't yet exited ###################################################################### sub exit_status{ my( $self ) = @_; return $EXIT_STATUS{ $self->pid }; } ###################################################################### =item wait The I method: $exit_status = $myproc->wait(); waits until the process is done and returns its exit status. =cut ###################################################################### # waits until the child process terminates and then # returns the exit status of the child process. ###################################################################### sub wait { my $self = shift; local $SIG{CHLD}; # disable until we're done my $pid = $self->pid(); # test if the signal handler reap'd this pid some time earlier or even just # a split second before localizing $SIG{CHLD} above; also kickout if # they've wait'd or waitpid'd on this pid before ... return $EXIT_STATUS{$pid} if defined $EXIT_STATUS{$pid}; # all systems support FLAGS==0 (accg to: perldoc -f waitpid) my $res = waitpid $pid, 0; my $rc = $?; $INTERVAL{$pid}{'t1'} = time(); $EXIT_STATUS{$pid} = $rc; dprt("", "For $pid, reaped '$res' with exit_status=$rc"); return $rc; } ###################################################################### # Reaps processes, uses the magic WNOHANG constant ###################################################################### sub THE_REAPER { # Localize special variables so that the exit status from waitpid # doesn't leak out, causing exit status to be incorrect. local( $., $@, $!, $^E, $? ); my $child; my $now = time(); if(defined $WNOHANG) { # Try to reap every process we've ever started and # whichs Proc::Simple object hasn't been destroyed. # # This is getting really ugly. But if we just call the REAPER # for every SIG{CHLD} event, code like this will fail: # # use Proc::Simple; # $proc = Proc::Simple->new(); $proc->start(\&func); sleep(5); # sub func { open(PIPE, "/bin/ls |"); @a = ; sleep(1); # close(PIPE) or die "PIPE failed"; } # # Reason: close() doesn't like it if the spawn has # been reaped already. Oh well. # # First, check if we can reap the processes which # went out of business because their kill_on_destroy # flag was set and their objects were destroyed. foreach my $pid (keys %DESTROYED) { if(my $res = waitpid($pid, $WNOHANG) > 0) { # We reaped a zombie delete $DESTROYED{$pid}; dprt("", "Reaped: $pid"); } } foreach my $pid (keys %EXIT_STATUS) { dprt("", "Trying to reap $pid"); if( defined $EXIT_STATUS{$pid} ) { dprt("", "exit status of $pid is defined - not reaping"); next; } if(my $res = waitpid($pid, $WNOHANG) > 0) { # We reaped a truly running process $EXIT_STATUS{$pid} = $?; $INTERVAL{$pid}{'t1'} = $now; dprt("", "Reaped: $pid"); } else { dprt("", "waitpid returned '$res'"); } } } else { # If we don't have $WNOHANG, we don't have a choice anyway. # Just reap everything. dprt("", "reap everything for lack of WNOHANG"); $child = CORE::wait(); $EXIT_STATUS{$child} = $?; $INTERVAL{$child}{'t1'} = $now; } # Don't reset signal handler for crappy sysV systems. Screw them. # This caused problems with Irix 6.2 # $SIG{'CHLD'} = \&THE_REAPER; } ###################################################################### =item debug Switches debug messages on and off -- Proc::Simple::debug(1) switches them on, Proc::Simple::debug(0) keeps Proc::Simple quiet. =cut # Proc::Simple::debug($level) - Turn debug on/off sub debug { $Debug = shift; } ###################################################################### =item cleanup Proc::Simple keeps around data of terminated processes, e.g. you can check via C and C how long a process ran, even if it's long gone. Over time, this data keeps occupying more and more memory and if you have a long-running program, you might want to run Ccleanup()> every once in a while to get rid of data pertaining to processes no longer in use. =cut sub cleanup { for my $pid ( keys %INTERVAL ) { if( !exists $DESTROYED{ $pid } ) { # process has been reaped already, safe to delete # its start/stop time delete $INTERVAL{ $pid }; } } } ###################################################################### # Internal debug print function ###################################################################### sub dprt { my $self = shift; if($Debug) { require Time::HiRes; my ($seconds, $microseconds) = Time::HiRes::gettimeofday(); print "[$seconds.$microseconds] ", ref($self), "> @_\n"; } } ###################################################################### sub get_system_nohang { ###################################################################### # This is for getting the WNOHANG constant of the system -- but since # the waitpid(-1, &WNOHANG) isn't supported on all Unix systems, and # we still want Proc::Simple to run on every system, we have to # quietly perform some tests to figure out if -- or if not. # The function returns the constant, or undef if it's not available. ###################################################################### my $nohang; open(SAVEERR, ">&STDERR"); # If the system doesn't even know /dev/null, forget about it. open(STDERR, ">/dev/null") || return undef; # Close stderr, since some weirdo POSIX modules write nasty # error messages close(STDERR); # Check for the constant eval 'use POSIX ":sys_wait_h"; $nohang = &WNOHANG;'; # Re-open STDERR open(STDERR, ">&SAVEERR"); close(SAVEERR); # If there was an error, return undef return undef if $@; return $nohang; } 1; __END__ =back =head1 NOTE Please keep in mind that there is no guarantee that the SIGTERM signal really terminates a process. Processes can have signal handlers defined that avoid the shutdown. If in doubt, whether a process still exists, check it repeatedly with the I routine after sending the signal. =head1 Shell Processes If you pass a shell program to Proc::Simple, it'll use C to launch it. As noted in Perl's C manpage, simple commands for the one-argument version of C will be passed to C directly, while commands containing characters like C<;> or C<*> will be passed to a shell to make sure those get the shell expansion treatment. This has the interesting side effect that if you launch something like $p->start("./womper *"); then you'll see two processes in your process list: $ ps auxww | grep womper mschilli 9126 11:21 0:00 sh -c ./womper * mschilli 9127 11:21 0:00 /usr/local/bin/perl -w ./womper ... A regular C on the process PID would only kill the first process, but Proc::Simple's C will use a negative signal and send it to the first process (9126). Since it has marked the process as a process group leader when it created it previously (via setsid()), this will cause both processes above to receive the signal sent by C. =head1 Contributors Tim Jenness did kill_on_destroy/signal_on_destroy/pid Mark R. Southern worked on EXIT_STATUS tracking Tobias Jahn added redirection to stdout/stderr Clauss Strauch suggested the multi-arg start()-methods. Chip Capelik contributed a patch with the wait() method. Jeff Holt provided a patch for time tracking with t0() and t1(). Brad Cavanagh fixed RT33440 (unreliable $?) =head1 AUTHOR 1996, Mike Schilli =head1 LICENSE Copyright 1996-2011 by Mike Schilli, all rights reserved. This program is free software, you can redistribute it and/or modify it under the same terms as Perl itself. Proc-Simple-1.31/eg/000075500000000000000000000000001205447104500141635ustar00rootroot00000000000000Proc-Simple-1.31/eg/parproc.pl000075500000000000000000000027641205447104500162020ustar00rootroot00000000000000#!/usr/local/bin/perl -w ###################################################################### # parproc.pl -- Sample script, runs 10 jobs, 5 at a time. # # From the book Perl Power! (Addison-Wesley) by Michael Schilli 1999 ###################################################################### use Proc::Simple; $| = 1; # debuffer output $max_parallel_jobs = 5; # jobs processed in parallel @running = (); # array of running jobs foreach $job (1..9) { # create pseudo jobs push(@todo, "sleep 3"); } ###################################################################### # while there are jobs to do while($#todo >= 0 || $#running >= 0) { # or started ones are running @running = grep { $_->poll() } @running; # remove finished jobs if($#running + 1 < $max_parallel_jobs && # space free in running? defined($job = pop(@todo))) { # ... and job available print "Starting job '$job' ... "; $proc = Proc::Simple->new(); # new process $proc->start($job) || die "Cannot start job $job"; push(@running, $proc); # include in running list print "STARTED. (Remaining: ", $#todo+1, " Running: ", $#running + 1, ")\n"; next; # proceed without delay } sleep(1); # pause ... and proceed } Proc-Simple-1.31/t/000075500000000000000000000000001205447104500140335ustar00rootroot00000000000000Proc-Simple-1.31/t/bin/000075500000000000000000000000001205447104500146035ustar00rootroot00000000000000Proc-Simple-1.31/t/bin/test-prog000075500000000000000000000003271205447104500164570ustar00rootroot00000000000000 # test perl program use FindBin qw($Bin); my $testfile = "$Bin/../test-prog-running"; open FILE, ">$testfile" or die "Can't open $testfile: $!"; close FILE; $SIG{ TERM } = sub { unlink $testfile; }; sleep 30; Proc-Simple-1.31/t/destroy.t000064400000000000000000000037551205447104500157230ustar00rootroot00000000000000#!/usr/bin/perl -w # Test the destructor code # This test code has two parts: # i) Fork a perl infinite loop # Retrieve the process id of the forked process # Undef the object # Try to kill the forked process # ii)Fork a perl infinite loop # Retrieve the process id of the forked process # Set the kill_on_destroy flag # Undef the object # Try to kill the forked process # In the first test the kill should succeed (since the process # will still be running. In the second test the kill will fail # since the destructor will have already killed the process. # A sleep of 1 is inserted to make sure the kill signal arrives # and the process shuts down before we check. # We check the process is running by looking at the return # value from perl kill. use Proc::Simple; use Test::More; plan tests => 5; ### ### Simple Test of destroy ### ### Test code $coderef = sub { while (1) { sleep(1) } }; # infinite loop $psh = Proc::Simple->new(); ok($psh->start($coderef)); # 1 # Retrieve the process id (so that we can look for it later) my $pid = $psh->pid; # Destroy object - process should still be running undef $psh; # Process should still be running - now kill it # The sleep is here to make the test fair with the # ond_destroy test later sleep 2; ok($result = kill "SIGTERM", $pid); # 2 ok($result == 1, "check result"); # 3 # print "Result should equal 1 if process was killed by us: $result\n"; # Now try the same thing with the kill_on_destroy flag set $psh = Proc::Simple->new(); ok($psh->start($coderef)); # 4 # Retrieve the process id (so that we can look for it later) my $pid2 = $psh->pid; # Set flag $psh->kill_on_destroy(1); # Destroy object - after that, process should terminate undef $psh; # Process should no longer be running # The sleep makes sure that the process has died by the time # we get there $i = 0; while($i++ < 10) { last unless kill 0, $pid2; sleep(1); } # Okay if we returned before the 10 secs expired ok($i<10); Proc-Simple-1.31/t/esub.t000075500000000000000000000006401205447104500151610ustar00rootroot00000000000000#!/usr/bin/perl -w use Proc::Simple; package EmptySubclass; @ISA = qw(Proc::Simple); 1; package Main; use Test::More; plan tests => 3; ### ### Empty Subclass test ### # Proc::Simple::debug(1); $psh = EmptySubclass->new(); ok($psh->start("sleep 10")); # 1 while(!$psh->poll) { sleep 1; } ok($psh->kill()) or die; # 2 while($psh->poll) { sleep 1; } ok(1, "the end"); 1; Proc-Simple-1.31/t/exit.t000075500000000000000000000013441205447104500151760ustar00rootroot00000000000000#!/usr/bin/perl -w ################################################## # Check the exit status feature ################################################## use Proc::Simple; use Test::More; plan tests => 1; #Proc::Simple::debug(1); $proc = Proc::Simple->new(); $proc->start("ls . >/dev/null"); while($proc->poll()) { sleep(1); } if(defined $proc->exit_status()) { $stat = $proc->exit_status(); } else { $stat = "undef"; } Proc::Simple->dprt("EXIT: '$stat'"); open PIPE, "ls |" or die "Cannot open pipe"; my $data = ; close PIPE or die "Cannot close pipe"; if(defined $proc->exit_status()) { $stat = $proc->exit_status(); } else { $stat = "undef"; } Proc::Simple->dprt("EXIT: '$stat'"); is $stat, 0, "stat 0"; Proc-Simple-1.31/t/muarg.t000075500000000000000000000006221205447104500153360ustar00rootroot00000000000000#!/usr/bin/perl -w use Proc::Simple; use Test::More; plan tests => 4; $psh = Proc::Simple->new(); ok($psh->start("sleep", "1")); # 1 while($psh->poll) { sleep 1; } ok(!$psh->poll()); # 2 Must be dead sub mysleep { sleep(@_); } ok($psh->start(\&mysleep, 1)); # 3 while($psh->poll) { sleep 1; } ok(!$psh->poll()); # 4 Must have been terminated Proc-Simple-1.31/t/mult.t000075500000000000000000000010751205447104500152070ustar00rootroot00000000000000#!/usr/bin/perl -w use Proc::Simple; use Test::More; plan tests => 80; ### ### Multiple Processes Test ### #Proc::Simple->debug(1); foreach $i (0..19) { $psh[$i] = Proc::Simple->new(); } foreach $i (@psh) { ok($i->start("sleep 60")); # 1-20 } foreach $i (@psh) { while(!$i->poll) { sleep 1; } ok($i->poll()); # Check each process, kill it ok($i->kill()); # and check again: 21-80 while($i->poll) { sleep 1; } ok(!$i->poll()); } Proc::Simple->cleanup(); 1; Proc-Simple-1.31/t/sh-c.t000075500000000000000000000020531205447104500150550ustar00rootroot00000000000000#!/usr/bin/perl -w use strict; use Proc::Simple; use Test::More; use FindBin qw($Bin); my $runfile = "$Bin/test-prog-running"; plan tests => 3; unlink $runfile; # cleanup leftover from previous runs my $psh = Proc::Simple->new(); # contains a wildcard, so will be launched via sh -c $psh->start("$^X $Bin/bin/test-prog *"); while( ! $psh->poll() ) { # diag "waiting for process to start"; sleep 1; } ok 1, "process is up"; # wait for shell to spawn perl process while( !-f $runfile ) { # diag "waiting for process to create runfile $runfile"; sleep 1; } $psh->kill(); while( $psh->poll() ) { # diag "waiting for process to shut down"; sleep 1; } ok 1, "process is down"; # as pointed out in [rt.cpan.org #69782], at this point, the grandchild # might not have terminated yet or deleted the runfile, although its # parent (the shell process) is gone. Allow 10 seconds max. for(1..10) { if( !-f "$Bin/test-prog-running" ) { last; } sleep 1; } ok !-f "$Bin/test-prog-running", "running file unlinked"; 1; Proc-Simple-1.31/t/simple.t000075500000000000000000000020051205447104500155110ustar00rootroot00000000000000#!/usr/bin/perl -w use Proc::Simple; package EmptySubclass; @ISA = qw(Proc::Simple); 1; package Main; use Test::More; plan tests => 10; ### ### Simple Test ### ### Shell commands # Proc::Simple::debug(1); $psh = Proc::Simple->new(); ok($psh->start("sleep 1")); # 1 while($psh->poll) { sleep 1; } ok(!$psh->poll()); # 2 Must have been terminated ok($psh->start("sleep 10")); # 3 while(!$psh->poll) { sleep 1; } ok($psh->kill()); # 4 while($psh->poll) { sleep 1; } ok(!$psh->poll()); # 5 Must have been terminated ### Perl subroutines $psub = Proc::Simple->new(); ok($psub->start(sub { sleep 1 })); # 6 while($psub->poll) { sleep 1; } ok(!$psub->poll()); # 7 Must have been terminated ok($psub->start(sub { sleep 10 })); # 8 while(!$psub->poll) { sleep 1; } ok($psub->kill("SIGTERM")); # 9 while($psub->poll) { sleep 1; } ok(!$psub->poll()); # 10 Must have been terminated 1; Proc-Simple-1.31/t/stdouterr.t000075500000000000000000000011541205447104500162570ustar00rootroot00000000000000#!/usr/bin/perl -w use Proc::Simple; use Test::More; plan tests => 2; sub test_output { print "hello stdout\n"; print STDERR "hello stderr\n"; } my $p = Proc::Simple->new(); $p->redirect_output ("stdout.txt", "stderr.txt"); $p->start(\&test_output); while($p->poll()) { } open FILE, "; close FILE; open FILE, "; close FILE; is $stderr, "hello stderr\n", "hello stderr"; is $stdout, "hello stdout\n", "hello stdout"; unlink("stdout.txt", "stderr.txt"); Proc-Simple-1.31/t/time.t000064400000000000000000000020561205447104500151610ustar00rootroot00000000000000#!/usr/bin/perl -w ################################################## # Check the exit status feature ################################################## use Test::More tests => 9; use Proc::Simple; #Proc::Simple::debug(1); my $errortolerance = 2; # this is necessary if the system under test is quite busy my $proc = Proc::Simple->new(); my $t0 = time(); my $start_rc = $proc->start("sleep 5"); ok($start_rc, 'start'); my $wait_rc = $proc->wait(); my $t1 = time(); ok(! $proc->poll(), "process has exited"); ok(defined $wait_rc, "wait_rc defined"); my $exit_rc = $proc->exit_status(); ok(defined $exit_rc, "exit_rc defined"); ok(defined $proc->t0, "t0 defined"); ok(defined $proc->t1, "t1 defined"); my $t0diff = abs($proc->t0 - $t0); ok($t0diff <= $errortolerance, "t0-proc->t0 <= $errortolerance"); my $t1diff = abs($proc->t1 - $t1); ok($t1diff <= $errortolerance, "t1-proc->t1 <= $errortolerance"); my $actela = $t1 - $t0; my $pmela = $proc->t1 - $proc->t0; my $eladiff = abs($actela - $pmela); ok($eladiff < $errortolerance, "eladiff <= $errortolerance"); Proc-Simple-1.31/t/wait.t000064400000000000000000000010031205447104500151560ustar00rootroot00000000000000#!/usr/bin/perl -w ################################################## # Check the exit status feature ################################################## use Test::More tests => 4; use Proc::Simple; #Proc::Simple::debug(1); my $proc = Proc::Simple->new(); my $start_rc = $proc->start("sleep 1"); ok($start_rc, 'start'); my $wait_rc = $proc->wait(); ok(! $proc->poll(), "process has exited"); ok(defined $wait_rc, "wait_rc defined"); my $exit_rc = $proc->exit_status(); ok(defined $exit_rc, "exit_rc defined");