File Coverage

lib/Shell/Cmd.pm
Criterion Covered Total %
statement 599 717 84.9
branch 293 370 80.2
condition 103 135 76.3
subroutine 47 53 90.5
pod 11 11 100.0
total 1053 1286 83.0


line stmt bran cond sub pod time code
1             package Shell::Cmd;
2             # Copyright (c) 2013-2018 Sullivan Beck. All rights reserved.
3             # This program is free software; you can redistribute it and/or modify it
4             # under the same terms as Perl itself.
5              
6             # Variables used in scripts
7             # SC_ORIG_DIRE : the directory you were in when the script ran
8             # SC_DIRE : the working directory of the script
9             # SC_DIRE_n : the working directory going into command n
10             # SC_FAILED = N : the command which failed
11             # SC_CURR_EXIT : the exit code for the current command
12             # SC_CURR_SUCC : 1 if the current command (any alternate) succeeded
13             # SC_RETRIES = N : this command will run up to N times
14             # SC_TRY = N : we're currently on the Nth try
15              
16             ###############################################################################
17              
18             require 5.008;
19 93     93   225029 use warnings 'all';
  93         177  
  93         3434  
20 93     93   432 use strict;
  93         145  
  93         2039  
21 93     93   41545 use Capture::Tiny qw(capture capture_stdout capture_stderr);
  93         1394653  
  93         5740  
22 93     93   83349 use Net::OpenSSH;
  93         2918997  
  93         4703  
23 93     93   54704 use Parallel::ForkManager 0.7.6;
  93         4459822  
  93         3597  
24 93     93   757 use IO::File;
  93         192  
  93         32408  
25 93     93   632 use Cwd;
  93         207  
  93         714339  
