← Index
Performance Profile   « block view • line view • sub view »
For /wise/base/deliv/dev/bin/getfix
  Run on Thu May 20 15:30:03 2010
Reported on Thu May 20 16:25:44 2010

File/wise/base/deliv/dev/lib/perl/WISE/Spawn.pm
Statements Executed33
Total Time0.008741 seconds

Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
00000WISE::Spawn::BEGIN
00000WISE::Spawn::_arg_expand
00000WISE::Spawn::_basename
00000WISE::Spawn::_whichami
00000WISE::Spawn::escape_shell
00000WISE::Spawn::mysystem
00000WISE::Spawn::param_passon
00000WISE::Spawn::param_spawn
00000WISE::Spawn::passon_abbrev
00000WISE::Spawn::spawncmd

LineStmts.Exclusive
Time		Avg.Code
1#! /usr/bin/env perl
2
335.1e-51.7e-5use strict;
# spent 21µs making 1 call to strict::import
435.7e-51.9e-5use warnings;
# spent 57µs making 1 call to warnings::import
5
630.000268.5e-5use threads::shared qw(share);
# spent 41µs making 1 call to threads::shared::import
7
8#use lib qw(/wise/base/deliv/dev/lib/perl);
9
10package WISE::Spawn;
11
1230.001240.00041use Exporter::Lite;
# spent 37µs making 1 call to Exporter::Lite::import
13
1434.5e-51.5e-5use vars qw(@EXPORT_OK $VERSION);
# spent 48µs making 1 call to vars::import
15
1611.0e-61.0e-6$VERSION = 0.1;
1711.0e-61.0e-6@EXPORT_OK = qw();
18
1930.000810.00027use IO::Handle;
# spent 53µs making 1 call to Exporter::import
2030.000237.6e-5use Time::HiRes qw( sleep time );
# spent 265µs making 1 call to Time::HiRes::import
2130.005970.00199use Cwd;
# spent 61µs making 1 call to Exporter::import
22
23# Application aliases to make passon param sepcs look cleaner
2411.0e-61.0e-6my %abbrev = ();
25
26sub spawncmd {
27 my $cmd = shift;
28 my $opts = shift || {};
29 my $err = "*** $0/spawncmd";
30
31 my $verbose = $opts->{verbose};
32 my $test = $opts->{test};
33 my $debug = $opts->{debug};
34 my $cluster = $opts->{cluster};
35 my $defs = $opts->{defs};
36 my $targdefs= $opts->{targdefs};
37
38 die "$err: Spawncmd sub illegally called with norun option; ".
39 "use test instead.\n"
40 if $opts->{norun};
41
42 $defs ||= WISE::Pars->target_defs($cmd,$opts) if ! ref $cmd;
43
44 my $status;
45 if($cluster && ! $test) {
46
47 die "$err: We don't use CondorJob anymore!!!!\n";
48
49 require WISE::CondorJob;
50
51 my $cluster_job = WISE::CondorJob->new(
52 $cmd,
53 {
54 merge => 1,
55 passon => 1,
56 targdefs=> $targdefs,
57 defs => $defs,
58 verbose => $verbose,
59 norun => $test,
60 debug => $debug,
61 %$opts, # Overrides
62 }
63 );
64
65 die "$err: Failed to make a CondorJob; $!\n"
66 if ! $cluster_job;
67
68 $status = $cluster_job->submit();
69
70 } else {
71
72 $status = param_spawn($cmd,
73 {
74 merge => 1,
75 passon => 1,
76 targdefs=> $targdefs,
77 defs => $defs,
78 logfh => 1, # Write to log, if there is one
79 tee => 1, # Write stdout/err while capturing
80 # Log stderr if the subprocess won't
81 #logerr => (! $defs || ! $defs->has("log_file")),
82 verbose => $verbose,
83 norun => $test,
84 debug => $debug,
85 %$opts, # Overrides
86 }
87 );
88 }
89
90 return $status;
91}
92
93# Create and optionally execute a process using a set of command line
94# parameters cloned from those of the currently executing process.
95
96sub param_spawn {
97 my $target = shift; # Program to execute
98 my $opts = shift || {}; # Other options in a hash ref
99 my (%not,%take,%mod,$status);
100 my (@cmd,@cloneargs,@unnamed,@mods,@add,%add,$add);
101 my ($norun,$verbose,$passon,$not,$iam,$noexit,$logfh,$tee,$redir,$logerr);
102 my ($defs,$targdefs,$take,$exec,$sysopts,@front,@back,$propogate,$shell);
103 my ($usetarg,$debug,$step);
104 my $err = "*** $0/SPAWN";
105 my $warn= "=== $0/SPAWN";
106
107 $verbose = $opts->{verbose};
108 $debug = $opts->{debug};
109 $targdefs = $opts->{targdefs}; # Target param def.s
110 $passon = (exists $opts->{passon} # What to do with pass-on variables
111 ? $opts->{passon} # Explicit instruction provided
112 : 1); # Assume default passing on is OK if not defined
113 $norun = $opts->{norun}; # Don't execute, just build the command line
114 $propogate= $opts->{propogate}; # Propogate children's signal upward
115 $exec = $opts->{exec}; # Use exec instead of system; I.e. don't return
116 $noexit = $opts->{noexit}; # Always return even if the exec dies
117 $iam = $opts->{iam}; # Exec's ID handle
118 $add = $opts->{add}; # Param.s to add
119 $tee = $opts->{tee}; # Tee output to stdout/err/log as well as capture
120 $redir = $opts->{redir}; # Copy stderr to stdout (mode II and III)
121 $logerr = $opts->{logerr}; # Copy stderr to log file (mode III)
122 @unnamed = @{$opts->{unnamed} || []}; # Unnamed arg. list (usu. files)
123 @front = @{$opts->{front} || []}; # Arg.s to add to the front
124 @back = @{$opts->{back} || []}; # Arg.s to add to the back
125 $not = $opts->{not}; # Param.s to exclude
126 $take = $opts->{take}; # Param.s to take
127 $sysopts = $opts->{sysopts} || {}; # msystem options
128 $step = $opts->{step};
129 $logfh = $opts->{logfh};
130 $usetarg = $opts->{usetargvals};
131 if(ref($target)) {
132 # Command line already assembled; just a front-end for mysystem()
133 @cmd = @$target if ref($target) =~ /array/i;
134 @cmd = ($$target), $shell=1 if ref($target) =~ /scalar/i;
135 die "$err: Exec is undefined; command args = '@cmd[1..$#cmd]'\n"
136 if ! defined $cmd[0];
137 $iam ||= ucfirst _basename($cmd[0]);
138 goto SPAWN;
139 } else {
140 $iam = $target;
141 }
142
143 $defs = $opts->{defs} or die "$err: No defs.\n"; # Current param def.s
144
145 # Turn array ref.s into hash keys for easy checking
146 @not{ map {lc $_} @$not } = (1) x @$not if $not;
147 @take{map {lc $_} @$take} = (1) x @$take if $take;
148 # Copy unnamed parameters still left on the command line
149 if(! @unnamed && ! $not{_unnamed} && @ARGV) { @unnamed = @ARGV; }
150
151 my $use = $targdefs ? $targdefs : $defs;
152
153 # Step through the parameter list and select and modify them according
154 # to the rules.
155 #print "--- names: /".join("/",@{$defs->{_meta}{parnames}})."/\n";
156 PARM: for my $p (@{$defs->{_meta}{parnames}}) {
157 my $parm = $p;
158 #print "--- param='$parm' /$defs->{$parm}{specified}/".
159 # "$defs->{$parm}{isdefault}/$defs->{$parm}{private}/\n";
160 # Skip parameters not specified or defaulted or defined as private
161 if(! $defs->{$parm}{specified} &&
162 ! $defs->{$parm}{isdefault}) { next PARM; }
163 if($defs->{$parm}{private}) { next PARM; }
164 my @aliases = @{ $defs->{$parm}{aliases} };
165 #print "--- aliases @aliases\n";
166 # Skip param.s in $not list
167 if(grep($not{lc $_},@aliases)) { next PARM; }
168 # Skip those not in $take list (if it's defined)
169 if($take && ! grep($take{lc $_},@aliases)) { next PARM; }
170 if($targdefs) {
171 #{require WISE; print WISE::Dumper::Dumper($targdefs)}
172 # Skip those not defined by the target
173 #print "--- targ '$parm' = /$targdefs->{$parm}/\n";
174 if(! $targdefs->{$parm}) { next PARM; }
175 # Error off if the target definition for this parameter is
176 # different in some important way
177 my @targaliases = @{ $targdefs->{$parm}{aliases} || [] };
178 #print "--- targ aliases=@targaliases\n";
179 die "$err: Parameter '$parm' has incompatible definitions; ".
180 "'@aliases' vs, '@targaliases'.\n"
181 if "@aliases" ne "@targaliases" ||
182 $targdefs->{$parm}{itype} != $defs->{$parm}{itype} ||
183 ($targdefs->{$parm}{list}||0) ne ($defs->{$parm}{list}||0);
184 }
185
186 my $val = $defs->{$parm}{val};
187 my $defval = $defs->{$parm}{default};
188 my $targval = $targdefs->{$parm}{val};
189
190 if($usetarg && ! $defs->{$parm}{specified} &&
191 $targdefs->{$parm}{isdefault}) {
192 # Value from target defaults
193 $val = $targval;
194 }
195
196 $val = _arg_expand($parm,$val);
197 $defval = _arg_expand($parm,$defval) if defined $defval;
198 $targval = _arg_expand($parm,$targval); # Only use if isdefault is true
199
200 #print "1 $parm/$usetarg=|'$val'".
201 # "($defs->{$parm}{specified}/$defs->{$parm}{isdefault}/".
202 # "$defs->{$parm}{source}) | ".
203 # "'$targval'($targdefs->{$parm}{isdefault})|\n";
204
205 # Don't bother specifying params on the command line if it's
206 # our default and the same as the target's default
207 if($defs->{$parm}{isdefault} && $targdefs->{$parm}{isdefault} &&
208 $val eq $targval) {
209 next PARM;
210 }
211
212 #print " --- type '$defs->{$parm}{type}'\n";
213 if($defs->{$parm}{type} ne 'switch') {
214 # Parameters with arguments
215 push @cloneargs,"-$parm",$val;
216 #print " --- arg '$cloneargs[-2]','$cloneargs[-1]'\n";
217 } else {
218 # To handle a switch set on the command line but set OFF, we must
219 # assume '-switch=0' notation was used and likewise employ it here.
220 if(! $val) { $parm .= '=0'; }
221 push @cloneargs,"-$parm";
222 #print " --- arg '$cloneargs[-1]'\n";
223 }
224 #print "------ /@cloneargs/\n";
225 } # Merge params
226
227 # Add some known parameters not already on the command line
228 if(ref($add) eq 'HASH') {
229 for my $k (keys %$add) {
230 #print "--- add key $k ...\n";
231 my $equal;
232 (my $key = $k) =~ s/^-+//; # Allow the user to use the dash or not
233 $key =~ s|([^=]+)=(.*)|$1|
234 and
235 $equal = $2; # Value is attached to the key rather than in the val
236 die "$err: Ambiguous value for 'key=val' parameter; ".
237 "'$key=$equal'=>'$add->{$k}'.\n"
238 if defined $equal && defined $add->{$k};
239 $add->{$k} = $equal if defined $equal; # Strange, but within spec
240 # Take the key directly if it's a pass-on param,
241 # otherwise look it up and get its full name.
242 my ($pass,$parm);
243 if($key =~ /:/) { # pass-on param
244 $parm = $key;
245 $pass = 1;
246 } else {
247 $parm = $use->{_meta}{aliases}{$key};
248 die "$err: Can't add unrecognized parameter '$key' to ".
249 "spawn of '$target'.\n"
250 if ! $parm;
251 }
252 $parm =~ s/^-//; # The leading dash will be added back in later
253 my $arg = $add->{$k};
254 $arg = _arg_expand($parm,$arg);
255 push @add,(! $pass && $use->{$parm}{type} eq 'switch'
256 ? ("-$parm".($arg?"=$arg":"=0"))
257 : ("-$parm",$arg) );
258 } # Hash Add
259 } elsif(ref($add) eq 'ARRAY') {
260 push @add,@$add;
261 } elsif($add) {
262 die "$err: Don't know what to do with add type ".ref($add).
263 "for spawn of '$target'.\n";
264 }
265
266 my $targbase = _basename($target);
267
268 # Copy passed-on param.s (if not contravened)
269 my @passon;
270 if($passon) {
271 if($passon > 0) {
272 # Default pass-on: The sub-process is smart and knows what to do
273 # with '-:subprog "arg1 arg2 ..."' parameters
274 #print " =@{$defs->{_meta}{pass_on}||[]}\n";
275 if($passon > 1) {
276 # Provide absolute pass-on param.s, rather than relative
277 # from our current state.
278 push @passon,@{$defs->{_meta}{pass_on_abs}||[]};
279 } else {
280 # Do normal (relative) pass-on form
281 push @passon,@{$defs->{_meta}{pass_on}||[]};
282 # Remove those with no hope of being relevant
283 my @newpasson;
284 while(@passon) {
285 my ($for, $args) = (shift(@passon),shift(@passon));
286 if($for =~ /^-+([^:*]+):/) {
287 my $full = WISE::Spawn::passon_abbrev($1);
288 $for =~ s/^-+[^:*]+:/-$full:/;
289 }
290 next if ! defined $args ||
291 ($for !~ /^-+:?\*/ && $for !~ /^-+:/ &&
292 $for !~ /^-+$targbase/);
293 push @newpasson, $for, $args;
294 }
295 @passon = @newpasson;
296 }
297 } else {
298 # The subproces is dumb and needs to have its parameters
299 # stripped out for it.
300 push @passon,param_passon({for=>$targbase,defs=>$defs});
301 }
302 }
303
304 # Throw added arg.s before passon args.
305 push @cloneargs,@add,@passon;
306
307 # Create executable array
308 @cmd = ($target,@front,@cloneargs,@back,@unnamed);
309
310 SPAWN:
311
312 my $print_cmd = join(" ", map {(my $s=$_) =~ s|([^-_/\w.,+%\@:=])|\\$1|g;
313 $s;
314 } @cmd);
315
316 # Warn about and remove residual undefs
317 warn "$warn: Spawn command contained undefined components: !".
318 join("! !",map {defined $_ ? $_ : "<UNDEF>"} @cmd)."!\n"
319 if grep {! defined $_} @cmd;
320 $_ //= '' for @cmd;
321
322 if($verbose) {
323 if($debug || $norun) {
324 print "SPAWN created cmd '$print_cmd'.\n";
325 } else {
326 print "SPAWN created cmd '$cmd[0] ...'.\n";
327 }
328 }
329
330 # Go
331 if(! $norun) {
332 if(! $exec) {
333 # Run and monitor; parent is waiting
334
335 # If we need the shell, pass as a plain string rather than an array
336 my $cmdarg = $shell ? $cmd[0] : \@cmd;
337 $status = mysystem($cmdarg,
338 {
339 verbose=> $verbose,
340 tag => $iam,
341 stderr => $opts->{stderr} || $opts->{err},
342 stdout => $opts->{stdout} || $opts->{out},
343 redir => $redir,
344 tee => $tee,
345 logerr => $logerr,
346 logfh => $logfh,
347 nobreak=> $shell,
348 quiet => $opts->{quiet},
349 memlimit=>$opts->{memlimit},
350 timeout=> 0.25, # How often to loop the select
351 step => $step,
352 %$sysopts,
353 }
354 );
355
356 my ($rc,$sig) = (($status>>8),$status&255);
357 if(! $noexit && $status) {
358 if($propogate && $sig) {
359 # Suicide by signal
360 warn "$err: Propogating signal $sig .\n";
361 kill $sig, $$;
362 } else {
363 $! = $rc || $sig;
364 # Die instead of exit so it's trappable by our caller
365 die "$err: Spawn of '$iam' dying with status ".($!+0).
366 "\n";
367 }
368 }
369
370 return wantarray ? ($rc||$sig, \@cmd) : $rc||$sig;
371
372 } else {
373 # Exec as overlay, with possible previous fork; parent is
374 # NOT waiting. I.e. it'll be a background process.
375
376 print "Exec'ing ...\n" if $verbose;
377
378 if(ref $exec) {
379 # If $exec has further instructions, assume we want to
380 # fork first and. Do so and carry out other
381 # instructions ...
382
383 my $pid;
384 if($pid=fork) {
385 # Parent; reap and return
386 my $rc = waitpid($pid,0);
387 if($rc < 0 || $? != 0) {
388 die "$0/SPAWN: Parent wait failed: $rc/$?\n."
389 }
390 # If not daemonizing, parent is expected to wait
391 # for and reap the child
392 return wantarray ? (0, \@cmd, $pid) : 0;
393 } elsif (! defined $pid) {
394 die "*** $0/SPAWN: Parent can't fork: $!.\n";
395 } else {
396 # Child
397 if($exec->{daemon}) {
398 # If daemonizing, set new process group and fork again
399 require POSIX;
400 POSIX->import("setsid");
401 setsid();
402 $SIG{HUP} = "IGNORE";
403 if($pid=fork) {
404 exit 0; # Parent
405 } elsif (! defined $pid) {
406 die "*** $0/SPAWN: Child can't fork: $!.\n";
407 }
408 # Child carries on
409 }
410 # Child (grandchild if daemon)
411 # Reroute input/output
412 open(STDIN, "<", $exec->{stdin}||"/dev/null");
413 if($exec->{stdout}) {
414 $exec->{stdout} =~ s/\$\$/$$/g;
415 $exec->{stdout} =~ s/%pid%/$$/ig;
416 }
417 if(defined $exec->{stdout} || $exec->{daemon}) {
418 $exec->{stdout} ||= "/dev/null";
419 open(STDOUT,"+>",$exec->{stdout})
420 or die "*** $0/SPAWN: Child can't redirect ".
421 "stdout to '$exec->{stdout}': $!.\n";
422 }
423 if($exec->{stderr}) {
424 $exec->{stderr} =~ s/\$\$/$$/g;
425 $exec->{stderr} =~ s/%pid%/$$/ig;
426 }
427 if(defined $exec->{stderr} || $exec->{daemon}) {
428 $exec->{stderr} ||= "/dev/null";
429 open(STDERR,"+>",$exec->{stderr})
430 or die "*** $0/SPAWN: Child can't redirect ".
431 "stderr to '$exec->{stderr}': $!.\n";
432 }
433 # Doing this messes up condor which expects a
434 # meaningful CWD in some circumstances, so commented out
435 #if($exec->{daemon}) {
436 # chdir "/"
437 # or die "*** $0/SPAWN: Can't cd to /: $!.\n";
438 #} # daemon
439 } # child
440 }
441 # Exec/overlay the new command
442 exec @cmd;
443 }
444 } else {
445 return wantarray ? @cmd : $print_cmd;
446 }
447
448}
449
450# Serialize parameter argument values for use on the command line
451sub _arg_expand {
452 my $parm= shift;
453 my $arg = shift;
454 my $err = "*** $0/ARGXPND";
455
456 if(! ref($arg)) {
457 $arg //= "undef"; # Special value to Params
458 # Otherwise no change
459 } elsif(ref($arg) eq "ARRAY") {
460 $arg = join ",", map { $_ // 'undef' } @$arg;
461 } elsif (ref($arg) eq "HASH") {
462 my ($k,$v,@val);
463 while(($k,$v)=each %$arg) {
464 if(ref($v)) {
465 if(ref($v) eq 'ARRAY') {
466 $v = join ",", map { $_ // 'undef' } @$v;
467 } else {
468 die "$err: Unknown sub-arg type '".ref($arg).
469 "' for '$parm'.\n";
470 }
471 } else {
472 $v //= 'undef';
473 }
474 push @val,"$k=$v";
475 }
476 $arg = join(",",@val);
477 } else {
478 die "$err: Unknown arg type '".ref($arg)."' for '$parm'.\n";
479 }
480
481 return $arg;
482}
483
484sub passon_abbrev {
485 my $for = shift // '';
486 return $abbrev{lc $for} // $for;
487}
488
489# Gather parameters meant for passing on as command line params to
490# sub-commands.
491
492sub param_passon {
493 my $opts = shift || {};
494 my $doit = exists $opts->{doit} ? $opts->{doit}||0 : 1;
495 my $err = "*** Spawn";
496 my $ctxt = $opts->{defs} || die "$err/passon: No defs.\n";
497 my $for = $opts->{for} || 0;
498 my $dump = $opts->{dump}; # For dumping, not actual use
499 my $ref = $opts->{pass} || $ctxt->{_meta}{pass_on};
500 my @passon = ref($ref) ? @$ref : ();
501 my $ref_from = $ctxt->{_meta}{pass_from};
502 my @passfrom = ref($ref_from) ? @$ref_from : ();
503 my ($parname,$i);
504
505 #warn "--------0- @passon // '$for'\n";
506
507 if($for) {
508 my @newpasson;
509 @passfrom = (); # Can't use origin info when $for is used
510 # If 'for' is defined, look for matches and just recover the
511 # arguments to pass on to "dumb" (non-perl) parameter receivers.
512 # Skip arg.s to the pass-on param.s by skipping every other
513 # element. 0=param, 1=arg, 2=param, 3=arg, etc.
514 for($i=0; $i<=$#passon-1; ++$i) {
515 # If there's only one remaining name in the pass-on path, grab it.
516 ($parname) = $passon[$i] =~ m/^-(?:\*?:)?([^:]+):?$/i;
517 if(! $parname) {
518 # Must be a pass-on parameter with path elements remaining
519 next;
520 }
521 # Look for an abbreviation of this name
522 $parname = passon_abbrev($parname);
523
524 # print "for=$for, i=$i, passon=$passon[$i], nm=$parname\n";
525
526 # Skip if param name does't match target
527 next if lc($parname) ne lc($for);
528
529 # Separate args by shell-like parsing of whitespace-separated words
530 if(defined $passon[$i+1]) {
531 require Text::ParseWords; Text::ParseWords->import();
532 my @words = shellwords($passon[$i+1]);
533 # This filters out '%' variants, because 'dumb'
534 # programs can't handle them. This is an overly wide
535 # net since *all* args are skipped (because I can't
536 # tell whether the arg after a word starting '-%' is a
537 # new parameter or an argument to the current one),
538 # but I don't know what else to do.
539 @words = () if grep /^--?%/, @words;
540 # Copy the arg.s onto the list to pass-on to the named exec.
541 push @newpasson,@words;
542 }
543 }
544 @passon = @newpasson;
545 }
546 # If there are no pass-on param.s, or if the $doit flag is both present
547 # and false, then return nothing.
548
549 #warn "--------1- @passon // '$doit'\n";
550 if(@passon && $doit) {
551 if($dump) {
552 # Tack on origin info, if any
553 for my $i (0..$#passon) {
554 if(defined $passfrom[$i]) {
555 my $from = [qw/n d c e f p i/]->[$passfrom[$i]+1] // '?';
556 $passon[$i] .= "($from)";
557 }
558 }
559 }
560 if($for) {
561 # "Dumb" parameter receiver; no quotes.
562 return wantarray ? @passon : " ".join(" ",@passon)." ";
563 } else {
564 return wantarray ? @passon : " '".join("' '",@passon)."' ";
565 }
566 } else {
567 return wantarray ? () : "";
568 }
569}
570
571# 'Mysystem' forks an executable one of three different ways. It avoids
572# running an intermediate shell by breaking the exec into words (if
573# it isn't already broken up). If '$verbose' is true, some extra
574# informative o/p is generated; an echo of exactly what is executed.
575# If a non-null $tag is given, it is used in the verbose and error
576# o/p along with the executable basename to disambiguate multiple
577# mysystem calls using the same executable.
578# A leading '!' means do not break the string into words, implying that an
579# intermediate shell will be used if shell meta-characters are present.
580# The leading '!' is stripped off if it appears. This flag can also be set
581# with the "nobreak" option.
582# I) $status = mysystem("[!]program args...",$verbose)
583# Just like $status = system("program args..."). O/p goes to screen.
584# $status = mysystem(["program","arg1","arg2",...],$verbose,$tag)
585# Just like $status = system("program","arg1","arg2",...).
586# II) ($status,@op) = mysystem("[!]program arg.s",$verbose,$tag[,$err])
587# ($status,@op) = mysystem(["program","arg1","arg2",...],$verbose,
588# $tag [,$err])
589# STDOUT is saved rather than just going to the screen.
590# Done with a fork/exec combo. If $err is defined and true but not a
591# reference (see below), redirect stderr into stdout.
592# III) ($status,@op) = mysystem("[!]program arg.s",$verbose,$tag,$err)
593# ($status,@op) = mysystem(["program","arg1","arg2",...],verbose,$err)
594# Like II) but the stderr o/p is separated and placed into an array,
595# to which $err is a reference. Done with pipe,fork,exec,select calls.
596
597sub mysystem {
598 my $ex = shift; # Command to be exec'd. String or array ref.
599 my $verbose = shift;
600 my $tag = shift||"";
601 my $stderr = shift;
602 my ($status,@op,@ope,$op,$ope,$main,$exec,@exec,$keep,$line,$cmdline);
603 my ($opts,$stdout,$redir,$tee,$noin,$timeout,$test,$quiet,$oplimit);
604 my ($logfh,$logerr,$memlimit,$step,$full);
605 my ($bufsz);
606
607 # A bit of non-obvious trickery employed in many places in my perl code.
608 # Lengthy explanation: For backward compatability I don't want to alter
609 # the way this subroutine is called, but I want to add options without
610 # creating a horribly long calling sequence. Thus I "overload" the
611 # meaning of an already defined parameter, in this case the '$verbose'
612 # boolean. If it's not a reference, I assume the old meaning. If it's
613 # a hash reference, I can get all conceivable options from the hash as
614 # named, rather than positional, parameters. E.g. turning this
615 # mysystem('ls','1','LS',\@err)
616 # into the longer but more readable
617 # mysystem('ls',{verbose=>1, tag=>'LS', stderr=>\@err})
618 # And along the way I can add extensions without altering the calling
619 # sequence.
620 if(ref($verbose) =~ /hash/i) {
621 # It is a hash reference, so get the options that can come
622 # from either @_ or $opts here.
623 $opts = $verbose;
624 $verbose = $opts->{verbose};
625 } elsif(! defined $verbose || ! ref($verbose)) {
626 # The old way of figuring out what to do
627 if($stderr && ref($stderr) !~ /array/i) { $stderr = 1; }
628 if(wantarray) {
629 $stdout = 1;
630 if($stderr) { $stderr = undef; $redir = 1; }
631 }
632 } else {
633 # $verbose was a reference but not a hash reference
634 die "*** $0/MYSYSTEM: Don't know what to do with non-hash ref ".
635 "\$opts = $opts."
636 }
637 # Alternative ways to get call param.s.
638 $opts ||= {};
639 $test = $opts->{test};
640 $tag ||= $opts->{tag};
641 $stderr ||= $opts->{stderr} || $opts->{err};
642 # Options that can only come from $opts.
643 # If '$stdout' is defined it's equivalent to case II but in a scalar
644 # context; the o/p is put in $stdout if it's an array ref., or is
645 # returned if context is array, otherwise it's thrown away.
646 $stdout = $opts->{stdout} || $opts->{out};
647 # If $opts is defined, we'll disavow the use of $stderr as a
648 # redirection flag for case II and rely on this parameter.
649 # The code is cleaner this way.
650 # Redirect stderr to stdout (modes II, III)
651 $redir = $opts->{redir_stderr} || $opts->{redir};
652 # Do not break exec into words. Same as a leading '!'
653 $keep = exists $opts->{nobreak} ? $opts->{nobreak} : 0;
654 # For type II or III interaction, tee the o/p to stdout/err
655 $tee = $opts->{tee} // 1;
656 # Step info, if any
657 $step = $opts->{step};
658 # Copy stderr to log file (mode III)
659 $logerr = $opts->{logerr};
660 # Close STDIN on child when doing a fork/exec.
661 $noin = $opts->{nostdin};
662 # Time limit waiting for input on type III
663 $timeout = $opts->{timeout} || undef;
664 # sysread buffer size for type III
665 $bufsz = $opts->{bufsz} || 2048;
666 # Quiet any non-fatal local error messages
667 $quiet = $opts->{quiet};
668 # Limit on output bytes allowable to stderr/out from child
669 $oplimit = $opts->{oplimit} || 128*1024*1024; # 100MB
670 # Limit on memory (RSS) usage (when logfh in effect)
671 $memlimit= $opts->{memlimit}; # undef or <=0 => no limit, units of bytes
672 $memlimit = undef if $memlimit && $memlimit < 0;
673 $memlimit /= 1024*1024 if $memlimit;
674 # Write stuff to a log file, if one is open
675 $logfh = $opts->{logfh};
676 if($logfh && ! ref $logfh) {
677 if(defined &WISE::UtilsLight::logging) {
678 $logfh = WISE::UtilsLight::logging();
679 } else {
680 $logfh = undef;
681 }
682 }
683 $logfh = undef if defined $logfh && ! defined fileno($logfh);
684
685 if(ref($stderr) && ref($stderr)!~/array|scalar/i) {
686 die "*** $0/MYSYSTEM: Don't know what to do with \$stderr of $stderr."
687 }
688
689 if(ref($stdout) && ref($stdout)!~/array|scalar/i) {
690 die "*** $0/MYSYSTEM: Don't know what to do with \$stdout of $stdout."
691 }
692
693 # Process executable string or array
694 if(ref $ex) {
695 if(ref($ex) !~ /array/i) {
696 die "*** $0/MYSYSTEM: Executable is a ref but not an array ref.\n";
697 }
698 # Caller passed an array ref.
699 @exec = @$ex;
700 } else {
701 # Caller passed a string
702 $exec = $ex;
703 }
704
705 if(! @exec) {
706 # Caller didn't pass executable and arg.s as an array, so we'll make
707 # make an array ourselves.
708 if($exec =~ s/^\!// || $keep) {
709 # Leave $exec exactly as given; do not break into words. The
710 # expectation is the shell is needed; e.g. a redirection, pipe or
711 # glob is employed.
712 $keep = '!';
713 # Put into a single element array.
714 @exec = ($exec);
715 } else {
716 # Otherwise, break into words before passing to exec to avoid
717 # invoking a shell (see 'exec' and 'system' write-ups in
718 # 'man perlfunc').
719 $keep = "0";
720 # Quotewords, from the parsewords module, will separate words
721 # in the exec string just as the shell would.
722 require Text::ParseWords; Text::ParseWords->import();
723 @exec = &shellwords($exec);
724 }
725 } else {
726 # Do nothing; take user's exec array as is.
727 $keep = 0;
728 }
729
730 # Get executable base name for o/p info.
731 $main = (split(" ",$exec[0]))[0];
732
733 $tag ||= $main;
734 $full = _whichami($main);
735
736 # Echo command line, making a valiant attempt to make it shell-safe.
737 $cmdline =
738 join(" ",map { my $x=$_;
739 ! defined($x) || $x eq "" ? "''"
740 : scalar($x=~s/([][\s!#&^*?(){};<>\\~`'"\$])/\\$1/g,$x)
741 } @exec) # )})
742 if ! $keep;
743 $cmdline = $exec[0] if $keep;
744 $stdout ||= wantarray ? 1 : $stdout||0;
745 $stderr ||= 0;
746 $line = "\nMysystem exec'ing $tag (exec=$full, keep,out,err=$keep,$stdout,$stderr) ".
747 "as ...\n$cmdline";
748 if($verbose || $test) { print "$line\n"; STDOUT->flush(); }
749
750 return wantarray ? (0,@op) : 0 if $test;
751
752 #if(defined &WISE::UtilsLight::logging &&
753 # WISE::UtilsLight::logging(1)) {
754 # print {WISE::UtilsLight::logging()} "\nCMDLINE => $cmdline\n\n";
755 #}
756
757 # Execute that puppy ...
758 if(! $logfh && ! $stdout && ! $stderr) {
759 # Case I: Save no output internally
760 # Simplest possible exec. Just send all op to the terminal and get
761 # status. Included so ALL calls can be with mysystem; no need to
762 # employ backticks or the perl builtin 'system' call.
763 $status = system(@exec);
764 } elsif(! $logfh && ! $stderr) {
765 # Case II: Save stdout and optionally redirect stderr to stdout.
766 # We want to trap output, but don't need to separate out stderr.
767 $status = open(EXEC,"-|");
768 if(! defined $status) {
769 # Couldn't fork.
770 warn "*** $0/MYSYSTEM: $main $tag unexecutable; $!\n";
771 $status = $!+0; # Make $status a number, not a string.
772 } elsif($status == 0) {
773 # Child process
774 # Reopen stdin to /dev/null
775 open(STDIN,"</dev/null") if $noin;
776 if($redir) {
777 # Redirect stderr to stdout
778 open(STDERR,">&STDOUT") or
779 die "*** $0/MYSYSTEM: Child can't redirect ".
780 "stderr to stdout; $!\n";
781 }
782 # Unbuffer the o/p stream.
783 select STDERR; $| = 1; select STDOUT; $| = 1;
784 # Overlay with new process.
785 exec @exec or
786 die "*** $0/MYSYSTEM: exec of $main $tag failed: $!\n";
787 exit -1; # Should never be reached.
788 } else {# $status is the PID
789 # Parent
790 my $cpid = $status;
791 my ($nbytes,$l);
792 while(defined ($l=<EXEC>)) { # Catch stdout.
793 push @op,$l;
794 if($tee) { print $l; }
795 $nbytes += length($l);
796 if($nbytes > $oplimit) {
797 warn "*** $0/MYSYSTEM: Stdout/err output exceeded ".
798 "limit of $oplimit bytes (1).\n";
799 kill(2,$cpid); # Kill the child; it's a runaway
800 last;
801 }
802 }
803 close(EXEC);
804 $status = $?;
805 }
806 } else { # $stderr is a ref or $logfh is set
807 # Case III: Save stdout and stderr separately
808 # Also used when logfh is specified whether or not stdout/err are.
809 # Take advantage of a high resolution sleep
810 my ($cpid,$rh,$rhf,$rhef,$rhe,$rin,$rout,$tout,$rc,$nr,$nre,$host,
811 $line,$linee,$off,$rbuf,$erbuf,$wbuf,$ewbuf,$startt,$startdat);
812 $op = $ope = "";
813 # Open pipes to move stdout/err from the child to the parent.
814 pipe(RH,WH);
815 pipe(RHE,WHE);
816 # Fork child process to run request.
817 FORK: {
818 if(($cpid = fork()) > 0) {
819 # Parent
820 # Won't be writing to pipe from parent.
821 close(WH);
822 close(WHE);
823 my ($sys);
824 if($logfh) {
825 require WISE::SysStat;
826 $sys = WISE::SysStat->new($cpid);
827 $startt = int(time()+0.5);
828 $startdat = WISE::UtilsLight::mytime($startt);
829 $host = WISE::UtilsLight::thishost();
830 # Note the weirdness with the pid. This necessary to
831 # maintain the proper structure of the log file when
832 # it is parsed by IOUtils::parse_log_file. The fake pid
833 # remains unique, but when compared indide an int() will
834 # produce the right structure.
835 print $logfh "\n\n>>>> START iam=>'Spawn_$main', ".
836 "host=>'$host', pid=>\"$$.$cpid\", ".
837 "starttime=>'$startdat', ppid=>$$, \n".
838 "\n>>>>+ Command_line=>'".
839 escape_shell(@exec)."'".
840 "\n\n"
841 or warn "*** $0/MYSYSTEM: Unable to print START tag ".
842 "to LOG file; $!\n";
843 # Log output should already be line buffered, but
844 # we're grasping at straws as to why the END tag doesn't
845 # get printed 1% of the time, so we're throwing in
846 # autoflushes everywhere.
847 select +(select($logfh), $|=1)[0];
848 # Add a step tag if requested
849 if(defined $step) {
850 print $logfh "\n\n>>>> STEP step=>'$step'\n\n";
851 }
852 }
853 # Use select to poll for which filehandle to read.
854 $rhf = $rhef = "";
855 # "vec" creates the bit field which controls
856 # which filehandles need to be read. See the 'select'
857 # perlfunc write-up.
858 vec($rhf, $rh = fileno(RH),1) = 1;
859 vec($rhef,$rhe = fileno(RHE),1) = 1;
860 # Bitwise "or" the bitfields.
861 $rin = $rhf | $rhef;
862 my $nbytes; # Limit line output to be on the safe side
863 my $t0 = time();
864 my $tsys = time();
865 OP: while(defined
866 ($rc=select($rout=$rin,undef,undef,$tout=$timeout))
867 && $rc != -1) {
868 $line = $linee = "";
869 $nr = $nre = -1;
870 # Read from job's stdout
871 if ($rout && vec($rout,$rh,1)) {
872 $nr = sysread(RH,$line,$bufsz);
873 if(! defined $nr) {
874 # Error
875 warn "*** $0/MYSYSTEM: Can't Read from $cpid ".
876 "stdout (".fileno(RH)."); $!.\n";
877 last OP;
878 } elsif($nr>0) {
879 # Has o/p
880 $op .= $line;
881 if ($tee) { print STDOUT $line; }
882 }
883 # ... else EOF
884 }
885 # Read from job's stderr
886 if ($rout && vec($rout,$rhe,1)) {
887 $nre = sysread(RHE,$linee,$bufsz);
888 if(! defined $nre) {
889 # Error
890 warn "*** $0/MYSYSTEM: Can't Read from $cpid ".
891 "stderr (".fileno(RHE)."); $!.\n";
892 last OP;
893 } elsif($nre>0) {
894 # Has o/p
895 $ope .= $linee;
896 if ($tee) { print STDERR $linee; }
897 if($redir) {
898 $op .= $linee;
899 if ($tee) { print STDOUT $line; }
900 }
901 if($logerr && $logfh) {
902 print $logfh $linee;
903 }
904 }
905 # ... else EOF
906 }
907 $nbytes += length($line) + length($linee);
908 if ($nbytes > $oplimit) {
909 warn "*** $0/MYSYSTEM: Stdout/err output exceeded ".
910 "limit of $oplimit bytes (2).\n";
911 kill(2,$cpid); # Kill the child; it's a runaway
912 last OP;
913 }
914 # Grab latest RSS value
915 if($sys) { SYS: {
916 # Sample no more often than 2/s
917 last SYS if time() - $tsys < 0.5;
918 $tsys = time();
919 my $stats = $sys->get();
920 if($stats && $memlimit && $stats->{rssmb} &&
921 $stats->{rssmb} > $memlimit) {
922 warn "$0/MYSYSTEM: Job $main ($cpid) ".
923 "memory ($stats->{rssmb} MB) exceeded ".
924 "limit of $memlimit MB; job killed.\n";
925 kill(2,$cpid); # Kill the child
926 last OP;
927 }
928 } }
929 # Only non-error way out: Neither file descriptor will
930 # block (the bit in $rout is set) and both return EOF.
931 last OP if ! $nr && ! $nre;
932 # Special case in case it returned nothing or we're
933 # collecting system info.
934 # If we loop too fast, we eat cpu.
935 sleep(0.1) if ! $rout;
936 } # OP
937 if(! defined $rc || $rc == -1) {
938 die "*** $0/MYSYSTEM: Bad select RC=".($rc||"undef").
939 "; $!.\n";
940 }
941 close(RH); # Close now defunct filehandles
942 close(RHE);
943 # Wait for child death.
944 $rc = waitpid($cpid,0);
945 warn "=== $0/MYSYSTEM: Surprising waitpid return on $cpid: ".
946 "'$rc'.\n"
947 if ! $rc;
948 if($rc && $rc < 0) {
949 die "*** $0/MYSYSTEM: Waitpid failed on $cpid: $!.\n";
950 } else {
951 $status = $?;
952 }
953 #print $logfh "\n--- Test $$ 2\n";
954 if($logfh) {
955 $sys->get() if $sys;
956 my $endt = int(time()+0.5);
957 my $enddat = WISE::UtilsLight::mytime($endt);
958 #print "\n--- Test $$ 3 (stdout)\n";
959 #print $logfh "\n--- Test $$ 3\n";
960 print $logfh "\n\n".
961 WISE::UtilsLight::wrapup(
962 132,">>>> ",">>>>+ ",1,
963 "END iam=>'Spawn_$main', ".
964 "host=>'$host', pid=>\"$$.$cpid\", ".
965 "starttime=>'$startdat', endtime=>'$enddat', ".
966 "status=>$status, ".
967 "signal=>".($status&255).", ".
968 "retcode=>".($status>>8).", ".
969 ($sys ? $sys->statstr().", " : (""))
970 )."\n\n"
971 or warn "*** $0/MYSYSTEM: Unable to print END tag ".
972 "to LOG file; $!\n";
973 # Log output should already be line buffered, but
974 # we're grasping at straws as to why the END tag doesn't
975 # get printed 1% of the time, so we're throwing in
976 # autoflushes everywhere.
977 select +(select($logfh), $|=1)[0];
978 }
979 # Parse op into lines with newlines at end.
980 push @op, map { $_."\n" } split(/\n/,$op) if length($op);
981 push @ope, map { $_."\n" } split(/\n/,$ope) if length($ope);
982 } elsif (defined $cpid) {
983 # Child
984 # Won't be reading from parent.
985 close(RH);
986 close(RHE);
987 # Reopen stdin to /dev/null
988 open(STDIN,"</dev/null") if $noin;
989 # Redirect stdout/err to the pipeline.
990 open(STDOUT, ">&WH") # Make STDOUT go to RH in parent;
991 or die "*** $0/MYSYSTEM: Redirect of stdout failed; ".
992 "$!\n";
993 open(STDERR, ">&WHE") # Make STDERR go to RHE in parent;
994 or die "*** $0/MYSYSTEM: Redirect of stderr failed; ".
995 "$!\n";
996 # Unbuffer every damn thing, every way I can think of.
997 if($logfh) { select($logfh); $| = 1; }
998 select(STDERR); $| = 1;
999 select(STDOUT); $| = 1;
1000 # (... all to no avail, as far as I can tell, since
1001 # buffering will not nherit across the exec)
1002 # Exec client's request.
1003 exec @exec or
1004 die "*** $0/MYSYSTEM: exec of $main $tag failed: $!\n";
1005 exit -1;
1006 # We never reach here.
1007 } else {
1008 # Other fork error.
1009 die "*** $0/MYSYSTEM: Fork failed: $!\n";
1010 } # Fork
1011 } # FORK
1012 } # defined $stderr ...
1013
1014 # print "STATUS for $tag = $status\n";
1015 if($status) {
1016 warn "*** $0/MYSYSTEM: Exec $main $tag failed with ",
1017 "RC=",($status>>8),", SIGNAL=",($status&255),".\n"
1018 if ! $quiet;
1019 }
1020
1021 if(ref($stdout)) {
1022 @$stdout = @op if ref($stdout) eq "ARRAY";
1023 $$stdout = join("",@op)||"" if ref($stdout) eq "SCALAR";
1024 }
1025 if(ref($stderr)) {
1026 @$stderr = @ope if ref($stderr) eq "ARRAY";
1027 $$stderr = join("",@ope)||"" if ref($stderr) eq "SCALAR";
1028 }
1029
1030 return wantarray ? ($status,@op) : $status;
1031}
1032
1033# Just to avoid use'ing File::Basename
1034sub _basename {
1035 my ($base) = $_[0] =~ m|([^/]*)$|;
1036 return $base;
1037}
1038
1039# Copied over from UtilsLight.
1040# Find the executable path for a given program, by default the currently
1041# executing one.
1042sub _whichami {
1043 my ($iam) = shift||$0;
1044 my (@path) = @_ ? (@_) : split(/[:\s]+/,$ENV{'PATH'});
1045 my ($me,$base,$path);
1046
1047 if($iam eq '-e' || $iam eq 'perl-e') { $iam = $^X; }
1048
1049 if($iam =~ m|/|) {
1050 ($base,$path) = File::Basename::fileparse($iam);
1051 } else {
1052 $path = "";
1053 $base = $iam;
1054 }
1055
1056 if ($path eq "") {
1057 for my $p (@path) {
1058 if(-x "$p/$base" && ! -d _) { $path = "$p/"; last; }
1059 }
1060 }
1061 $path = eval { Cwd::fast_abs_path($path) } // "" if $path ne "";
1062
1063 $me = $path.$base;
1064
1065 return wantarray ? ($base,$path) : $me;
1066}
1067
1068# Escape shell-unfirendly characters
1069sub escape_shell {
1070 my @new = map { if(defined $_) {
1071 s/\n/\\n/g;
1072 s/([\s'"\$\*&;?\\{}\[\]<>()])/\\$1/g;
1073 $_ = '""' if ! length $_;
1074 }
1075 $_;
1076 } @_;
1077 return wantarray ? @new : join(" ",@new);
1078}
1079
1080# Some aliases for backward compatability.
1081
108235.4e-51.8e-5use vars qw/&Param_passon &Param_spawn/;
# spent 61µs making 1 call to vars::import
1083
108413.0e-63.0e-6*Param_passon = \&param_passon;
108514.0e-64.0e-6*Param_spawn = \&param_spawn;
1086
108711.8e-51.8e-51;

Report produced by the NYTProf 2.07 Perl profiler, developed by Tim Bunce and Adam Kaplan.