File Coverage

blib/lib/No/Worries/Proc.pm
Criterion Covered Total %
statement 290 339 85.5
branch 120 208 57.6
condition 30 60 50.0
subroutine 35 37 94.5
pod 7 7 100.0
total 482 651 74.0


line stmt bran cond sub pod time code
1             #+##############################################################################
2             # #
3             # File: No/Worries/Proc.pm #
4             # #
5             # Description: process handling without worries #
6             # #
7             #-##############################################################################
8              
9             #
10             # module definition
11             #
12              
13             package No::Worries::Proc;
14 15     15   98 use strict;
  15         17  
  15         360  
15 15     15   70 use warnings;
  15         18  
  15         291  
16 15     15   298 use 5.005; # need the four-argument form of substr()
  15         46  
17             our $VERSION = "1.6";
18             our $REVISION = sprintf("%d.%02d", q$Revision: 1.26 $ =~ /(\d+)\.(\d+)/);
19              
20             #
21             # used modules
22             #
23              
24 15     15   90 use Config qw(%Config);
  15         29  
  15         640  
25 15     15   6386 use IO::Select qw();
  15         21302  
  15         392  
26 15     15   89 use No::Worries qw($_IntegerRegexp $_NumberRegexp);
  15         30  
  15         85  
27 15     15   76 use No::Worries::Die qw(dief);
  15         20  
  15         84  
28 15     15   74 use No::Worries::Dir qw(dir_change);
  15         18  
  15         74  
29 15     15   68 use No::Worries::Export qw(export_control);
  15         26  
  15         150  
30 15     15   85 use Params::Validate qw(validate validate_with :types);
  15         20  
  15         2778  
31 15     15   6059 use POSIX qw(:sys_wait_h :errno_h setsid);
  15         72605  
  15         97  
32 15     15   28418 use Time::HiRes qw();
  15         18565  
  15         27576  