26              
27             our($VERSION);
28             $VERSION = "3.03";
29              
30             $| = 1;
31             $Data::Dumper::Sortkeys = 1;
32              
33             ###############################################################################
34             # METHODS TO CREATE OBJECT
35             ###############################################################################
36              
37             sub version {
38             # uncoverable subroutine
39             # uncoverable statement
40 0     0 1 0 my($self) = @_;
41             # uncoverable statement
42 0         0 return $VERSION;
43             }
44              
45             sub new {
46 79     79 1 654195 my($class,%options) = @_;
47              
48 79         908 my $self = {};
49              
50 79         1207 bless $self,$class;
51 79         1638 $self->flush();
52              
53 79         279 return $self;
54             }
55              
56             sub flush {
57 89     89 1 1799 my($self, @opts) = @_;
58              
59 89 100       1448 my $all = 1 if (! @opts);
60 89         600 my %opts = map { $_,1 } @opts;
  4         11  
61              
62             # $self = {
63             # 'g' => { VAR => VAL } global options
64             # 'c' => { VAR => VAL } per-command options
65             # 'e' => [ VAR, VAL ] environment
66             # 'o' => { out => STDOUT, output from script mode
67             # err => STDERR,
68             # exit => EXIT }
69             # 's' => { HOST => { out => STDOUT, output from ssh script mode
70             # err => STDERR,
71             # exit => EXIT } }
72             # 'curr' => NUM, the current command in
73             # the output method
74             # 'err' => ERROR,
75             # 'cmd' => { CMD_NUM => CMD_DESC } command descriptions
76             # 'cmd_num' => NUM
77             # 'max_alt' => NUM the greatest number of
78             # alternates
79             # 'scr' => [] the current script
80              
81 89         1787 $$self{'err'} = '';
82 89         990 $$self{'scr'} = [];
83              
84 89 100 100     5251 if ($all || $opts{'opts'}) {
85 86         8841 $$self{'g'} =
86             {
87             #
88             # Options set with the options method.
89             #
90              
91             'mode' => 'run',
92             'dire' => '',
93             'output' => 'both',
94             'script' => '',
95             'echo' => 'noecho',
96             'failure' => 'exit',
97              
98             'tmp_script' => "/tmp/.cmd.shell.$$",
99             'tmp_script_keep' => 0,
100             'ssh_script' => '',
101             'ssh_script_keep' => 0,
102              
103             'ssh_opts' => {},
104             'ssh_num' => 1,
105             'ssh_sleep' => 0,
106              
107             #
108             # A description of the script (calulated
109             # from some of the obove options in _script_options).
110             #
111             # s_type : Type of script currently being
112             # created.
113             # run, simple, script
114             # simple : Type of simple script currently being
115             # created.
116             # script : s_type = script
117             # failure : s_type = run, failure = display
118             # c_echo : mode=run: echo,noecho,failed
119             # otherwise: ''
120             # c_fail : How to treat command failure
121             # in the calculated environment.
122             # simple: ''
123             # otherwise: exit,display,continue
124             # out : 1 if STDOUT captured
125             # err : 1 if STDERR captured
126             # redir : String to redirect output
127             #
128              
129             's_type' => '',
130             'simple' => '',
131             'out' => 0,
132             'err' => 0,
133             'redir' => '',
134             'c_echo' => '',
135             'c_fail' => '',
136              
137             #
138             # Script indentation (used to keep track of
139             # all indentation)
140             #
141             'ind_per_lev' => 3,
142             'ind_cur_lev' => 0,
143             'curr_ind' => "",
144             'next_ind' => "",
145             'prev_ind' => "",
146              
147             #
148             # Keep track of current flow structure
149             # as commands are added (not used once
150             # they are done).
151             #
152             # ( [ FLOW, CMD_NUM ],
153             # [ FLOW, CMD_NUM ], ... )
154             # where:
155             # FLOW : type of flow
156             # CMD_NUM : command where it opened
157             #
158             'flow' => [],
159             };
160             }
161              
162 89 100 100     1009 if ($all || $opts{'commands'}) {
163             # cmd => { CMD_NUM => { 'meta' => VAL, (0 or a string)
164             # 'label' => LABEL,
165             # 'cmd' => [ CMD ],
166             # 'dire' => DIRE,
167             # 'noredir' => 0/1,
168             # 'retry' => NUM,
169             # 'sleep' => NUM,
170             # 'check' => CMD,
171             # 'flow' => if/loop/...
172             # 'flow_type' => open/cont/close
173             # }
174 86         365 $$self{'cmd'} = {};
175 86         343 $$self{'cmd_num'} = 1;
176 86         311 $$self{'max_alt'} = 0;
177             }
178              
179             # Command options
180             # c_flow 1 if this is a flow command
181             # c_num The number of the current command
182             # f_num The failure code (c_num if <=200, 201 otherwise)
183             # alts 1 if alternates are available
184             # a_num The number of the alternate
185             # c_label The label for the command
186             #
187             # c_retries The number of retries
188             # c_sleep How long to sleep between retries
189             # c_redir Redirect string for this command (takes into account
190             # noredir)
191             # c_check The command to check success
192             # c_check_q The quoted check command
193             # simp If the current command is in a simple script
194             #
195             # cmd_str The current command string
196             # e.g. '/bin/ls /tmp'
197             # cmd_str_q The quoted command string
198             # cmd_label A label describing the command (command number and
199             # command label if available):
200             # '1'
201             # '1 [LABEL]'
202             # alt_label A label describing the alternate
203             # '1.1'
204             # '1.1 [LABEL]'
205             # '1.0' (if no alternates)
206              
207 89         250 $$self{'c'} = {};
208              
209 89 100 100     924 $$self{'e'} = [] if ($all || $opts{'env'});
210              
211 89 100 100     622 if ($all || $opts{'out'}) {
212 86         307 $$self{'o'} = {};
213 86         568 $$self{'s'} = {};
214 86         367 $$self{'curr'} = 0;
215             }
216              
217 89         320 return;
218             }
219              
220             ###############################################################################
221             # METHODS TO SET OPTIONS
222             ###############################################################################
223              
224             sub dire {
225 6     6 1 31813 my($self,$dire) = @_;
226 6 100       20 return $$self{'g'}{'dire'} if (! defined($dire));
227              
228 2         5 return $self->options("dire",$dire);
229             }
230              
231             sub mode {
232 75     75 1 978 my($self,$mode) = @_;
233 75 100       405 return $$self{'g'}{'mode'} if (! defined($mode));
234              
235 2         4 return $self->options("mode",$mode);
236             }
237              
238             sub env {
239 19     19 1 902 my($self,@tmp) = @_;
240 19 100       88 return @{ $$self{'e'} } if (! @tmp);
  4         10  
241              
242 15         53 while (@tmp) {
243 30         54 my $var = shift(@tmp);
244 30         45 my $val = shift(@tmp);
245 30         44 push @{ $$self{'e'} },($var,$val);
  30         122  
246             }
247              
248 15         41 return;
249             }
250              
251             sub options {
252 233     233 1 8974 my($self,%opts) = @_;
253              
254             OPT:
255 233         1079 foreach my $opt (keys %opts) {
256              
257 312         980 my $val = $opts{$opt};
258 312         892 $opt = lc($opt);
259              
260 312 100 100     4204 if ($opt eq 'mode') {
    100 100        
    100 100        
    100 100        
    100          
    100          
    100          
    100          
    100          
261              
262 75 100       1505 if (lc($val) =~ /^(run|dry-run|script)$/) {
263 74         348 $$self{'g'}{$opt} = lc($val);
264 74         315 next OPT;
265             }
266              
267             } elsif ($opt eq 'dire') {
268 18         127 $$self{'g'}{$opt} = $self->_quote($val);
269 18         56 next OPT;
270              
271             } elsif ($opt eq 'output') {
272              
273 11 100       126 if (lc($val) =~ /^(both|merged|stdout|stderr|quiet)$/) {
274 10         48 $$self{'g'}{$opt} = lc($val);
275 10         39 next OPT;
276             }
277              
278             } elsif ($opt eq 'script') {
279              
280 27 100       365 if (lc($val) =~ /^(run|script|simple)$/) {
281 26         134 $$self{'g'}{$opt} = lc($val);
282 26         84 next OPT;
283             }
284              
285             } elsif ($opt eq 'echo') {
286              
287 4 100       22 if (lc($val) =~ /^(echo|noecho|failed)$/) {
288 3         13 $$self{'g'}{$opt} = lc($val);
289 3         8 next OPT;
290             }
291              
292             } elsif ($opt eq 'failure') {
293              
294 13 100       134 if (lc($val) =~ /^(exit|display|continue)$/) {
295 12         45 $$self{'g'}{$opt} = lc($val);
296 12         33 next OPT;
297             }
298              
299             } elsif ($opt =~ s/^ssh://) {
300 1         3 $$self{'g'}{'ssh_opts'}{$opt} = $val;
301 1         3 next OPT;
302              
303             } elsif ($opt eq 'ssh_num' ||
304             $opt eq 'ssh_sleep'
305             ) {
306 2         4 $$self{'g'}{$opt} = $val;
307 2         5 next OPT;
308              
309             } elsif ($opt eq 'tmp_script' ||
310             $opt eq 'tmp_script_keep' ||
311             $opt eq 'ssh_script' ||
312             $opt eq 'ssh_script_keep'
313             ) {
314 160         443 $$self{'g'}{$opt} = $val;
315 160         388 next OPT;
316              
317             } else {
318 1         4 $self->_err("Invalid option: $opt");
319 1         3 return 1;
320             }
321              
322 5         18 $self->_err("Invalid value: $opt [ $val ]");
323 5         16 return 1;
324             }
325              
326 227         807 return 0;
327             }
328              
329             ###############################################################################
330             # ADDING COMMANDS
331             ###############################################################################
332              
333             sub cmd {
334 483     483 1 7147 my($self,@args) = @_;
335              
336 483         1054 while (@args) {
337 484         726 my $cmd = shift(@args);
338 484         972 my $cmd_num = $$self{'cmd_num'}++;
339              
340 484 100 100     1311 if (ref($cmd) ne '' &&
341             ref($cmd) ne 'ARRAY') {
342 1         2 $$self{'err'} = "cmd must be a string or listref";
343 1         2 $self->_err($$self{'err'});
344 1         2 return 1;
345             }
346              
347 483         670 my %options;
348 483 100 100     1647 if (@args && ref($args[0]) eq 'HASH') {
349 106         209 %options = %{ shift(@args) };
  106         357  
350             }
351              
352 483         1249 foreach my $opt (keys %options) {
353 114 100       845 if ($opt !~ /^(dire|noredir|retry|sleep|check|label)$/) {
354 2         6 $$self{'err'} = "Invalid cmd option: $opt";
355 2         11 $self->_err($$self{'err'});
356 2         7 return 1;
357             }
358 112 100       329 if ($opt eq 'dire') {
359 3         69 $$self{'cmd'}{$cmd_num}{$opt} = $self->_quote($options{$opt});
360             } else {
361 109         892 $$self{'cmd'}{$cmd_num}{$opt} = $options{$opt};
362             }
363             }
364              
365             # Check if it is a flow command. Also, make sure that flow
366             # commands are properly opened, closed, and nested.
367              
368 481         1208 my $err = $self->_cmd_flow($cmd,$cmd_num);
369 481 100       989 return 1 if ($err);
370              
371             # If the command has alternates, update the max_alt value
372             # as necessary.
373              
374 475 100       856 if (ref($cmd) eq 'ARRAY') {
375 10         20 my $n = $#{ $cmd } + 1;
  10         28  
376 10 100       43 if ($n > $$self{'max_alt'}) {
377 9         21 $$self{'max_alt'} = $n;
378             }
379              
380 10         50 $$self{'cmd'}{$cmd_num}{'cmd'} = $cmd;
381              
382             } else {
383 465         2985 $$self{'cmd'}{$cmd_num}{'cmd'} = [ $cmd ];
384             }
385              
386             }
387 474         1175 return 0;
388             }
389              
390             #####################
391             # Check whether a command is a flow command
392              
393             sub _cmd_flow {
394 481     481   1011 my($self,$cmd,$cmd_num) = @_;
395              
396             # A flow command may not have alternatives, so it must be a single command.
397 481 100       922 return if (ref($cmd));
398              
399 471         668 my($flow,$type,$err);
400              
401             #
402             # Check to see if it is a flow command
403             #
404              
405 471 100 100     6901 if ($cmd =~ /^\s*(if)\s+.*?;\s*then\s*$/ ||
    100 100        
      100        
      100        
      100        
      100        
406             $cmd =~ /^\s*(elif)\s+.*?;\s*then\s*$/ ||
407             $cmd =~ /^\s*(else)\s*$/ ||
408             $cmd =~ /^\s*(fi)\s*$/) {
409 17         90 $flow = $1;
410              
411 17 100       64 if ($flow eq 'if') {
    100          
412 7         58 $err = $self->_cmd_open_flow($cmd_num,'if');
413 7         57 $$self{'cmd'}{$cmd_num}{'flow_type'} = 'open';
414             } elsif ($flow eq 'fi') {
415 3         18 $err = $self->_cmd_close_flow($cmd_num,'if','fi');
416 3         14 $$self{'cmd'}{$cmd_num}{'flow_type'} = 'close';
417             } else {
418 7         35 $err = $self->_cmd_cont_flow($cmd_num,'if',$flow);
419 7         29 $$self{'cmd'}{$cmd_num}{'flow_type'} = 'cont';
420             }
421 17         65 $$self{'cmd'}{$cmd_num}{'flow'} = 'if';
422              
423             } elsif ($cmd =~ /^\s*(while)\s+.*?;\s*do\s*$/ ||
424             $cmd =~ /^\s*(until)\s+.*?;\s*do\s*$/ ||
425             $cmd =~ /^\s*(for)\s+.*?;\s*do\s*$/ ||
426             $cmd =~ /^\s*(done)\s*$/) {
427 24         196 $flow = $1;
428              
429 24 100 100     254 if ($flow eq 'while' || $flow eq 'until' || $flow eq 'for') {
      100        
430 13         79 $err = $self->_cmd_open_flow($cmd_num,'loop [while|until|for]');
431 13         110 $$self{'cmd'}{$cmd_num}{'flow_type'} = 'open';
432             } else {
433 11         123 $err = $self->_cmd_close_flow($cmd_num,'loop [while|until|for]','done');
434 11         47 $$self{'cmd'}{$cmd_num}{'flow_type'} = 'close';
435             }
436 24         62 $$self{'cmd'}{$cmd_num}{'flow'} = 'loop';
437              
438             } else {
439 430         964 return 0;
440             }
441              
442             #
443             # Flow commands may not have the following options:
444             # dire, noredir, retry, check
445             #
446              
447 41         107 foreach my $opt ('dire','noredir','retry','check') {
448 158 100       367 if (exists $$self{'cmd'}{$cmd_num}{$opt}) {
449 4         16 $$self{'err'} = "$opt option not allowed with flow command: $cmd_num";
450 4         32 return 1;
451             }
452             }
453              
454 37 100       101 return 1 if ($err);
455 35         74 return 0;
456             }
457              
458             sub _cmd_curr_flow {
459 91     91   189 my($self) = @_;
460 91         156 my @flow = @{ $$self{'g'}{'flow'} };
  91         280  
461 91 100       535 return '' if (! @flow);
462 22         77 return $flow[$#flow]->[0];
463             }
464             sub _cmd_open_flow {
465 20     20   111 my($self,$cmd_num,$flow) = @_;
466              
467 20         38 push(@{ $$self{'g'}{'flow'} },
  20         129  
468             [$flow,$cmd_num]);
469              
470 20         59 return 0;
471             }
472             sub _cmd_close_flow {
473 14     14   66 my($self,$cmd_num,$flow,$close) = @_;
474              
475 14         63 my $curr_flow = $self->_cmd_curr_flow();
476 14 100       56 if ($flow ne $curr_flow) {
477 1         5 $$self{'err'} = "Broken flow: '$close' found, but no '$flow': $cmd_num";
478 1         4 return 1;
479             }
480              
481 13         23 pop(@{ $$self{'g'}{'flow'} });
  13         43  
482 13         38 return 0;
483             }
484             sub _cmd_cont_flow {
485 7     7   40 my($self,$cmd_num,$flow,$cont) = @_;
486              
487 7         29 my $curr_flow = $self->_cmd_curr_flow();
488 7 100       19 if ($flow ne $curr_flow) {
489 1         5 $$self{'err'} = "Broken flow: '$cont' found, but no '$flow': $cmd_num";
490 1         3 return 1;
491             }
492 6         10 return 0;
493             }
494             sub _cmd_valid_script {
495 71     71   172 my($self) = @_;
496              
497 71 100       298 return 1 if ($$self{'err'});
498 70         306 my $curr_flow = $self->_cmd_curr_flow();
499 70 100       241 if ($curr_flow) {
500 1         5 $$self{'err'} = "Broken flow: '$curr_flow' opened, but not closed";
501 1         3 return 1;
502             }
503 69         212 return 0;
504             }
505              
506             ###############################################################################
507             # RUN THE COMMANDS
508             ###############################################################################
509              
510             sub run {
511 71     71 1 123523 my($self) = @_;
512 71 100       368 if ($self->_cmd_valid_script()) {
513 2         19 $self->_err($$self{'err'});
514 2         7 return 252;
515             }
516 69         411 $self->_script();
517              
518             #
519             # Return the script if this is a dry run.
520             #
521              
522 69         171 my $script = join("\n",@{ $$self{'scr'} });
  69         2405  
523 69 100       465 return $script if ($$self{'g'}{'mode'} eq 'dry-run');
524              
525             #
526             # If it's running in real-time, do so.
527             #
528              
529 43         111 my $tmp_script = $$self{'g'}{'tmp_script'};
530 43 100       163 if (! $tmp_script) {
531 1         5 $self->_err("tmp_script option must be set");
532 1         7 return 254;
533             }
534              
535 42         612 my $out = new IO::File;
536              
537 42 100       2596 if ($out->open("> $tmp_script")) {
538 41         5953 print $out $script;
539 41         410 $out->close();
540             } else {
541 1         59 $self->_err("tmp_script not writable");
542 1         8 return 254;
543             }
544              
545 41         3350 my $err;
546 41 100       221 if ($$self{'g'}{'mode'} eq 'run') {
547 33         2282454 system(". $tmp_script");
548 33         1304 $err = $?;
549              
550 33 100       846 if (! $$self{'g'}{'tmp_script_keep'}) {
551 1         92 unlink($tmp_script);
552             }
553              
554 33         2611 return $err;
555             }
556              
557             #
558             # If it's running in 'script' mode, capture the output so that
559             # we can parse it.
560             #
561              
562 8         78 my($stdout,$stderr,$exit);
563              
564             # We will always keep at least one of STDOUT/STDERR because they contain the
565             # information necessary to see what commands run. In 'quiet' mode, the
566             # individual commands will discard all output, but the overall script will
567             # still use STDOUT.
568 8 100 100     95 if ($$self{'g'}{'out'} &&
    100          
569             $$self{'g'}{'err'}) {
570 5     5   577 ($stdout,$stderr,$exit) = capture { system( ". $tmp_script" ) };
  5         73105  
571             } elsif ($$self{'g'}{'err'}) {
572 1     1   88 ($stderr,$exit) = capture_stderr { system( ". $tmp_script" ) };
  1         5778  
573             } else {
574 2     2   186 ($stdout,$exit) = capture_stdout { system( ". $tmp_script" ) };
  2         12052  
575             }
576 8         8935 $exit = $exit >> 8;
577              
578 8 100       118 if (! $$self{'g'}{'tmp_script_keep'}) {
579 1         51 unlink($tmp_script);
580             }
581              
582 8 100       196 $$self{'o'}{'out'} = $self->_script_output($stdout) if ($stdout);
583 8 100       70 $$self{'o'}{'err'} = $self->_script_output($stderr) if ($stderr);
584 8         64 $$self{'o'}{'exit'} = $exit;
585              
586 8         131 return $exit;
587             }
588              
589             ###############################################################################
590             # CREATE THE SCRIPT
591             ###############################################################################
592              
593             sub _script {
594 69     69   182 my($self) = @_;
595 69         124 my(@ret);
596 69         523 $self->_script_options();
597 69         590 $self->_ind_0();
598              
599 69         123 while (1) {
600              
601             ##############################
602             # If needed, we'll generate a simple script.
603             #
604             # The simple script is used in two ways:
605             # o If a simple script is all that is needed, we'll use this
606             # to print out the list of commands that would run without
607             # all of the fancy error handling and I/O redirection.
608             # o If the 'failure' option is set to 'display', we'll build
609             # in a function to the script that will display the commands
610             # that should have run. This function will be called in
611             # the event of a failure.
612              
613 69 100       274 if ($$self{'g'}{'simple'}) {
614 6         24 $self->_script_init('simple');
615              
616 6         55 foreach my $cmd_num (1 .. $$self{'cmd_num'}-1) {
617 18         83 $self->_cmd_options($cmd_num,'simple');
618 18         68 $self->_script_cmd($cmd_num)
619             }
620              
621 6         25 $self->_script_term('simple');
622              
623 6 100       29 last if ($$self{'g'}{'simple'} eq 'simple');
624             }
625              
626             ##############################
627             # Now generate the full script
628              
629 67         427 $self->_script_init();
630              
631 67         670 foreach my $cmd_num (1 .. $$self{'cmd_num'}-1) {
632 454         1562 $self->_cmd_options($cmd_num);
633 454         1025 $self->_script_cmd($cmd_num)
634             }
635              
636 67         322 $self->_script_term();
637              
638 67         173 last;
639             }
640             }
641              
642             sub _script_init {
643 73     73   241 my($self,$simple) = @_;
644 73         153 my($text,$env,$text2);
645              
646 73 100       225 if ($simple) {
647 6         32 $$self{'c'}{'simp'} = $$self{'g'}{'simple'};
648             } else {
649 67         494 $$self{'c'}{'simp'} = '';
650             }
651              
652 73 100       299 if ($simple) {
653              
654 6         34 $text = <<'EOT';
655             : simple () {
656             : echo ""
657             : echo "#****************************************"
658             : if [ $SC_FAILED -eq 201 ]; then
659             : echo "# The following script failed after command 200"
660             : elif [ $SC_FAILED -gt 201 ]; then
661             : echo "# The following script failed during initialization"
662             : else
663             : echo "# The following script failed at command $SC_FAILED"
664             : fi
665             : while read line ;do
666             : echo "$line"
667             : done << SC_SIMPLE_EOS
668             : SC_ORIG_DIRE=`pwd`;
669             EOT
670              
671             } else {
672 67         369 $text = <<'EOT';
673             : SC_FAILED=0;
674             : echo "# SC_ORIG_DIRE=`pwd`";
675             : SC_ORIG_DIRE=`pwd`;
676             :
677             : main () {
678             EOT
679             }
680              
681 73         200 $env = <<'EOT';
682             : echo '# export =""';
683             : export ="";
684             EOT
685              
686 73         133 $text2 = <<'EOT';
687             : echo '# SC_DIRE=""';
688             : SC_DIRE="";
689             : echo '# cd "$SC_DIRE"';
690             : cd "$SC_DIRE";
691             : cd "$SC_DIRE" 2>/dev/null;
692             : if [ $? -ne 0 ]; then
693             : SC_FAILED=255;
694             : return;
695             : fi
696             : echo "# SC_DIRE=$SC_ORIG_DIRE";
697             : SC_DIRE=$SC_ORIG_DIRE;
698             EOT
699              
700 73         457 $self->_text_to_script($text);
701 73 100       486 $self->_ind_plus() if (! $simple);
702              
703 73         159 my(@tmp) = @{ $$self{'e'} };
  73         223  
704 73         296 while (@tmp) {
705 26         59 my $var = shift(@tmp);
706 26         45 my $val = shift(@tmp);
707 26         57 my $str = $env;
708 26         146 $str =~ s//$var/g;
709 26         109 $str =~ s//$val/g;
710 26         90 $self->_text_to_script($str);
711             }
712              
713 73         277 $self->_text_to_script($text2);
714             }
715              
716             sub _script_term {
717 73     73   185 my($self,$simple) = @_;
718 73         189 my($text);
719              
720 73 100       221 if ($simple) {
721 6         23 $$self{'c'}{'simp'} = $$self{'g'}{'simple'};
722 6         46 $text = <<'EOT';
723             : cd "$SC_ORIG_DIRE";
724             : SC_SIMPLE_EOS
725             : }
726             :
727             EOT
728              
729             } else {
730 67         244 $self->_ind_minus();
731 67         449 $text = <<'EOT';
732             : }
733             :
734             : main;
735             : cd "$SC_ORIG_DIRE";
736             : if [ $SC_FAILED -ne 0 ]; then
737             : simple;
738             : fi
739             : echo '# cd "$SC_ORIG_DIRE"';
740             : exit $SC_FAILED;
741             :
742             EOT
743             }
744              
745 73         347 $self->_text_to_script($text);
746             }
747              
748             #####################
749             # This analyzes the options and sets some variables to determine
750             # how the script behaves.
751             #
752             sub _script_options {
753 69     69   194 my($self) = @_;
754              
755             #
756             # Calculate the type of script that we're creating.
757             #
758             # In dry-run mode, we may produce any of the script types:
759             # simple, run, script
760             #
761             # In run/script mode, we will produce that type of script.
762             # We'll also produce a simple script for failure in 'run'
763             # mode if 'failure' is 'display'.
764             #
765              
766 69 100       276 if ($$self{'g'}{'mode'} eq 'dry-run') {
767 26 100       101 $$self{'g'}{'s_type'} = ($$self{'g'}{'script'} ? $$self{'g'}{'script'} : 'run');
768 26 100 100     234 if ($$self{'g'}{'script'} eq 'simple') {
    100          
769 2         4 $$self{'g'}{'simple'} = 'simple';
770             } elsif ($$self{'g'}{'s_type'} eq 'run' &&
771             $$self{'g'}{'failure'} eq 'display') {
772 2         5 $$self{'g'}{'simple'} = 'failure';
773             } else {
774 22         58 $$self{'g'}{'simple'} = '';
775             }
776             } else {
777 43         165 $$self{'g'}{'s_type'} = $$self{'g'}{'mode'};
778 43 100 100     483 if ($$self{'g'}{'s_type'} eq 'run' &&
779             $$self{'g'}{'failure'} eq 'display') {
780 2         6 $$self{'g'}{'simple'} = 'failure';
781             } else {
782 41         133 $$self{'g'}{'simple'} = '';
783             }
784             }
785              
786             #
787             # Echoing commands applies to run mode. In both dry-run and
788             # script mode, it doesn't apply.
789             #
790              
791 69 100       292 if ($$self{'g'}{'mode'} eq 'run') {
792 35         137 $$self{'g'}{'c_echo'} = $$self{'g'}{'echo'};
793             } else {
794 34         118 $$self{'g'}{'c_echo'} = '';
795             }
796              
797             #
798             # When a command fails, we normally handle it using the 'failure'
799             # option. In a simple script, we don't do failure handling.
800             #
801              
802 69 100       256 if ($$self{'g'}{'s_type'} eq 'simple') {
803 2         3 $$self{'g'}{'c_fail'} = '';
804             } else {
805 67         161 $$self{'g'}{'c_fail'} = $$self{'g'}{'failure'};
806             }
807              
808             #
809             # Analyze the 'output' option to determine whether we are capturing
810             # STDOUT and/or STDERR. Set the 'redir' flag to the appropriate
811             # string for performing this capture.
812             #
813             # 'simple' scripts do no redirection.
814             #
815             #
816             # If we ever want:
817             # STDOUT -> /dev/null, STDERR -> STDOUT:
818             # use:
819             # $$self{'c'}{'g_redir'} = '2>&1 >/dev/null';
820              
821 69 100 100     418 if ($$self{'g'}{'s_type'} eq 'run' ||
822             $$self{'g'}{'s_type'} eq 'script') {
823              
824 67 100       300 if ($$self{'g'}{'output'} eq 'both') {
    100          
    100          
    100          
825             # Capturing both so no redirection
826 59         150 $$self{'g'}{'redir'} = '';
827 59         128 $$self{'g'}{'out'} = 1;
828 59         130 $$self{'g'}{'err'} = 1;
829 59         447 $$self{'g'}{'quiet'} = 0;
830              
831             } elsif ($$self{'g'}{'output'} eq 'merged') {
832             # Merged output
833 1         3 $$self{'g'}{'redir'} = '2>&1';
834 1         2 $$self{'g'}{'out'} = 1;
835 1         14 $$self{'g'}{'err'} = 0;
836 1         7 $$self{'g'}{'quiet'} = 0;
837              
838             } elsif ($$self{'g'}{'output'} eq 'stdout') {
839             # Keep STDOUT, discard STDERR
840 2         8 $$self{'g'}{'redir'} = '2>/dev/null';
841 2         5 $$self{'g'}{'out'} = 1;
842 2         2 $$self{'g'}{'err'} = 0;
843 2         12 $$self{'g'}{'quiet'} = 0;
844              
845             } elsif ($$self{'g'}{'output'} eq 'stderr') {
846             # Discard STDOUT, keep STDERR
847 2         9 $$self{'g'}{'redir'} = '>/dev/null';
848 2         4 $$self{'g'}{'out'} = 0;
849 2         4 $$self{'g'}{'err'} = 1;
850 2         18 $$self{'g'}{'quiet'} = 0;
851              
852             } else {
853             # Discard everthing
854 3         11 $$self{'g'}{'redir'} = '>/dev/null 2>&1';
855 3         7 $$self{'g'}{'out'} = 0;
856 3         4 $$self{'g'}{'err'} = 0;
857 3         22 $$self{'g'}{'quiet'} = 1;
858             }
859              
860             } else {
861             # s_type = simple
862              
863 2         10 $$self{'g'}{'redir'} = '';
864 2         4 $$self{'g'}{'out'} = 1;
865 2         4 $$self{'g'}{'err'} = 1;
866              
867             }
868             }
869              
870             ###############################################################################
871             # ADD A COMMAND TO THE SCRIPT
872             ###############################################################################
873              
874             sub _script_cmd {
875 472     472   813 my($self,$cmd_num) = @_;
876              
877 472 100       1081 if ($$self{'cmd'}{$cmd_num}{'flow'}) {
878 30         85 $self->_script_cmd_flow($cmd_num);
879             } else {
880 442         974 $self->_script_cmd_nonflow($cmd_num);
881             }
882             }
883              
884             sub _script_cmd_flow {
885 30     30   65 my($self,$cmd_num) = @_;
886              
887 30         58 my $type = $$self{'cmd'}{$cmd_num}{'flow_type'};
888              
889 30 100       103 if ($type eq 'open') {
    100          
890 13         64 $self->_script_cmd_cmd();
891 13         39 $self->_ind_plus();
892             } elsif ($type eq 'cont') {
893 4         10 $self->_ind_minus();
894 4         8 $self->_script_cmd_cmd();
895 4         11 $self->_ind_plus();
896             } else {
897 13         40 $self->_ind_minus();
898 13         32 $self->_script_cmd_cmd();
899             }
900             }
901              
902             sub _script_cmd_nonflow {
903 442     442   778 my($self,$cmd_num) = @_;
904              
905 442         1111 $self->_script_cmd_init($cmd_num);
906 442         560 my $n = @{ $$self{'cmd'}{$cmd_num}{'cmd'} };
  442         922  
907              
908 442 100       880 if ($n > 1) {
909             # Command with alternates
910              
911 9         36 for (my $a=1; $a<= $n; $a++) {
912 24         85 $self->_alt_options($cmd_num,$a);
913 24         49 $self->_script_cmd_cmd();
914             }
915              
916             } else {
917             # Single command
918              
919 433         1070 $self->_script_cmd_cmd();
920             }
921              
922 442         1140 $self->_script_cmd_term($cmd_num);
923             }
924              
925             sub _script_cmd_init {
926 442     442   747 my($self,$cmd_num) = @_;
927              
928 442         665 my $text = <<'EOT';
929             : #
930             :
931             : #
932             : # Command
933             : #
934             :
935             : SC_CURR_EXIT=0;
936             : SC_CURR_SUCC=0;
937             :
938             : echo '# SC_DIRE_=`pwd`';
939             : echo '# cd ""';
940             : SC_DIRE_=`pwd`;
941             : cd "";
942             : cd "" 2>/dev/null;
943             : if [ $? -eq 0 ]; then
944             EOT
945              
946 442         918 $self->_text_to_script($text);
947              
948 442         740 $text = <<'EOT';
949             :
950             : SC_RETRIES=;
951             : SC_TRY=0;
952             : while [ $SC_TRY -lt $SC_RETRIES ]; do
953             EOT
954              
955 442         1000 $self->_text_to_script($text);
956 442 100 100     1573 $self->_ind_plus() if ($$self{'c'}{'c_retries'} && ! $$self{'c'}{'simp'});
957             }
958              
959             sub _script_cmd_term {
960 442     442   869 my($self,$cmd_num) = @_;
961              
962 442         942 my $text = <<'EOT';
963             :
964             : if [ $SC_CURR_EXIT -eq 0 ]; then
965             : break;
966             : fi
967             : SC_TRY=`expr $SC_TRY + 1`;
968             : if [ $SC_TRY -lt $SC_RETRIES ]; then
969             : sleep ;
970             : fi
971             : done
972             EOT
973              
974 442         1314 $self->_text_to_script($text);
975              
976 442         876 $text = <<'EOT';
977             :
978             : echo '# cd "$SC_DIRE_"';
979             : cd "$SC_DIRE_";
980             : else
981             : SC_CURR_EXIT=;
982             : fi
983             EOT
984              
985 442         1129 $self->_text_to_script($text);
986              
987 442         686 $text = <<'EOT';
988             :
989             : if [ $SC_FAILED -eq 0 -a $SC_CURR_EXIT -ne 0 ]; then
990             : SC_FAILED=;
991             : fi
992             :
993             : if [ $SC_FAILED -ne 0 ]; then
994             : return;
995             : fi
996             EOT
997              
998 442         926 $self->_text_to_script($text);
999             }
1000              
1001             sub _script_cmd_cmd {
1002 487     487   846 my($self) = @_;
1003 487         640 my($text);
1004              
1005             # Print out any header and echo the command as appropriate
1006              
1007 487 100       1111 if (! $$self{'c'}{'simp'}) {
1008 469 100       1021 if (! $$self{'c'}{'c_flow'}) {
1009 439         936 $text = <<'EOT';
1010             :
1011             : #
1012             : # Command
1013             : #
1014             :
1015             : if [ $SC_CURR_SUCC -eq 0 ]; then
1016             : echo "#SC CMD .";
1017             : echo "#SC CMD ." >&2;
1018             : echo "#SC CMD .";
1019             : echo "#SC TRY $SC_TRY";
1020             : echo "#SC TRY $SC_TRY" >&2;
1021             : fi
1022             :
1023             : echo "# ";
1024             : echo "# Check with: ";
1025             : echo "# ALT: ";
1026             : echo "# ";
1027             : echo "# Check with: ";
1028             EOT
1029              
1030 439         833 $self->_text_to_script($text);
1031             }
1032             }
1033              
1034             # We want to generate essentially the following script:
1035             #
1036             # CMD1
1037             # if [ "$?" != 0 ]; then
1038             # CMD2
1039             # fi
1040             # ...
1041             # if [ "$?" != 0 ]; then
1042             # CMDn
1043             # fi
1044             # if [ "$?" != 0 ]; then
1045             # exit X
1046             # fi
1047             #
1048             # where CMDn is the last alternate and X is the command number.
1049             #
1050             # If we have a 'check' option, we'll need to run that
1051             # command immediately after every CMDi.
1052             #
1053             # if command succeeded
1054             # SC_CURR_SUCC = 1 -> this will mean that no more alternates run
1055             # SC_CURR_EXIT = 0
1056             # else if this is the first alternate to fail
1057             # SC_CURR_EXIT = $? -> we'll use the first exit code if all alt. fail
1058             #
1059             # For script mode, make sure that both STDOUT and STDIN have a newline.
1060              
1061              
1062 487 100       1512 if ($$self{'c'}{'c_flow'}) {
    100          
1063 30         43 $text = <<'EOT';
1064             :
1065             :
1066             EOT
1067              
1068             } elsif ($$self{'c'}{'simp'}) {
1069 18         42 $text = <<'EOT';
1070             : ;
1071             EOT
1072              
1073             } else {
1074 439         703 $text = <<'EOT';
1075             :
1076             : if [ $SC_CURR_SUCC -eq 0 ]; then
1077             : ;
1078             : # CHECK WITH
1079             : ;
1080             : CMD_EXIT=$?;
1081             : echo "";
1082             : echo "" >&2;
1083             : if [ $CMD_EXIT -eq 0 ]; then
1084             : SC_CURR_SUCC=1;
1085             : SC_CURR_EXIT=0;
1086             : elif [ $SC_CURR_EXIT -eq 0 ]; then
1087             : SC_CURR_EXIT=$CMD_EXIT;
1088             : fi
1089             : if [ $CMD_EXIT -ne 0 ]; then
1090             : echo "#SC EXIT . $CMD_EXIT";
1091             : echo "#SC EXIT . $CMD_EXIT" >&2;
1092             : echo "#SC EXIT . $CMD_EXIT";
1093             : fi
1094             : fi
1095             EOT
1096             }
1097              
1098 487         1156 $self->_text_to_script($text);
1099             }
1100              
1101             ###################
1102              
1103             # Set cmd_str and cmd_pref for the current command.
1104             #
1105             sub _alt_options {
1106 24     24   57 my($self,$cmd_num,$alt_num) = @_;
1107 24         43 my $label = $$self{'c'}{'c_label'};
1108              
1109             #
1110             # Only called with a command with alternates.
1111             #
1112              
1113 24         75 $$self{'c'}{'cmd_str'} = $$self{'cmd'}{$cmd_num}{'cmd'}[$alt_num-1];
1114 24         57 $$self{'c'}{'cmd_str_q'} = $self->_quote($$self{'c'}{'cmd_str'});
1115 24 100       109 $$self{'c'}{'cmd_label'} = "$cmd_num" . ($label ? " [$label]" : '');
1116 24         72 $$self{'c'}{'alt_label'} = "$cmd_num.$alt_num";
1117 24         36 $$self{'c'}{'alts'} = 1;
1118 24         47 $$self{'c'}{'a_num'} = $alt_num;
1119             }
1120              
1121             sub _cmd_options {
1122 472     472   944 my($self,$cmd_num,$simple) = @_;
1123              
1124 472         1003 $$self{'c'}{'c_num'} = $cmd_num;
1125 472 100       1116 $$self{'c'}{'f_num'} = ($cmd_num > 200 ? 201 : $cmd_num);
1126 472         1399 $$self{'c'}{'c_label'} = $$self{'cmd'}{$cmd_num}{'label'};
1127              
1128             $$self{'c'}{'c_retries'} = ($$self{'cmd'}{$cmd_num}{'retry'}
1129 472 100       1309 ? $$self{'cmd'}{$cmd_num}{'retry'}+0
1130             : 0);
1131             $$self{'c'}{'c_sleep'} = ($$self{'cmd'}{$cmd_num}{'sleep'}
1132 472 100       1101 ? $$self{'cmd'}{$cmd_num}{'sleep'}+0
1133             : 0);
1134             $$self{'c'}{'c_redir'} = (($$self{'cmd'}{$cmd_num}{'noredir'} ||
1135             $simple ||
1136             ! $$self{'g'}{'redir'})
1137             ? ''
1138 472 100 100     3166 : ' ' . $$self{'g'}{'redir'} );
1139             $$self{'c'}{'c_check'} = ($$self{'cmd'}{$cmd_num}{'check'}
1140 472 100       1312 ? $$self{'cmd'}{$cmd_num}{'check'}
1141             : '');
1142 472         1108 $$self{'c'}{'c_check_q'} = $self->_quote($$self{'c'}{'c_check'});
1143             $$self{'c'}{'c_dir'} = ($$self{'cmd'}{$cmd_num}{'dire'}
1144 472 100       1145 ? $self->_quote($$self{'cmd'}{$cmd_num}{'dire'})
1145             : '');
1146              
1147 472 100       1095 $$self{'c'}{'c_retries'} = 0 if ($$self{'c'}{'c_retries'} == 1);
1148              
1149 472         859 $$self{'c'}{'ind'} = $$self{'g'}{'curr_ind'};
1150 472 100       992 $$self{'c'}{'simp'} = $$self{'g'}{'simple'} if ($simple);
1151              
1152 472 100       1156 $$self{'c'}{'c_flow'} = ($$self{'cmd'}{$cmd_num}{'flow'} ? 1 : 0);
1153              
1154             # Handle the cases of a command with no alternates and init stuff
1155              
1156 472         675 my $n = @{ $$self{'cmd'}{$cmd_num}{'cmd'} };
  472         842  
1157              
1158 472 100       1089 if ($n == 1) {
1159             #
1160             # A command with no alternates.
1161             #
1162              
1163 463         728 my $label = $$self{'c'}{'c_label'};
1164 463         978 $$self{'c'}{'cmd_str'} = $$self{'cmd'}{$cmd_num}{'cmd'}[0];
1165 463         938 $$self{'c'}{'cmd_str_q'} = $self->_quote($$self{'c'}{'cmd_str'});
1166 463 100       1385 $$self{'c'}{'cmd_label'} = $cmd_num . ($label ? " [$label]" : '');
1167 463         1083 $$self{'c'}{'alt_label'} = "$cmd_num.0";
1168 463         770 $$self{'c'}{'alts'} = 0;
1169 463         841 $$self{'c'}{'a_num'} = 0;
1170             }
1171             }
1172              
1173             ###############################################################################
1174              
1175             # Text to script
1176              
1177             sub _text_to_script {
1178 3381     3381   5125 my($self,$text) = @_;
1179 3381         4039 my @script;
1180              
1181             # Text is a combination of:
1182             # : CMD
1183             # : CMD
1184             # : CMD
1185             # : CMD
1186             # : CMD
1187             #
1188             # means to include this line only if the given TAG has a value
1189             # of 'VAL'. The TAG can be either of:
1190             # $$self{'c'}{TAG}
1191             # $$self{'g'}{TAG}
1192             # means to include this line only if the given TAG does NOT
1193             # have a value of 'VAL'
1194             # means to include this line only if the TAG has a true value
1195             # means to include this line only if the TAG has a false value
1196             # CMD can include indentation relative to the current text
1197             # CMD can include and it will be replaced by the
1198             # value of TAG
1199             #
1200             # Every line must contain a colon, and the colon defines the start of
1201             # the actual line (so spacing to the right of the colon is used to
1202             # determine indentation).
1203              
1204 3381         15277 my @lines = split(/\n/,$text);
1205 3381         4859 my $line_ind = '';
1206              
1207             LINE:
1208 3381         5281 foreach my $line (@lines) {
1209 37292         133457 $line =~ /(.*?)\s*:(\s*)(.*)$/;
1210 37292         92103 my($tags,$ind,$cmd) = ($1,$2,$3);
1211              
1212 37292         115112 while ($tags =~ s,^<(!?)(.*?)>,,) {
1213 37759         80534 my ($not,$tagstr) = ($1,$2);
1214 37759 100       75138 if ($tagstr =~ /^(.*?)=(.*)$/) {
1215 11902         23084 my($tag,$req) = ($1,$2);
1216 11902 100       18555 if ($self->_tagval($tag) eq $req) {
1217 731 100       2322 next LINE if ($not);
1218             } else {
1219 11171 100       25065 next LINE if (! $not);
1220             }
1221              
1222             } else {
1223 25857         31604 my $tag = $tagstr;
1224 25857 100       38399 if ($self->_tagval($tag)) {
1225 1168 100       2895 next LINE if ($not);
1226             } else {
1227 24689 100       66720 next LINE if (! $not);
1228             }
1229             }
1230             }
1231              
1232 14505         27356 while ($cmd =~ /<\?(.*?)\?>/) {
1233 2552         4739 my $tag = $1;
1234 2552         4237 my $val = $self->_tagval($tag);
1235 2552         36292 $cmd =~ s/<\?$tag\?>/$val/g;
1236             }
1237              
1238 14505 100       22342 if (! $cmd) {
1239 2867         4609 push(@script,'');
1240 2867         4790 next;
1241             }
1242              
1243 11638         13968 my $len = length($ind);
1244 11638 100       18521 $line_ind = $len if ($line_ind eq '');
1245              
1246 11638 100       20419 if ($len > $line_ind) {
    100          
1247 2278         4971 $self->_ind_plus();
1248 2278         2940 $line_ind = $len;
1249             } elsif ($len < $line_ind) {
1250 2296         4719 $self->_ind_minus();
1251 2296         2928 $line_ind = $len;
1252             }
1253 11638         16104 my $spc = $$self{'g'}{'curr_ind'};
1254 11638         27546 push(@script,"${spc}$cmd");
1255             }
1256              
1257 3381         4095 push @{ $$self{'scr'} },@script;
  3381         14457  
1258             }
1259              
1260             sub _tagval {
1261 40311     40311   56158 my($self,$tag) = @_;
1262              
1263 40311         43137 my $val;
1264 40311 100       71869 if (exists $$self{'c'}{$tag}) {
    100          
1265 22070         29257 $val = $$self{'c'}{$tag};
1266             } elsif (exists $$self{'g'}{$tag}) {
1267 12495         16905 $val = $$self{'g'}{$tag};
1268             }
1269              
1270 40311 100       62320 $val = '' if (! defined($val));
1271 40311         71840 return $val;
1272             }
1273              
1274             #####################
1275             # Script indentation
1276              
1277             sub _ind {
1278 4829     4829   6211 my($self) = @_;
1279             $$self{'g'}{'curr_ind'} =
1280 4829         9766 " "x($$self{'g'}{'ind_per_lev'} * $$self{'g'}{'ind_cur_lev'});
1281             $$self{'g'}{'next_ind'} =
1282 4829         8735 " "x($$self{'g'}{'ind_per_lev'} * ($$self{'g'}{'ind_cur_lev'} + 1));
1283             $$self{'g'}{'prev_ind'} =
1284             " "x($$self{'g'}{'ind_cur_lev'} == 0
1285             ? 0
1286 4829 100       11709 : $$self{'g'}{'ind_per_lev'} * ($$self{'g'}{'ind_cur_lev'} - 1));
1287             }
1288              
1289             sub _ind_0 {
1290 69     69   187 my($self) = @_;
1291 69         161 $$self{'g'}{'ind_cur_lev'} = 0;
1292 69         437 $self->_ind();
1293             }
1294              
1295             sub _ind_plus {
1296 2380     2380   3528 my($self) = @_;
1297 2380         3260 $$self{'g'}{'ind_cur_lev'}++;
1298 2380         4016 $self->_ind();
1299             }
1300             sub _ind_minus {
1301 2380     2380   3253 my($self) = @_;
1302 2380         3227 $$self{'g'}{'ind_cur_lev'}--;
1303 2380         3485 $self->_ind();
1304             }
1305              
1306             ###############################################################################
1307              
1308             sub _err {
1309 13     13   28 my($self,$text) = @_;
1310              
1311             # uncoverable branch false
1312 13 100       38 if ($ENV{'SHELL_CMD_TESTING'}) {
1313 8         10 return;
1314             }
1315              
1316 5         132 print STDERR "# ERROR: ${text}\n";
1317 5         25 return;
1318             }
1319              
1320             # This prepares a string to be enclosed in double quotes.
1321             #
1322             # Escape: \ $ ` "
1323             #
1324             sub _quote {
1325 981     981   1486 my($self,$string) = @_;
1326              
1327 981         1969 $string =~ s/([\\\$`"])/\\$1/g;
1328 981         1968 return $string;
1329             }
1330              
1331             ###############################################################################
1332             # The stdout/stderr from a script-mode run are each of the form:
1333             # #SC CMD N1.A1
1334             # ...
1335             # #SC CMD N2.A2
1336             # ...
1337             # where N* are the command number and A* are the alternate number.
1338             #
1339             # Retries are noted with:
1340             # #SC TRY T
1341             #
1342             # If the script fails, for the failing command, it includes:
1343             # #SC EXIT N1.A1 EXIT_VALUE
1344             #
1345             # STDOUT and STDERR are guaranteed to be identical in form (provided both
1346             # are kept).
1347             #
1348             sub _script_output {
1349 13     13   89 my($self,$out) = @_;
1350 13         143 my @out = split(/\n/,$out);
1351              
1352             #
1353             # Parse stdout and turn it into:
1354             #
1355             # ( [ CMD_NUM_1, ALT_NUM_1, TRY_1, EXIT_1, STDOUT_1 ],
1356             # [ CMD_NUM_2, ALT_NUM_2, TRY_2, EXIT_2, STDOUT_2 ], ... )
1357             #
1358              
1359 13         50 my @cmd_raw;
1360              
1361             PARSE_LOOP:
1362 13         81 while (@out) {
1363              
1364             #
1365             # Get STDOUT (or STDERR) for the one command.
1366             #
1367              
1368 50         150 my($cmd_num,$alt_num,$cmd_exit,$cmd_try,$tmp);
1369 50         0 my($out_hdr,@output);
1370 50         76 $cmd_exit = 0;
1371 50         85 $cmd_try = 0;
1372              
1373 50         87 $out_hdr = shift(@out);
1374              
1375             # The output MUST start with a header:
1376             # #SC CMD X.Y
1377             #
1378             # uncoverable branch true
1379 50 50       346 if ($out_hdr !~ /^\#SC CMD (\d+)\.(\d+)$/) {
1380             # Invalid output... should never happen
1381             # uncoverable statement
1382 0         0 $self->_err("Missing command header in STDOUT: $out_hdr");
1383             # uncoverable statement
1384 0         0 return ();
1385             }
1386              
1387 50         238 ($cmd_num,$alt_num) = ($1,$2);
1388              
1389 50   100     284 while (@out && $out[0] !~ /^\#SC CMD (\d+)\.(\d+)$/) {
1390 114 100       1013 if ($out[0] =~ /^\#SC TRY (\d+)$/) {
    100          
1391 20         32 $cmd_try = $1;
1392 20         75 shift(@out);
1393              
1394             } elsif ($out[0] =~ /^\#SC EXIT $cmd_num\.$alt_num (\d+)$/) {
1395 20         39 $cmd_exit = $1;
1396 20         76 shift(@out);
1397              
1398             } else {
1399 74         363 push(@output,shift(@out));
1400             }
1401             }
1402              
1403 50 100 100     246 pop(@output) if (! defined($output[$#output]) || $output[$#output] eq '');
1404 50         308 push (@cmd_raw, [ $cmd_num,$alt_num,$cmd_try,$cmd_exit,\@output ]);
1405             }
1406              
1407             #
1408             # Now go through this list and group all alternates together and determine
1409             # the status for each command.
1410             #
1411             # This will now look like:
1412             # ( CMD_1 CMD_2 ... )
1413             # where
1414             # CMD_i = [ CMD_NUM EXIT TRY_1 TRY_2 ... ]
1415             # CMD_NUM is the command number being executed
1416             # EXIT is the exit code produced by this command
1417             # TRY_i is the i'th retry (there will only be one if
1418             # the command does not have retries
1419             #
1420             # TRY_i = [ ALT_1 ALT_2 ... ]
1421             # ALT_i = [ LINE1 LINE2 ... ] the output
1422             #
1423             # The exit code is the one produced by the very first alternate in the first
1424             # try.
1425             #
1426             # When looking at a command (I), we have to take into account the following
1427             # command (J = I+1).
1428             #
1429             # I J
1430             # CMD ALT TRY CMD ALT TRY
1431             #
1432             # * * * * 0/1 0 The next command is from a totally new
1433             # command, so the current command concludes
1434             # a retry and a command.
1435             #
1436             # C A T C A+1 T The next command is another alternate.
1437             # Add it to the current retry.
1438             #
1439             # C A T C 0/1 T+1 The next command starts another retry,
1440             # so the current command concludes a
1441             # retry, but NOT a command.
1442             #
1443             # Everthing else is an error
1444             #
1445              
1446 13         43 my @cmds = (); # @cmds = ( CMD_1 CMD_2 ... )
1447 13         29 my @cmd = (); # @cmd = ( TRY_1 TRY_2 ... )
1448 13         37 my @try = (); # @try = ( ALT_1 ALT_2 ... )
1449 13         35 my $alt; # $alt = [ LINE_1 LINE_2 ... ]
1450 13         30 my $cmd_curr = 0;
1451 13         27 my $alt_curr = 0;
1452 13         36 my $try_curr = 0;
1453 13         51 my $cmd_next = 0;
1454 13         22 my $alt_next = 0;
1455 13         25 my $try_next = 0;
1456 13         22 my $exit_curr = 0;
1457 13         20 my $exit_next = 0;
1458 13         23 my $i = 0;
1459              
1460 13         43 ($cmd_curr,$alt_curr,$try_curr,$exit_curr,$alt) = @{ shift(@cmd_raw) };
  13         52  
1461 13         36 push(@try,$alt);
1462              
1463             COMMAND_LOOP:
1464 13         42 while (@cmd_raw) {
1465 37         74 $i++;
1466              
1467 37         65 ($cmd_next,$alt_next,$try_next,$exit_next,$alt) = @{ shift(@cmd_raw) };
  37         82  
1468              
1469             VALID_CONDITIONS: {
1470              
1471             ## ALT_NEXT = 0/1 and
1472             ## TRY_NEXT = 0
1473             ## next command
1474             ##
1475             ## All valid CMD_NEXT != CMD_CURR entries will be covered here.
1476              
1477 37 100 100     73 if ($alt_next <= 1 &&
  37         188  
1478             $try_next == 0) {
1479              
1480 21         72 push(@cmd,[@try]);
1481 21         48 push(@cmds,[$cmd_curr,$exit_curr,@cmd]);
1482 21         34 @cmd = ();
1483 21         43 @try = ($alt);
1484 21         44 $cmd_curr = $cmd_next;
1485 21         40 $alt_curr = $alt_next;
1486 21         33 $try_curr = $try_next;
1487 21         37 $exit_curr= $exit_next;
1488 21         97 next COMMAND_LOOP;
1489             }
1490              
1491             # uncoverable branch true
1492 16 50       37 if ($cmd_next != $cmd_curr) {
1493             # uncoverable statement
1494 0         0 last VALID_CONDITIONS;
1495             }
1496              
1497             ## ALT_NEXT = ALT_CURR+1
1498             ## next alternate
1499             ##
1500             ## All valid entries will have TRY_NEXT = TRY_CURR
1501              
1502 16 100       33 if ($alt_next == $alt_curr+1) {
1503              
1504             # uncoverable branch true
1505 8 50       14 if ($try_next != $try_curr) {
1506             # uncoverable statement
1507 0         0 last VALID_CONDITIONS;
1508             }
1509              
1510 8         15 push(@try,$alt);
1511 8         10 $alt_curr = $alt_next;
1512 8         9 $exit_curr= $exit_next;
1513 8         21 next COMMAND_LOOP;
1514             }
1515              
1516             ## ALT_NEXT = 0/1 and
1517             ## TRY_NEXT = TRY_CURR+1
1518             ## next try
1519             ##
1520             ## Everything left must have both of these conditions.
1521              
1522             # uncoverable branch true
1523 8 50       15 if ($alt_next > 1) {
1524             # uncoverable statement
1525 0         0 last VALID_CONDITIONS;
1526             }
1527              
1528             # uncoverable branch true
1529 8 50       19 if ($try_next != $try_curr+1) {
1530             # uncoverable statement
1531 0         0 last VALID_CONDITIONS;
1532             }
1533              
1534 8         18 push(@cmd,[@try]);
1535 8         15 @try = ($alt);
1536 8         10 $alt_curr = $alt_next;
1537 8         11 $try_curr = $try_next;
1538 8         12 $exit_curr= $exit_next;
1539 8         13 next COMMAND_LOOP;
1540             }
1541              
1542             #
1543             # Everything else is an error in the output (should never happen)
1544             #
1545              
1546             # uncoverable statement
1547 0         0 $self->_err("Unexpected error in output: $i " .
1548             "[$cmd_curr,$alt_curr,$try_curr] " .
1549             "[$cmd_next,$alt_next,$try_next]");
1550             # uncoverable statement
1551 0         0 return ();
1552             }
1553              
1554             #
1555             # Add on the last command is stored.
1556             #
1557              
1558 13         45 push(@cmd,[@try]);
1559 13         38 push(@cmds,[$cmd_curr,$exit_curr,@cmd]);
1560              
1561 13         142 return [@cmds];
1562             }
1563              
1564             ###############################################################################
1565              
1566             sub ssh {
1567 0     0 1 0 my($self,@hosts) = @_;
1568              
1569 0 0       0 if (! @hosts) {
1570 0         0 $self->_err("A host or hosts must be supplied with the ssh method");
1571 0         0 return;
1572             }
1573              
1574 0 0       0 if ($self->_cmd_valid_script()) {
1575 0         0 $self->_err("script flow commands not closed correctly");
1576 0         0 return;
1577             }
1578 0         0 $self->_script();
1579              
1580             #
1581             # Return the script if this is a dry run.
1582             #
1583              
1584 0         0 my $script = join("\n",@{ $$self{'scr'} });
  0         0  
1585 0 0       0 return $script if ($$self{'g'}{'mode'} eq 'dry-run');
1586              
1587             #
1588             # Create the temporary script
1589             #
1590              
1591 0         0 my $tmp_script = $$self{'g'}{'tmp_script'};
1592 0 0       0 if (! $tmp_script) {
1593 0         0 $self->_err("tmp_script option must be set");
1594 0         0 return 254;
1595             }
1596              
1597 0         0 my $out = new IO::File;
1598              
1599 0 0       0 if ($out->open("> $tmp_script")) {
1600 0         0 print $out $script;
1601 0         0 $out->close();
1602             } else {
1603 0         0 $self->_err("tmp_script not writable");
1604 0         0 return 254;
1605             }
1606              
1607             #
1608             # Run the script
1609             #
1610              
1611 0         0 my %ret;
1612 0 0       0 if ($$self{'g'}{'ssh_num'} == 1) {
1613 0         0 %ret = $self->_ssh_serial(@hosts);
1614             } else {
1615 0         0 %ret = $self->_ssh_parallel(@hosts);
1616             }
1617              
1618 0 0       0 if (! $$self{'g'}{'tmp_script_keep'}) {
1619 0         0 unlink($tmp_script);
1620             }
1621              
1622 0         0 return %ret;
1623             }
1624              
1625             sub _ssh_serial {
1626 0     0   0 my($self,@hosts) = @_;
1627 0         0 my %ret;
1628              
1629 0         0 foreach my $host (@hosts) {
1630 0         0 $ret{$host} = $self->_ssh($host);
1631             }
1632              
1633 0         0 return %ret;
1634             }
1635              
1636             sub _ssh_parallel {
1637 0     0   0 my($self,@hosts) = @_;
1638 0         0 my %ret;
1639              
1640 0 0       0 my $max_proc = ($$self{'g'}{'ssh_num'} ? $$self{'g'}{'ssh_num'} : @hosts);
1641 0         0 my $manager = Parallel::ForkManager->new($max_proc);
1642              
1643             $manager->run_on_finish
1644             (
1645             sub {
1646 0     0   0 my($pid,$exit_code,$id,$signal,$core_dump,$data) = @_;
1647 0         0 my($host,$exit,$stdout,$stderr) = @$data;
1648 0         0 $ret{$host} = $exit;
1649 0 0       0 $$self{'s'}{$host}{'out'} = $self->_script_output($stdout)
1650             if (defined $stdout);
1651 0 0       0 $$self{'s'}{$host}{'err'} = $self->_script_output($stderr)
1652             if (defined $stderr);
1653 0         0 $$self{'s'}{$host}{'exit'} = $exit;
1654             }
1655 0         0 );
1656              
1657 0         0 foreach my $host (@hosts) {
1658 0 0       0 $manager->start and next;
1659              
1660 0         0 my @r = ($host,$self->_ssh($host));
1661              
1662 0         0 $manager->finish(0,\@r);
1663             }
1664              
1665 0         0 $manager->wait_all_children();
1666 0         0 return %ret;
1667             }
1668              
1669             sub _ssh {
1670 0     0   0 my($self,$host) = @_;
1671              
1672 0         0 my $ssh = Net::OpenSSH->new($host, %{ $$self{'g'}{'ssh_opts'} });
  0         0  
1673              
1674 0         0 my $script_loc = $$self{'g'}{'tmp_script'};
1675 0   0     0 my $script_rem = $$self{'g'}{'ssh_script'} || $script_loc;
1676 0 0       0 $ssh->scp_put($script_loc,$script_rem) or return 253;
1677              
1678             #
1679             # If we're sleeping, do so.
1680             #
1681              
1682 0 0       0 if ($$self{'g'}{'ssh_sleep'}) {
1683 0         0 my $n = $$self{'g'}{'ssh_sleep'};
1684 0 0       0 if ($n < 0) {
1685 0         0 sleep(-$n);
1686             } else {
1687 0         0 sleep(int(rand($$self{'g'}{'ssh_sleep'})));
1688             }
1689             }
1690              
1691             #
1692             # If it's running in real-time, do so.
1693             #
1694              
1695 0 0       0 if ($$self{'g'}{'mode'} eq 'run') {
1696 0         0 $ssh->system({},". $script_rem");
1697 0         0 my $ret = $?;
1698              
1699 0 0       0 if (! $$self{'g'}{'ssh_script_keep'}) {
1700 0         0 $ssh->system({},"rm -f $script_rem");
1701             }
1702 0         0 return ($ret);
1703             }
1704              
1705             #
1706             # If it's running in script mode, do so.
1707             #
1708              
1709 0         0 my($stdout,$stderr,$exit);
1710              
1711 0 0       0 if ($$self{'g'}{'err'}) {
    0          
1712 0         0 ($stdout,$stderr) = $ssh->capture2({},". $script_rem");
1713 0 0       0 $stdout = undef if (! $$self{'g'}{'out'});
1714             } elsif ($$self{'g'}{'out'}) {
1715 0         0 $stdout = $ssh->capture({},". $script_rem");
1716             } else {
1717 0         0 $ssh->system({},". $script_rem");
1718             }
1719 0         0 $exit = $?;
1720 0         0 $exit = $exit >> 8;
1721              
1722 0 0       0 if (! $$self{'g'}{'ssh_script_keep'}) {
1723 0         0 $ssh->system({},"rm -f $script_rem");
1724             }
1725              
1726 0         0 return ($exit,$stdout,$stderr);
1727             }
1728              
1729             ###############################################################################
1730              
1731             sub output {
1732 141     141 1 160314 my($self,%options) = @_;
1733              
1734 141 50       330 my $host = (exists $options{'host'} ? $options{'host'} : '');
1735 141 50       275 my $type = (exists $options{'output'} ? $options{'output'} : 'stdout');
1736 141 50       242 my $cmd = (exists $options{'command'} ? $options{'command'} : 'curr');
1737              
1738 141 50       693 if ($type !~ /^(stdout|stderr|command|num|label|exit)$/) {
1739 0         0 $self->_err("Invalid output option: output=$type");
1740 0         0 return;
1741             }
1742              
1743             #
1744             # Output from ssh method
1745             #
1746              
1747 141 50       254 if ($host) {
1748 0         0 my @all = keys %{ $$self{'s'} };
  0         0  
1749 0 0       0 if (! @all) {
1750 0         0 $self->_err("Invalid option in output: " .
1751             "host not allowed unless run with ssh method");
1752 0         0 return;
1753             }
1754              
1755             # host = all
1756             # host = HOST,HOST,...
1757              
1758 0 0 0     0 if ($host eq 'all' || $host =~ /,/) {
1759 0         0 my %ret;
1760 0 0       0 my @host = ($host eq 'all'
1761             ? @all
1762             : split(/,/,$host));
1763              
1764 0         0 foreach my $host (@host) {
1765 0 0       0 if (! exists $$self{'s'}{$host}) {
1766 0         0 $self->_err("Host has no output: $host");
1767 0         0 next;
1768             }
1769              
1770 0         0 $ret{$host} = [ $self->_output($type,$cmd,$$self{'s'}{$host}) ];
1771             }
1772 0         0 return %ret;
1773             }
1774              
1775             # host = HOST
1776              
1777 0 0       0 if (! exists $$self{'s'}{$host}) {
1778 0         0 $self->_err("Host has no output: $host");
1779 0         0 return;
1780             }
1781 0         0 return $self->_output($type,$cmd,$$self{'s'}{$host});
1782             }
1783              
1784             #
1785             # Output from run method
1786             #
1787              
1788 141         332 return $self->_output($type,$cmd,$$self{'o'});
1789             }
1790              
1791             sub _output {
1792 141     141   256 my($self,$type,$cmd,$output) = @_;
1793              
1794             #
1795             # Figure out which output sections need to be returned.
1796             #
1797              
1798 141         165 my @c;
1799 141 100       259 my $no = (exists $$output{'out'} ? @{ $$output{'out'} } : 0);
  116         178  
1800 141 100       228 my $ne = (exists $$output{'err'} ? @{ $$output{'err'} } : 0);
  91         135  
1801 141 100       229 my $max = ($no > $ne ? $no : $ne);
1802              
1803 141 100       444 if ($cmd eq 'curr') {
    100          
    100          
    100          
    50          
1804 26         43 push @c,$$self{'curr'};
1805              
1806             } elsif ($cmd eq 'next') {
1807 5         17 $$self{'curr'}++;
1808 5         12 push @c,$$self{'curr'};
1809              
1810             } elsif ($cmd eq 'all') {
1811 43         127 push @c, (0 .. ($max-1));
1812              
1813             } elsif ($cmd eq 'fail') {
1814             # Find the command that failed.
1815              
1816 38         88 foreach my $i (0 .. ($max-1)) {
1817 86 100 66     305 if (exists $$output{'out'} && defined $$output{'out'}[$i]) {
    50 33        
1818 74 100       161 if ($$output{'out'}[$i][1]) {
1819 9         15 push(@c,$i);
1820 9         14 last;
1821             }
1822              
1823             } elsif (exists $$output{'err'} && defined $$output{'err'}[$i]) {
1824 12 50       23 if ($$output{'err'}[$i][1]) {
1825 0         0 push(@c,$i);
1826 0         0 last;
1827             }
1828             }
1829             }
1830              
1831             } elsif ($cmd =~ /^\d+$/) {
1832             # CMD_NUM
1833              
1834 29         74 foreach my $i (0 .. ($max-1)) {
1835 68 100 66     232 if (exists $$output{'out'} && defined $$output{'out'}[$i]) {
    50 33        
1836 56 100       115 if ($$output{'out'}[$i][0] eq $cmd) {
1837 23         39 push(@c,$i);
1838             }
1839              
1840             } elsif (exists $$output{'err'} && defined $$output{'err'}[$i]) {
1841 12 100       25 if ($$output{'err'}[$i][0] eq $cmd) {
1842 6         8 push(@c,$i);
1843             }
1844             }
1845             }
1846              
1847             } else {
1848             # LABEL
1849              
1850 0         0 foreach my $i (0 .. ($max-1)) {
1851 0 0 0     0 if (exists $$output{'out'} && defined $$output{'out'}[$i]) {
    0 0        
1852 0         0 my $n = $$output{'out'}[$i][0];
1853 0 0       0 if ($$self{'cmd'}{$n}{'label'} eq $cmd) {
1854 0         0 push(@c,$i);
1855             }
1856              
1857             } elsif (exists $$output{'err'} && defined $$output{'err'}[$i]) {
1858 0         0 my $n = $$output{'err'}[$i][0];
1859 0 0       0 if ($$self{'cmd'}{$n}{'label'} eq $cmd) {
1860 0         0 push(@c,$i);
1861             }
1862             }
1863             }
1864             }
1865              
1866 141 100       336 return if (! @c);
1867              
1868             #
1869             # Now gather up the stuff to return.
1870             #
1871              
1872 112         150 my @ret;
1873              
1874 112         193 foreach my $i (@c) {
1875 175 100       499 if ($type eq 'stdout') {
    100          
    100          
    100          
    100          
    50          
1876 31         58 my @r;
1877 31 100 66     164 if (exists $$output{'out'} && defined $$output{'out'}[$i]) {
1878 27         42 my @tmp = @{ $$output{'out'}[$i] };
  27         116  
1879 27         47 shift(@tmp);
1880 27         129 shift(@tmp);
1881 27         52 foreach my $try (@tmp) {
1882 31         50 foreach my $alt (@$try) {
1883 35         76 push(@r,@$alt);
1884             }
1885             }
1886 27         109 push(@ret,[@r]);
1887             }
1888              
1889             } elsif ($type eq 'stderr') {
1890 21         27 my @r;
1891 21 100 66     93 if (exists $$output{'err'} && defined $$output{'err'}[$i]) {
1892 13         19 my @tmp = @{ $$output{'err'}[$i] };
  13         27  
1893 13         24 shift(@tmp);
1894 13         20 shift(@tmp);
1895 13         18 foreach my $try (@tmp) {
1896 15         22 foreach my $alt (@$try) {
1897 17         32 push(@r,@$alt);
1898             }
1899             }
1900 13         26 push(@ret,[@r]);
1901             }
1902              
1903             } elsif ($type eq 'command') {
1904 31         53 my $n;
1905 31 100 66     179 if (exists $$output{'out'} && defined $$output{'out'}[$i]) {
    50 33        
1906 27         55 $n = $$output{'out'}[$i][0];
1907             } elsif (exists $$output{'err'} && defined $$output{'err'}[$i]) {
1908 4         9 $n = $$output{'err'}[$i][0];
1909             }
1910 31         100 push(@ret,$$self{'cmd'}{$n}{'cmd'});
1911              
1912             } elsif ($type eq 'num') {
1913 37         51 my $n;
1914 37 100 66     218 if (exists $$output{'out'} && defined $$output{'out'}[$i]) {
    50 33        
1915 32         64 $n = $$output{'out'}[$i][0];
1916             } elsif (exists $$output{'err'} && defined $$output{'err'}[$i]) {
1917 5         14 $n = $$output{'err'}[$i][0];
1918             }
1919 37         99 push(@ret,$n);
1920              
1921             } elsif ($type eq 'label') {
1922 23         32 my $n;
1923 23 100 66     141 if (exists $$output{'out'} && defined $$output{'out'}[$i]) {
    50 33        
1924 19         34 $n = $$output{'out'}[$i][0];
1925             } elsif (exists $$output{'err'} && defined $$output{'err'}[$i]) {
1926 4         6 $n = $$output{'err'}[$i][0];
1927             }
1928 23         66 push(@ret,$$self{'cmd'}{$n}{'label'});
1929              
1930             } elsif ($type eq 'exit') {
1931 32         50 my $exit;
1932 32 100 66     186 if (exists $$output{'out'} && defined $$output{'out'}[$i]) {
    50 33        
1933 28         75 $exit = $$output{'out'}[$i][1];
1934             } elsif (exists $$output{'err'} && defined $$output{'err'}[$i]) {
1935 4         6 $exit = $$output{'err'}[$i][1];
1936             }
1937 32         61 push(@ret,$exit);
1938             }
1939             }
1940              
1941 112         476 return @ret;
1942             }
1943              
1944             1;
1945             # Local Variables:
1946             # mode: cperl
1947             # indent-tabs-mode: nil
1948             # cperl-indent-level: 3
1949             # cperl-continued-statement-offset: 2
1950             # cperl-continued-brace-offset: 0
1951             # cperl-brace-offset: 0
1952             # cperl-brace-imaginary-offset: 0
1953             # cperl-label-offset: 0
1954             # End: