File Coverage

blib/lib/Proc/Background.pm
Criterion Covered Total %
statement 123 150 82.0
branch 67 114 58.7
condition 19 52 36.5
subroutine 22 28 78.5
pod 16 17 94.1
total 247 361 68.4


line stmt bran cond sub pod time code
1             package Proc::Background;
2             $Proc::Background::VERSION = '1.32';
3             # ABSTRACT: Generic interface to Unix and Win32 background process management
4             require 5.004_04;
5              
6 22     22   83327 use strict;
  22         98  
  22         610  
7 22     22   110 use Exporter;
  22         47  
  22         698  
8 22     22   112 use Carp;
  22         43  
  22         1583  
9 22     22   128 use Cwd;
  22         26  
  22         1435  
10 22     22   151 use Scalar::Util;
  22         144  
  22         49044  
11             @Proc::Background::ISA = qw(Exporter);
12             @Proc::Background::EXPORT_OK = qw(timeout_system);
13              
14             # Determine if the operating system is Windows.
15             my $is_windows = $^O eq 'MSWin32';
16             my $weaken_subref = Scalar::Util->can('weaken');
17              
18             # Set up a regular expression that tests if the path is absolute and
19             # if it has a directory separator in it. Also create a list of file
20             # extensions of append to the programs name to look for the real
21             # executable.
22             my $is_absolute_re;
23             my $has_dir_element_re;
24             my $path_sep;
25             my @extensions = ('');
26             if ($is_windows) {
27             $is_absolute_re = '^(?:(?:[a-zA-Z]:[\\\\/])|(?:[\\\\/]{2}\w+[\\\\/]))';
28             $has_dir_element_re = "[\\\\/]";
29             $path_sep = "\\";
30             push(@extensions, '.exe');
31             } else {
32             $is_absolute_re = "^/";
33             $has_dir_element_re = "/";
34             $path_sep = "/";
35             }
36              
37             # Make this class a subclass of Proc::Win32 or Proc::Unix. Any
38             # unresolved method calls will go to either of these classes.
39             if ($is_windows) {
40             require Proc::Background::Win32;
41             unshift(@Proc::Background::ISA, 'Proc::Background::Win32');
42             } else {
43             require Proc::Background::Unix;
44             unshift(@Proc::Background::ISA, 'Proc::Background::Unix');
45             }
46              
47             # Take either a relative or absolute path to a command and make it an
48             # absolute path.
49             sub _resolve_path {
50 103     103   353 my $command = shift;
51              
52 103 50       437 return ( undef, 'empty command string' ) unless length $command;
53              
54             # Make the path to the progam absolute if it isn't already. If the
55             # path is not absolute and if the path contains a directory element
56             # separator, then only prepend the current working to it. If the
57             # path is not absolute, then look through the PATH environment to
58             # find the executable. In all cases, look for the programs with any
59             # extensions added to the original path name.
60 103         261 my $path;
61 103 100       2223 if ($command =~ /$is_absolute_re/o) {
62 101         1297 foreach my $ext (@extensions) {
63 101         1179 my $p = "$command$ext";
64 101 50 33     6363 if (-f $p and -x _) {
65 101         458 $path = $p;
66 101         372 last;
67             }
68             }
69 101 50       980 return defined $path? ( $path, undef ) : ( undef, "no executable program located at $command" );
70             } else {
71 2         5540 my $cwd = cwd;
72 2 50       60 if ($command =~ /$has_dir_element_re/o) {
73 0         0 my $p1 = "$cwd$path_sep$command";
74 0         0 foreach my $ext (@extensions) {
75 0         0 my $p2 = "$p1$ext";
76 0 0 0     0 if (-f $p2 and -x _) {
77 0         0 $path = $p2;
78 0         0 last;
79             }
80             }
81             } else {
82 2 50       95 foreach my $dir (split($is_windows ? ';' : ':', $ENV{PATH})) {
83 18 50       45 next unless length $dir;
84 18 100       107 $dir = "$cwd$path_sep$dir" unless $dir =~ /$is_absolute_re/o;
85 18         48 my $p1 = "$dir$path_sep$command";
86 18         43 foreach my $ext (@extensions) {
87 18         39 my $p2 = "$p1$ext";
88 18 50 33     384 if (-f $p2 and -x _) {
89 0         0 $path = $p2;
90 0         0 last;
91             }
92             }
93 18 50       54 last if defined $path;
94             }
95             }
96 2 50       57 return defined $path? ( $path, undef ) : ( undef, "cannot find absolute location of $command" );
97             }
98             }
99              
100             # Define the set of allowed options, to warn about unknown ones.
101             # Make it a method so subclasses can override it.
102             %Proc::Background::_available_options= (
103             autodie => 1, command => 1, exe => 1,
104             cwd => 1, stdin => 1, stdout => 1, stderr => 1,
105             autoterminate => 1, die_upon_destroy => 1,
106             );
107              
108             sub _available_options {
109 24     24   135 return \%Proc::Background::_available_options;
110             }
111              
112             # We want the created object to live in Proc::Background instead of
113             # the OS specific class so that generic method calls can be used.
114             sub new {
115 108     108 1 2013658 my $class = shift;
116              
117             # The parameters are an optional %options hashref followed by any number
118             # of arguments to become the @argv for exec(). If options are given, check
119             # the keys for typos.
120 108         293 my $options;
121 108 100 66     2157 if (@_ and ref $_[0] eq 'HASH') {
122 24         92 $options= shift;
123 24         568 my $known= $class->_available_options;
124 24         397 my @unknown= grep !$known->{$_}, keys %$options;
125 24 50       218 carp "Unknown options: ".join(', ', @unknown)
126             if @unknown;
127             }
128             else {
129 84         429 $options= {};
130             }
131              
132 108         736 my $self= bless {}, $class;
133 108 100       563 $self->{_autodie}= 1 if $options->{autodie};
134              
135             # Resolve any confusion between the 'command' option and positional @argv params.
136             # Store the command in $self->{_command} so that the ::Unix and ::Win32 don't have
137             # to deal with it redundantly.
138 108         295 my $cmd= $options->{command};
139 108 100       431 if (defined $cmd) {
140 14 50       79 croak "Can't use both 'command' option and command argument list"
141             if @_;
142             # Can be an arrayref or a single string
143 14 0 33     268 croak "command must be a non-empty string or an arrayref of strings"
      33        
      0        
      0        
      33        
144             unless (ref $cmd eq 'ARRAY' && defined $cmd->[0] && length $cmd->[0])
145             or (!ref $cmd && defined $cmd && length $cmd);
146             }
147             else {
148             # Back-compat: maintain original API quirks
149 94 50       1522 confess "Proc::Background::new called with insufficient number of arguments"
150             unless @_;
151 94 50       498 return $self->_fatal('command is undefined') unless defined $_[0];
152              
153             # Interpret the parameters as an @argv if there is more than one,
154             # or if the 'exe' option was given.
155 94 100 66     1029 $cmd= (@_ > 1 || defined $options->{exe})? [ @_ ] : $_[0];
156             }
157              
158 108         965 $self->{_command}= $cmd;
159 108 50       512 $self->{_exe}= $options->{exe} if defined $options->{exe};
160              
161             # Also back-compat: failing to fork or CreateProcess returns undef
162 108 100       897 return unless $self->_start($options);
163              
164             # Save the start time
165 87         1655 $self->{_start_time} = time;
166              
167 87 100 66     1989 if ($options->{autoterminate} || $options->{die_upon_destroy}) {
168 2         100 $self->autoterminate(1);
169             }
170              
171 87         2660 return $self;
172             }
173              
174             # The original API returns undef from the constructor in case of various errors.
175             # The autodie option converts these undefs into exceptions.
176             sub _fatal {
177 4     4   36 my ($self, $message)= @_;
178 4 100       651 croak $message if $self->{_autodie};
179 2         105 warn "$0: $message";
180 2         45 return undef;
181             }
182              
183             sub autoterminate {
184 2     2 1 16 my ($self, $newval)= @_;
185 2 50 25     136 if (@_ > 1 and ($newval xor $self->{_die_upon_destroy})) {
      33        
186 2 50       24 if ($newval) {
187             # Global destruction can break this feature, because there are no guarantees
188             # on which order object destructors are called. In order to avoid that, need
189             # to run all the ->die methods during END{}, and that requires weak
190             # references which weren't available until 5.8
191 2 50       44 $weaken_subref->( $Proc::Background::_die_upon_destroy{$self+0}= $self )
192             if $weaken_subref;
193             # could warn about it for earlier perl... but has been broken for 15 years and
194             # who is still using < 5.8 anyway?
195             }
196             else {
197 0         0 delete $Proc::Background::_die_upon_destroy{$self+0};
198             }
199 2 50       26 $self->{_die_upon_destroy}= $newval? 1 : 0;
200             }
201 2 50       12 $self->{_die_upon_destroy} || 0
202             }
203              
204             sub DESTROY {
205 49     49   2002598 my $self = shift;
206 49 100       2386 if ($self->{_die_upon_destroy}) {
207             # During a mainline exit() $? is the prospective exit code from the
208             # parent program. Preserve it across any waitpid() in die()
209 2         44 local $?;
210 2         84 $self->terminate;
211 2         62 delete $Proc::Background::_die_upon_destroy{$self+0};
212             }
213             }
214              
215             END {
216             # Child processes need killed before global destruction, else the
217             # Win32::Process objects might get destroyed first.
218 5     5   2196646 for (grep defined, values %Proc::Background::_die_upon_destroy) {
219 0         0 $_->terminate;
220             delete $_->{_die_upon_destroy}
221 0         0 }
222 5         141 %Proc::Background::_die_upon_destroy= ();
223             }
224              
225             # Reap the child. If the first argument is false, then return immediately.
226             # Else, block waiting for the process to exit. If no second argument is
227             # given, wait forever, else wait for that number of seconds.
228             # If the wait was sucessful, then delete
229             # $self->{_os_obj} and set $self->{_exit_value} to the OS specific
230             # class return of _reap. Return 1 if we sucessfully waited, 0
231             # otherwise.
232             sub _reap {
233 204     204   1392 my ($self, $blocking, $wait_seconds) = @_;
234              
235 204 50       908 return 0 unless exists($self->{_os_obj});
236              
237             # Try to wait on the process. Use the OS dependent wait call using
238             # the Proc::Background::*::waitpid call, which returns one of three
239             # values.
240             # (0, exit_value) : sucessfully waited on.
241             # (1, undef) : process already reaped and exit value lost.
242             # (2, undef) : process still running.
243 204         3045 my ($result, $exit_value) = $self->_waitpid($blocking, $wait_seconds);
244 204 100 66     2158 if ($result == 0 or $result == 1) {
245 87 50       1459 $self->{_exit_value} = defined($exit_value) ? $exit_value : 0;
246 87         712 delete $self->{_os_obj};
247             # Save the end time of the class.
248 87         641 $self->{_end_time} = time;
249 87         1909 return 1;
250             }
251 117         1564 return 0;
252             }
253              
254             sub alive {
255 188     188 1 5003 my $self = shift;
256              
257             # If $self->{_os_obj} is not set, then the process is definitely
258             # not running.
259 188 100       2036 return 0 unless exists($self->{_os_obj});
260              
261             # If $self->{_exit_value} is set, then the process has already finished.
262 124 50       489 return 0 if exists($self->{_exit_value});
263              
264             # Try to reap the child. If it doesn't reap, then it's alive.
265 124         694 !$self->_reap(0);
266             }
267              
268             sub suspended {
269 0 0   0 1 0 $_[0]->{_suspended}? 1 : 0
270             }
271              
272             sub suspend {
273 0     0 1 0 my $self= shift;
274             return $self->_fatal("can't suspend, process has exited")
275 0 0       0 if !$self->{_os_obj};
276 0 0       0 $self->{_suspended} = 1 if $self->_suspend;
277 0         0 return $self->{_suspended};
278             }
279              
280             sub resume {
281 0     0 1 0 my $self= shift;
282             return $self->_fatal("can't resume, process has exited")
283 0 0       0 if !$self->{_os_obj};
284 0 0       0 $self->{_suspended} = 0 if $self->_resume;
285 0         0 return !$self->{_suspended};
286             }
287              
288             sub wait {
289 126     126 1 4368 my ($self, $timeout_seconds) = @_;
290              
291             # If $self->{_exit_value} exists, then we already waited.
292 126 100       2227 return $self->{_exit_value} if exists($self->{_exit_value});
293              
294 54 50       358 carp "calling ->wait on a suspended process" if $self->{_suspended};
295              
296             # If neither _os_obj or _exit_value are set, then something is wrong.
297 54 50       340 return undef if !exists($self->{_os_obj});
298              
299             # Otherwise, wait for the process to finish.
300 54 100       569 return $self->_reap(1, $timeout_seconds)? $self->{_exit_value} : undef;
301             }
302              
303 15     15 1 171 sub terminate { shift->die(@_) }
304             sub die {
305 37     37 0 306 my $self = shift;
306              
307 37 50 33     453 croak "process is already terminated" if $self->{_autodie} && !$self->{_os_obj};
308              
309             # See if the process has already died.
310 37 100       375 return 1 unless $self->alive;
311              
312             # Kill the process using the OS specific method.
313 26 50       1783 $self->_terminate(@_? ([ @_ ]) : ());
314              
315             # See if the process is still alive.
316 26         171 !$self->alive;
317             }
318              
319             sub command {
320 0     0 1 0 $_[0]->{_command};
321             }
322              
323             sub exe {
324             $_[0]->{_exe}
325 0     0 1 0 }
326              
327             sub start_time {
328 40     40 1 733 $_[0]->{_start_time};
329             }
330              
331             sub exit_code {
332 9 50   9 1 197 return undef unless exists $_[0]->{_exit_value};
333 9         232 return $_[0]->{_exit_value} >> 8;
334             }
335              
336             sub exit_signal {
337 0 0   0 1 0 return undef unless exists $_[0]->{_exit_value};
338 0         0 return $_[0]->{_exit_value} & 127;
339             }
340              
341             sub end_time {
342 10     10 1 680 $_[0]->{_end_time};
343             }
344              
345             sub pid {
346 7     7 1 1399 $_[0]->{_pid};
347             }
348              
349             sub timeout_system {
350 34 50   34 1 3696 unless (@_ > 1) {
351 0         0 confess "$0: timeout_system passed too few arguments.\n";
352             }
353              
354 34         343 my $timeout = shift;
355 34 50 33     1301 unless ($timeout =~ /^\d+(?:\.\d*)?$/ or $timeout =~ /^\.\d+$/) {
356 0         0 confess "$0: timeout_system passed a non-positive number first argument.\n";
357             }
358              
359 34 50       598 my $proc = Proc::Background->new(@_) or return;
360 30         374 my $end_time = $proc->start_time + $timeout;
361 30         291 my $delay= $timeout;
362 30   66     669 while ($delay > 0 && defined $proc->{_os_obj}) {
363 30 100       480 last if defined $proc->wait($delay);
364             # If it times out, it's likely that wait() already waited the entire duration.
365             # But, if it got interrupted, there might be time remaining.
366             # But, if the system clock changes, this could break horribly. Constrain it to a sane value.
367 13         113 my $t= time;
368 13 50       161 if ($t < $end_time - $delay) { # time moved backward!
369 0         0 $end_time= $t + $delay;
370             } else {
371 13         103 $delay= $end_time - $t;
372             }
373             }
374              
375 30         478 my $alive = $proc->alive;
376 30 100       285 $proc->terminate if $alive;
377              
378 30 100       234 if (wantarray) {
379 14         434 return ($proc->wait, $alive);
380             } else {
381 16         109 return $proc->wait;
382             }
383             }
384              
385             1;
386              
387             __END__