33              
34             #
35             # global variables
36             #
37              
38             our(@SigName, $Transient);
39              
40             #
41             # check a command to be executed
42             #
43              
44             sub _chk_cmd (@) {
45 54     54   266 my(@cmd) = @_;
46 54         178 my($path);
47              
48 54 50       781 if ($cmd[0] =~ /\//) {
49 54 50 33     1714 dief("invalid command: %s", $cmd[0]) unless -f $cmd[0] and -x _;
50             } else {
51 0   0     0 $path = $ENV{PATH} || "/usr/bin:/usr/sbin:/bin:/sbin";
52 0         0 foreach my $dir (split(/:/, $path)) {
53 0 0 0     0 next unless length($dir) and -d $dir;
54 0 0 0     0 next unless -f "$dir/$cmd[0]" and -x _;
55 0         0 $cmd[0] = "$dir/$cmd[0]";
56 0         0 last;
57             }
58 0 0       0 dief("command not found: %s", $cmd[0]) unless $cmd[0] =~ /\//;
59             }
60 54         434 return(\@cmd);
61             }
62              
63             #
64             # definition of the process structure
65             #
66              
67             my $nbre = "(\\d+\\.)?\\d+"; # fractional number pattern
68             my $ksre = "([A-Z]+\\/${nbre}\\s+)*[A-Z]+\\/${nbre}"; # kill spec. pattern
69              
70             my %proc_structure = (
71             # public
72             command => { optional => 0, type => ARRAYREF },
73             pid => { optional => 0, type => SCALAR, regex => $_IntegerRegexp },
74             start => { optional => 0, type => SCALAR, regex => $_NumberRegexp },
75             stop => { optional => 1, type => SCALAR, regex => $_NumberRegexp },
76             status => { optional => 1, type => SCALAR, regex => qr/^-?\d+$/ },
77             timeout => { optional => 1, type => SCALAR, regex => $_NumberRegexp },
78             # private
79             kill => { optional => 1, type => SCALAR, regex => qr/^${ksre}$/ },
80             maxtime => { optional => 1, type => SCALAR, regex => $_NumberRegexp },
81             fhin => { optional => 1, type => GLOBREF },
82             fhout => { optional => 1, type => GLOBREF },
83             fherr => { optional => 1, type => GLOBREF },
84             bufin => { optional => 1, type => SCALAR },
85             cbout => { optional => 1, type => CODEREF },
86             cberr => { optional => 1, type => CODEREF },
87             );
88              
89             sub _chk_proc ($) {
90 53     53   215 my($proc) = @_;
91              
92             validate_with(
93             params => $proc,
94             spec => \%proc_structure,
95 0     0   0 on_fail => sub { dief("invalid process structure: %s", $_[0]) },
96 53         6347 );
97 53         5640 return(); # so that validate_with() is called in void context
98             }
99              
100             #
101             # close a file handle used for IPC
102             #
103              
104             sub _close ($$$$) {
105 65     65   210 my($proc, $fh, $what, $ios) = @_;
106              
107 65 100       364 $ios->remove($fh) if $ios;
108 65 50       3796 close($fh) or dief("cannot close(): %s", $!);
109 65         396 delete($proc->{"fh$what"});
110 65         964 delete($proc->{"cb$what"});
111             }
112              
113             #
114             # try to read from a dead process in case we called _is_alive() on it
115             # before all its output pipes got emptied...
116             #
117              
118             sub _read_zombie ($$$) {
119 44     44   115 my($proc, $iosr, $iosw) = @_;
120 44         89 my($fh, $buf, $done);
121              
122 44         229 foreach my $what (qw(in)) {
123 44 50 33     334 next unless $proc->{"fh$what"} and $proc->{"cb$what"};
124 0         0 $fh = $proc->{"fh$what"};
125             # no write, simply close
126 0         0 _close($proc, $fh, $what, $iosw);
127             }
128 44         112 foreach my $what (qw(out err)) {
129 88 100 66     948 next unless $proc->{"fh$what"} and $proc->{"cb$what"};
130 52         1043 $fh = $proc->{"fh$what"};
131             # read until EOF then close
132 52         109 $done = 1;
133 52         158 while ($done) {
134 59 50 66     821 last if $iosr and not grep($fh eq $_, $iosr->can_read(1));
135 59         17032 $buf = "";
136 59         519 $done = sysread($fh, $buf, 8192);
137 59 50       200 dief("cannot sysread(): %s", $!) unless defined($done);
138 59         280 $proc->{"cb$what"}($proc, $buf);
139             }
140 52         162 _close($proc, $fh, $what, $iosr);
141             }
142             }
143              
144             #
145             # check if a process is alive, record its status if not
146             #
147              
148             sub _is_alive ($$$) {
149 1727     1727   5406 my($proc, $iosr, $iosw) = @_;
150              
151             # check if it recently died
152 1727 100       145479 if (waitpid($proc->{pid}, WNOHANG) == $proc->{pid}) {
153 44         817 $proc->{status} = $?;
154 44         249 $proc->{stop} = Time::HiRes::time();
155 44         81 delete($proc->{maxtime});
156 44         105 delete($proc->{kill});
157 44         185 _read_zombie($proc, $iosr, $iosw);
158 44         244 return(0); # no
159             }
160             # check if we can kill it
161 1683 50 33     22009 if (kill(0, $proc->{pid}) or $! == EPERM) {
162 1683         28704 return(1); # yes
163             }
164             # ooops
165 0         0 return(); # don't know
166             }
167              
168             #
169             # prepare I/O before creating a process
170             #
171              
172             sub _prepare_stdin ($$) {
173 54     54   202 my($proc, $stdin) = @_;
174 54         105 my($ref, $rdrin, $wrtin);
175              
176 54 100       205 return() unless defined($stdin);
177 11         28 $ref = ref($stdin);
178 11 100       122 if ($ref eq "") {
    50          
179 6 50       36 if ($stdin eq "") {
180 0         0 dief("unexpected stdin: empty string");
181             } else {
182             ## no critic 'InputOutput::RequireBriefOpen'
183 6 50       186 open($rdrin, "<", $stdin)
184             or dief("cannot open(<, %s): %s", $stdin, $!);
185             }
186             } elsif ($ref eq "SCALAR") {
187 5 50       180 pipe($rdrin, $wrtin)
188             or dief("cannot pipe(): %s", $!);
189 5         65 $proc->{fhin} = $wrtin;
190 5         35 $proc->{bufin} = ${ $stdin };
  5         25  
191             } else {
192 0         0 dief("unexpected stdin: ref(%s)", $ref);
193             }
194 11         44 return($rdrin, $wrtin);
195             }
196              
197             sub _prepare_stdout ($$) {
198 54     54   160 my($proc, $stdout) = @_;
199 54         96 my($ref, $rdrout, $wrtout);
200              
201 54 100       170 return() unless defined($stdout);
202 52         120 $ref = ref($stdout);
203 52 100 33     488 if ($ref eq "") {
    50          
204 8 50       120 if ($stdout eq "") {
205 0         0 dief("unexpected stdout: empty string");
206             } else {
207             ## no critic 'InputOutput::RequireBriefOpen'
208 8 50       544 open($wrtout, ">", $stdout)
209             or dief("cannot open(>, %s): %s", $stdout, $!);
210             }
211             } elsif ($ref eq "CODE" or $ref eq "SCALAR") {
212 44 50       1589 pipe($rdrout, $wrtout)
213             or dief("cannot pipe(): %s", $!);
214 44         160 $proc->{fhout} = $rdrout;
215 44 50       152 if ($ref eq "CODE") {
216 0         0 $proc->{cbout} = $stdout;
217             } else {
218 44         133 ${ $stdout } = "";
  44         98  
219             $proc->{cbout} = sub {
220 66     66   182 my($_proc, $_buf) = @_;
221 66         148 ${ $stdout } .= $_buf;
  66         188  
222 44         339 };
223             }
224             } else {
225 0         0 dief("unexpected stdout: ref(%s)", $ref);
226             }
227 52         306 return($rdrout, $wrtout);
228             }
229              
230             sub _prepare_stderr ($$) {
231 54     54   166 my($proc, $stderr) = @_;
232 54         113 my($ref, $rdrerr, $wrterr, $merge);
233              
234 54 100       161 return() unless defined($stderr);
235 39         96 $ref = ref($stderr);
236 39 100 33     461 if ($ref eq "") {
    50          
237 9 50       36 if ($stderr eq "") {
238             # special case: stderr will be merged with stdout
239 9         18 $merge = 1;
240             } else {
241             ## no critic 'InputOutput::RequireBriefOpen'
242 0 0       0 open($wrterr, ">", $stderr)
243             or dief("cannot open(>, %s): %s", $stderr, $!);
244             }
245             } elsif ($ref eq "CODE" or $ref eq "SCALAR") {
246 30 50       878 pipe($rdrerr, $wrterr)
247             or dief("cannot pipe(): %s", $!);
248 30         98 $proc->{fherr} = $rdrerr;
249 30 50       109 if ($ref eq "CODE") {
250 0         0 $proc->{cberr} = $stderr;
251             } else {
252 30         49 ${ $stderr } = "";
  30         97  
253             $proc->{cberr} = sub {
254 41     41   131 my($_proc, $_buf) = @_;
255 41         108 ${ $stderr } .= $_buf;
  41         198  
256 30         248 };
257             }
258             } else {
259 0         0 dief("unexpected stderr: ref(%s)", $ref);
260             }
261 39         223 return($rdrerr, $wrterr, $merge);
262             }
263              
264             #
265             # redirect I/O after creating a process
266             #
267              
268             sub _redirect_io ($$$$) {
269 9     9   169 my($rdrin, $wrtout, $wrterr, $merge) = @_;
270 9         125 my($fd);
271              
272             # handle stdin
273 9 100       129 if ($rdrin) {
274 2         18 $fd = fileno($rdrin);
275 2 50       23 if (fileno(*STDIN) != $fd) {
276 2 50       402 open(*STDIN, "<&=$fd")
277             or dief("cannot redirect stdin: %s", $!);
278             }
279             }
280             # handle stdout
281 9 100       84 if ($wrtout) {
282 8         78 $fd = fileno($wrtout);
283 8 50       121 if (fileno(*STDOUT) != $fd) {
284 8 50       898 open(*STDOUT, ">&=$fd")
285             or dief("cannot redirect stdout: %s", $!);
286             }
287             }
288             # handle stderr
289 9 100 100     255 if ($wrterr or $merge) {
290 6 100       206 $fd = $merge ? fileno(*STDOUT) : fileno($wrterr);
291 6 50       63 if (fileno(*STDERR) != $fd) {
292 6 50       215 open(*STDERR, ">&=$fd")
293             or dief("cannot redirect stderr: %s", $!);
294             }
295             }
296             }
297              
298             #
299             # fork a new process, setup its environment and exec() the command
300             #
301              
302             my %proc_create_options = (
303             command => { optional => 0, type => ARRAYREF },
304             cwd => { optional => 1, type => SCALAR },
305             timeout => { optional => 1, type => SCALAR, regex => $_NumberRegexp },
306             kill => { optional => 1, type => SCALAR, regex => qr/^${ksre}$/ },
307             stdin => { optional => 1, type => SCALAR | SCALARREF },
308             stdout => { optional => 1, type => SCALAR | SCALARREF | CODEREF },
309             stderr => { optional => 1, type => SCALAR | SCALARREF | CODEREF },
310             );
311              
312             sub proc_create (@) {
313 54     54 1 428 my(%option, %proc, $merge);
314 54         0 my($rdrin, $wrtin, $rdrout, $wrtout, $rdrerr, $wrterr);
315              
316             #
317             # preparation
318             #
319              
320 54         2070 %option = validate(@_, \%proc_create_options);
321 54         441 $proc{command} = _chk_cmd(@{ $option{command} });
  54         759  
322             # check the "current working directory" option
323 54 50       208 if (defined($option{cwd})) {
324 0 0       0 dief("invalid directory: %s", $option{cwd}) unless -d $option{cwd};
325             }
326             # prepare I/O
327 54         279 ($rdrin, $wrtin) = _prepare_stdin(\%proc, $option{stdin});
328 54         231 ($rdrout, $wrtout) = _prepare_stdout(\%proc, $option{stdout});
329 54         276 ($rdrerr, $wrterr, $merge) = _prepare_stderr(\%proc, $option{stderr});
330             # fork
331 54         64330 $proc{pid} = fork();
332 54 50       1676 dief("cannot fork(): %s", $!) unless defined($proc{pid});
333              
334             #
335             # handle the child
336             #
337              
338 54 100       519 unless ($proc{pid}) {
339             # we are about to exec() or die()
340 9         655 $Transient = 1;
341             # handle the "current working directory"
342 9 50       367 dir_change($option{cwd}) if defined($option{cwd});
343             # make sure the STD* file handles are "normal"
344 9         156 foreach my $glob (*STDIN, *STDOUT, *STDERR) {
345 27 50       228 next unless tied($glob);
346 15     15   123 no warnings qw(untie); ## no critic 'ProhibitNoWarnings'
  15         37  
  15         31140  
347 0         0 untie($glob);
348             }
349             # handle the pipe ends to close
350 9         144 foreach my $fh ($wrtin, $rdrout, $rdrerr) {
351 27 100       203 next unless $fh;
352 13 50       354 close($fh) or dief("cannot close pipe: %s", $!);
353             }
354             # redirect I/O
355 9         299 _redirect_io($rdrin, $wrtout, $wrterr, $merge);
356             # execute the command
357 9         173 exec({ $proc{command}[0] } @{ $proc{command} })
  9         0  
358 9 0       23 or dief("cannot execute %s: %s", $proc{command}[0], $!);
359 0         0 exit(-1);
360             }
361              
362             #
363             # handle the father
364             #
365              
366             # record the "start" time
367 45         1614 $proc{start} = Time::HiRes::time();
368             # record the maximum running time
369 45 100       507 if (defined($option{timeout})) {
370 6         264 $proc{maxtime} = $proc{start} + $option{timeout};
371             }
372             # record the kill specification
373 45 50       505 $proc{kill} = $option{kill} if $option{kill};
374             # handle the pipe ends to close
375 45         859 foreach my $fh ($rdrin, $wrtout, $wrterr) {
376 135 100       464 next unless $fh;
377 78 50       1706 close($fh) or dief("cannot close pipe: %s", $!);
378             }
379             # so far so good
380 45         4461 return(\%proc);
381             }
382              
383             #
384             # terminate a process
385             #
386              
387             my %proc_terminate_options = (
388             kill => { optional => 1, type => SCALAR, regex => qr/^${ksre}$/ },
389             _iosr => { optional => 1, type => UNDEF|OBJECT },
390             _iosw => { optional => 1, type => UNDEF|OBJECT },
391             );
392              
393             sub proc_terminate ($@) {
394 7     7 1 904303 my($proc, %option, $pid, $sig, $grace, $maxtime);
395              
396             # setup
397 7         58 $proc = shift(@_);
398 7 50       115 if (ref($proc) eq "") {
    50          
399 0 0       0 dief("unexpected pid: %s", $proc) unless $proc =~ /^\d+$/;
400 0         0 $proc = { pid => $proc };
401             } elsif (ref($proc) eq "HASH") {
402 7         66 _chk_proc($proc);
403             } else {
404 0         0 dief("unexpected process: %s", $proc);
405             }
406 7 100       275 %option = validate(@_, \%proc_terminate_options) if @_;
407 7   50     288 $option{kill} ||= $proc->{kill} || "TERM/1 INT/1 QUIT/1";
      33        
408 7         14 $pid = $proc->{pid};
409             # gentle kill
410 7         102 foreach my $spec (split(/\s+/, $option{kill})) {
411 7 50       437 if ($spec =~ /^([A-Z]+)\/(${nbre})$/) {
412 7         131 ($sig, $grace) = ($1, $2);
413             } else {
414 0         0 dief("unexpected kill specification: %s", $spec);
415             }
416 7 50       3405 unless (kill($sig, $pid)) {
417 0 0       0 dief("cannot kill(%s, %d): %s", $sig, $pid, $!) unless $! == ESRCH;
418             }
419 7         55 $maxtime = Time::HiRes::time() + $grace;
420 7         41 while (Time::HiRes::time() < $maxtime) {
421 14 100       168 return unless _is_alive($proc, $option{_iosr}, $option{_iosw});
422 7         72715 Time::HiRes::sleep(0.01);
423             }
424 0 0       0 return unless _is_alive($proc, $option{_iosr}, $option{_iosw});
425             }
426             # hard kill
427 0         0 $sig = "KILL";
428 0 0       0 unless (kill($sig, $pid)) {
429 0 0       0 dief("cannot kill(%s, %d): %s", $sig, $pid, $!) unless $! == ESRCH;
430             }
431             }
432              
433             #
434             # setup monitoring
435             #
436              
437             sub _monitor_setup ($) {
438 44     44   134 my($procs) = @_;
439 44         79 my(%process, %map, $iosr, $iosw, $fh);
440              
441             # store the processes to monitor in a hash
442 44         95 foreach my $proc (@{ $procs }) {
  44         127  
443 46         712 _chk_proc($proc);
444 46         425 $process{$proc->{pid}} = $proc;
445             }
446             # record the file handles to monitor
447 44         1610 $iosr = IO::Select->new();
448 44         691 $iosw = IO::Select->new();
449 44         409 foreach my $proc (values(%process)) {
450 46         160 foreach my $what (qw(in out err)) {
451 138         311 $fh = $proc->{"fh$what"};
452 138 100       276 next unless $fh;
453 65 100       172 if ($what eq "in") {
454 4         108 $iosw->add($fh);
455             } else {
456 61         236 $iosr->add($fh);
457             }
458 65         5961 $map{"$fh"} = [ $proc->{pid}, $what ];
459             }
460             }
461 44 100       297 $iosr = undef unless $iosr->count();
462 44 100       356 $iosw = undef unless $iosw->count();
463 44         544 return(\%process, \%map, $iosr, $iosw);
464             }
465              
466             #
467             # monitor I/O
468             #
469              
470             sub _monitor_reading ($$$$$) {
471 1249     1249   6132 my($process, $map, $iosr, $bufsize, $timeout) = @_;
472 1249         3695 my($buf, $done, $proc, $what);
473              
474 1249         5239 foreach my $fh ($iosr->can_read($timeout)) {
475 48         2092 $timeout = 0;
476 48         122 $buf = "";
477 48         557 $done = sysread($fh, $buf, $bufsize);
478 48 50       166 dief("cannot sysread(): %s", $!) unless defined($done);
479 48         251 $proc = $process->{$map->{"$fh"}[0]};
480 48         121 $what = $map->{"$fh"}[1];
481 48         360 $proc->{"cb$what"}($proc, $buf);
482 48 100       324 unless ($done) {
483 9         200 _close($proc, $fh, $what, $iosr);
484             }
485             }
486 1249         12688072 return($timeout);
487             }
488              
489             sub _monitor_writing ($$$$$) {
490 8     8   44 my($process, $map, $iosw, $bufsize, $timeout) = @_;
491 8         48 my($buf, $done, $proc, $what);
492              
493 8         444 foreach my $fh ($iosw->can_write($timeout)) {
494 8         528 $timeout = 0;
495 8         52 $proc = $process->{$map->{"$fh"}[0]};
496 8         24 $what = $map->{"$fh"}[1];
497 8         52 $buf = $proc->{"buf$what"};
498 8 100       36 if (length($buf)) {
499 4         48 $done = syswrite($fh, $buf, length($buf));
500 4 50       32 dief("cannot syswrite(): %s", $!) unless defined($done);
501 4         40 substr($proc->{"buf$what"}, 0, $done, "");
502             } else {
503 4         72 _close($proc, $fh, $what, $iosw);
504             }
505             }
506 8         48 return($timeout);
507             }
508              
509             #
510             # monitor termination (death and timeout)
511             #
512              
513             sub _monitor_termination ($$$$) {
514 1683     1683   6010 my($process, $iosr, $iosw, $timeout) = @_;
515 1683         4408 my($now);
516              
517             # check if some processes finished
518 1683         3127 foreach my $proc (grep(!defined($_->{status}), values(%{ $process }))) {
  1683         18709  
519 1713 100       7526 next if _is_alive($proc, $iosr, $iosw);
520 37         81 $timeout = 0;
521             }
522             # check if some processes timed out
523 1683         7402 $now = Time::HiRes::time();
524 1683         2781 foreach my $proc (grep($_->{maxtime}, values(%{ $process }))) {
  1683         7083  
525 264 100       1146 next unless $now > $proc->{maxtime};
526 6         96 $timeout = 0;
527 6         36 delete($proc->{maxtime});
528 6         24 $proc->{timeout} = $now;
529 6         72 proc_terminate($proc, _iosr => $iosr, _iosw => $iosw);
530             }
531 1683         4889 return($timeout);
532             }
533              
534             #
535             # monitor one or more processes
536             #
537              
538             my %proc_monitor_options = (
539             timeout => { optional => 1, type => SCALAR, regex => $_NumberRegexp },
540             bufsize => { optional => 1, type => SCALAR, regex => $_IntegerRegexp },
541             deaths => { optional => 1, type => SCALAR, regex => $_IntegerRegexp },
542             );
543              
544             sub proc_monitor ($@) {
545 44     44 1 23421 my($procs, %option, $process, $map, $iosr, $iosw);
546 44         0 my($maxtime, $timeout, $zombies);
547              
548             #
549             # preparation
550             #
551              
552 44         114 $procs = shift(@_);
553 44 100       390 if (ref($procs) eq "HASH") {
    50          
554 42         266 $procs = [ $procs ];
555             } elsif (ref($procs) ne "ARRAY") {
556 0         0 dief("unexpected processes: %s", $procs);
557             }
558 44 100       270 %option = validate(@_, \%proc_monitor_options) if @_;
559 44   50     1152 $option{bufsize} ||= 8192;
560 44         343 ($process, $map, $iosr, $iosw) = _monitor_setup($procs);
561             # count the number of processes which are already dead
562 44         78 $zombies = grep(defined($_->{status}), values(%{ $process }));
  44         582  
563              
564             #
565             # work
566             #
567              
568             $maxtime = Time::HiRes::time() + $option{timeout}
569 44 100       265 if defined($option{timeout});
570 44   66     348 while ($iosr or $iosw
      100        
571 477         3687 or grep(!defined($_->{status}), values(%{ $process }))) {
572 1683         3703 $timeout = 0.01;
573             # read what can be read
574             $timeout = _monitor_reading($process, $map, $iosr, $option{bufsize},
575 1683 100       10177 $timeout) if $iosr;
576             # write what can be written
577             $timeout = _monitor_writing($process, $map, $iosw, $option{bufsize},
578 1683 100       11361 $timeout) if $iosw;
579             # check if some processes finished or timed out
580 1683         9500 $timeout = _monitor_termination($process, $iosr, $iosw, $timeout);
581             # or if we timed out
582 1683 50 33     6456 last if $maxtime and Time::HiRes::time() > $maxtime;
583             # or if enough processes died
584             last if $option{deaths}
585 30         284 and grep(defined($_->{status}), values(%{ $process }))
586 1683 100 100     7909 >= $zombies + $option{deaths};
587             # sleep a bit if needed (= if we have not worked before in the loop)
588 1682 100       17317003 Time::HiRes::sleep($timeout) if $timeout;
589             # update the IO::Select objects
590 1682 100 100     27904 $iosr = undef unless $iosr and $iosr->count();
591 1682 100 100     30885 $iosw = undef unless $iosw and $iosw->count();
592             }
593             }
594              
595             #
596             # run the given command
597             #
598              
599             sub proc_run (@) {
600 49     49 1 42025 my(@args) = @_;
601 49         104 my($proc);
602              
603             # create the process
604 49         196 $proc = proc_create(@args);
605             # monitor it until it ends
606 42         51766 proc_monitor($proc);
607             # return what is expected
608 42 100       183 return(%{ $proc }) if wantarray();
  6         192  
609 36         1056 return($proc->{status});
610             }
611              
612             #
613             # execute the given command, check its status and return its output
614             #
615              
616             sub proc_output (@) {
617 4     4 1 12340 my(@command) = @_;
618 4         16 my($output, $status);
619              
620 4         32 $output = "";
621 4         24 $status = proc_run(command => \@command, stdout => \$output);
622 3 50       78 dief("%s failed: %d", $command[0], $status) if $status;
623 3         69 return($output);
624             }
625              
626             #
627             # detach ourself and go in the background
628             #
629              
630             my %proc_detach_options = (
631             callback => { optional => 1, type => CODEREF },
632             );
633              
634             sub proc_detach (@) {
635 0     0 1 0 my(%option, $pid, $sid);
636              
637 0 0       0 %option = validate(@_, \%proc_detach_options) if @_;
638             # change directory to a known place
639 0         0 dir_change("/");
640             # fork and let dad die
641 0         0 $pid = fork();
642 0 0       0 dief("cannot fork(): %s", $!) unless defined($pid);
643 0 0       0 if ($pid) {
644             # we are about to exit()
645 0         0 $Transient = 1;
646 0 0       0 $option{callback}->($pid) if $option{callback};
647 0         0 exit(0);
648             }
649             # create a new session
650 0         0 $sid = setsid();
651 0 0       0 dief("cannot setsid(): %s", $!) if $sid == -1;
652             # detach std* from anything but plain files (i.e. allow: cmd --detach > log)
653 0 0       0 unless (-f STDIN) {
654 0 0       0 open(STDIN, "<", "/dev/null")
655             or dief("cannot re-open stdin: %s", $!);
656             }
657 0 0       0 unless (-f STDOUT) {
658 0 0       0 open(STDOUT, ">", "/dev/null")
659             or dief("cannot re-open stdout: %s", $!);
660             }
661 0 0       0 unless (-f STDERR) {
662 0 0       0 open(STDERR, ">", "/dev/null")
663             or dief("cannot re-open stderr: %s", $!);
664             }
665             }
666              
667             #
668             # return a string representation of the process status
669             #
670              
671             sub proc_status ($) {
672 6     6 1 4251 my($status) = @_;
673 6         15 my($signum, @list);
674              
675 6 100       57 return("ok") unless $status;
676 3         18 $signum = $status & 127;
677 3         24 push(@list, sprintf("code=%d", $status >> 8));
678 3 50 0     24 push(@list, sprintf("signal=%s", $SigName[$signum] || $signum))
679             if $signum;
680 3 50       15 push(@list, "(core dumped)")
681             if $status & 128;
682 3         18 return(join(" ", @list));
683             }
684              
685             #
686             # module initialization
687             #
688              
689             @SigName[split(/\s+/, $Config{sig_num})] = split(/\s+/, $Config{sig_name});
690              
691             #
692             # export control
693             #
694              
695             sub import : method {
696 26     26   134 my($pkg, %exported);
697              
698 26         41 $pkg = shift(@_);
699 26         211 grep($exported{$_}++,
700             map("proc_$_", qw(create detach monitor output run status terminate)));
701 26         154 export_control(scalar(caller()), $pkg, \%exported, @_);
702             }
703              
704             1;
705              
706             __DATA__