File Coverage

blib/lib/Shell/EnvImporter/Shell.pm
Criterion Covered Total %
statement 171 194 88.1
branch 29 44 65.9
condition 2 6 33.3
subroutine 22 23 95.6
pod 0 13 0.0
total 224 280 80.0


line stmt bran cond sub pod time code
1             package Shell::EnvImporter::Shell;
2              
3 1     1   6 use strict;
  1         1  
  1         32  
4 1     1   5 use warnings;
  1         2  
  1         24  
5 1     1   5 no warnings 'uninitialized';
  1         1  
  1         35  
6              
7 1     1   1066 use IO::Handle;
  1         9521  
  1         57  
8 1     1   2688 use IO::Select;
  1         5600  
  1         70  
9 1     1   1989 use IPC::Open3;
  1         6172  
  1         69  
10 1     1   1074 use Shell::EnvImporter::Result;
  1         5  
  1         66  
11              
12             use Class::MethodMaker 2.0 [
13 1         12 new => [qw(-init new)],
14             scalar => [qw(
15             debuglevel
16              
17             name
18              
19             sourcecmd
20             envcmd
21              
22             envsep
23             cmdsep
24             wordsep
25             squotechar
26             dquotechar
27             escchar
28              
29             statusvar
30             )],
31             array => [qw(
32             flags
33              
34             ignore
35             )],
36 1     1   8 ];
  1         24  
37              
38             # Block size
39 1     1   6399 use constant BLKSIZE => 4096;
  1         2  
  1         110  
40              
41             # Default -- the Bourne shell
42 1         2539 use constant DEFAULTS => (
43             name => 'sh', # Shell name
44              
45             flags => ['-c'], # Flag to pass a command/script to the shell
46              
47             sourcecmd => '.', # Command for sourcing a script file
48             envcmd => 'env', # Command for printing the environment
49              
50             envsep => '=', # Env separator ('=' if envcmd returns '=')
51             cmdsep => ';', # Command separator
52             wordsep => ' ', # Word separator
53             squotechar => "'", # Single-quote character
54             dquotechar => '"', # Double-quote character
55             escchar => "\\", # Escape character (to escape the quote character)
56              
57             statusvar => '$?', # Exit status of last command (shell variable)
58              
59             # These variables get changed in the normal course of shell execution
60             # without being explicitly set
61             ignore => [qw(_ PWD SHLVL)],
62 1     1   6 );
  1         2  
63              
64              
65              
66             ##########
67             sub init {
68             ##########
69 15     15 0 33 my $self = shift;
70 15         66 my %args = @_;
71 15         464 my %defaults = (DEFAULTS);
72              
73             # Set supplied fields with defaults
74 15         106 my @fields = (keys %args, keys %defaults);
75 15         47 my %fields; @fields{@fields} = (1) x @fields;
  15         123  
76 15         91 @fields = keys %fields;
77              
78 15         162 foreach my $field (@fields) {
79 195 50       3147 if ($self->can($field)) {
80 195         10271 my $curval = $self->$field();
81 195 100       3553 my $arg = exists($args{$field}) ? $args{$field} : $defaults{$field};
82 195 100       698 if (ref($curval) =~ /ARRAY/) {
    50          
83 30         1430 $self->$field(@$arg);
84             } elsif (ref($curval) =~ /HASH/) {
85 0         0 $self->$field(%$arg);
86             } else {
87 165         8562 $self->$field($arg);
88             }
89             }
90             }
91            
92              
93             }
94              
95              
96              
97              
98             #########
99             sub run {
100             #########
101 15     15 0 156 my $self = shift;
102 15         118 my %args = @_;
103              
104 15         37 my $command = $args{'command'};
105              
106             # Make a random tag to split up the output
107 15         256 my $tag = join('_', time, $$, int(rand(1) * 10000000));
108 15         284 $self->dprint(4, "Output tag: $tag\n");
109              
110             # Create a result object
111 15         1016 my $rv = Shell::EnvImporter::Result->new();
112              
113             # Create the shell script
114 15         1814 my @script = $self->make_script($command, $tag);
115              
116 15         1282 $self->dprint(3, "EXECUTING: @script\n");
117              
118             # Run the shell script
119 15         317 my $output = $self->execute(@script);
120              
121             # Parse the results
122 14         302 $self->dprint(1, "Parsing results\n");
123 14         741 $self->parse_results($rv, $output, $tag);
124              
125 14         719 return $rv;
126              
127             }
128              
129              
130              
131             #################
132             sub make_script {
133             #################
134 15     15 0 28 my $self = shift;
135 15         24 my $command = shift;
136 15         31 my $tag = shift;
137              
138 15         672 my $statusvar = $self->statusvar;
139 15         607 my $wordsep = $self->wordsep;
140              
141             # Command to invoke the shell
142 15         676 my $shellcmd = join($wordsep, $self->name, $self->flags);
143              
144             # The script: print tag, run command, print tag, run 'env', print tag.
145 15         1504 my $script = join($self->cmdsep,
146             $self->echo_command($tag, 0),
147             $command,
148             $self->echo_command($tag, $statusvar),
149             $self->envcmd,
150             $self->echo_command($tag, $statusvar),
151             );
152              
153 15         484 return ($self->name, $self->flags, $script);
154              
155             }
156              
157              
158              
159             #############
160             sub execute {
161             #############
162 15     15 0 29 my $self = shift;
163 15         50 my @script = @_;
164              
165             # Establish STDIN, STDOUT, and STDERR pipes for the child
166 15         29 my(%fh, %h2p);
167 15         43 foreach my $pipename (qw(STDIN STDOUT STDERR)) {
168 45         669 my $handle = IO::Handle->new();
169 45         1587 $fh{$pipename} = $handle;
170 45         409 $h2p{"$handle"} = $pipename;
171             }
172              
173              
174             # Run that puppy
175 15         136 my $pid = open3($fh{'STDIN'}, $fh{'STDOUT'}, $fh{'STDERR'}, @script);
176              
177              
178             # No input.
179 14         141930 $fh{'STDIN'}->close();
180              
181              
182             # Consume output until the child dies.
183 14         803 my $s = IO::Select->new($fh{'STDOUT'}, $fh{'STDERR'});
184              
185 14         1688 my $t0 = time;
186 14         82 my %buf;
187 14         32 while (1) {
188              
189 45         89319 my @ready = $s->can_read();
190 45 100       76913 last unless (@ready);
191              
192 31         167 foreach my $ready (@ready) {
193 42         699 my $pipename = $h2p{"$ready"};
194 42 100       300 if ($ready->eof) {
195 28         629 $s->remove($ready);
196 28 100       3365 last unless ($s->count);
197             } else {
198 14         966 $ready->read($buf{$pipename}, BLKSIZE, length($buf{$pipename}));
199             }
200             }
201              
202             }
203              
204              
205 14 50       44 if ($s->count) {
206              
207             # Timed out -- kill the child
208 0         0 kill 'TERM', $pid;
209              
210 0         0 $buf{'STDERR'} .= "ERROR: Timed out waiting for output";
211              
212             }
213              
214              
215             # Reap the child process
216 14         600 waitpid($pid, 0);
217              
218              
219 14         1251 return (\%buf);
220              
221             }
222              
223              
224              
225             ###################
226             sub parse_results {
227             ###################
228 14     14 0 107 my $self = shift;
229 14         72 my $rv = shift;
230 14         36 my $output = shift;
231 14         51 my $tag = shift;
232              
233             # Save STDERR if present
234 14 50       60 if (defined($output->{'STDERR'})) {
235 0         0 $rv->stderr($output->{'STDERR'});
236 0         0 $self->dprint(3, "STDERR: $output->{'STDERR'}\n");
237             }
238              
239             # Parse the output, ferreting out exit status and environment based on
240             # the tag.
241 14         465 my @lines = split(/\n/, $output->{'STDOUT'});
242 14         52 my %output;
243              
244             # STDOUT FORMAT:
245             #
246             # 0
247             #
248             #
249             #
250             #
251              
252              
253             # Read the shell startup output
254             my @shell_output;
255 14         50 while (@lines) {
256 14         30 my $line = shift(@lines);
257 14 50       600 if ($line =~ /^$tag 0/) {
258 14         822 $rv->shell_status(0);
259 14         1085 $self->dprint(4, "SHELL STATUS: ", $rv->shell_status, "\n");
260 14         177 last;
261             } else {
262 0         0 push(@shell_output, $line);
263             }
264             }
265 14 50       59 if (@shell_output) {
266 0         0 $rv->shell_output(join("\n", @shell_output));
267 0         0 $self->dprint(4, "SHELL OUTPUT: ", $rv->shell_output, "\n");
268             }
269              
270              
271             # Read the env command output
272 14         471 my @command_output;
273 14         61 while (@lines) {
274 14         28 my $line = shift(@lines);
275 14 50       412 if ($line =~ /^$tag (\d+)/) {
276 14         691 $rv->command_status($1);
277 14         777 $self->dprint(4, "COMMAND STATUS: ", $rv->command_status, "\n");
278 14         153 last;
279             } else {
280 0         0 push(@command_output, $line);
281             }
282             }
283 14 50       50 if (@command_output) {
284 0         0 $rv->command_output(join("\n", @command_output));
285 0         0 $self->dprint(4, "COMMAND OUTPUT: ", $rv->command_output, "\n");
286             }
287              
288              
289             # Read the environment
290 14         23 my %new_env;
291 14         48 while (@lines) {
292 374         679 my $line = shift(@lines);
293 374 100       1682 if ($line =~ /^$tag (\d+)/) {
294 14         574 $rv->env_status($1);
295 14         943 $self->dprint(4, "ENV STATUS: ", $rv->env_status, "\n");
296 14         237 last;
297             } else {
298 360         1018 my($key, $value) = $self->parse_env($line);
299 360         8291 $new_env{$key} = $value;
300             }
301             }
302              
303              
304             # Finally, diff the new environment and the old, but only if the
305             # commands succeeded
306 14 50 33     466 if ($rv->shell_status == 0 and
      33        
307             $rv->command_status == 0 and
308             $rv->env_status == 0 ) {
309              
310 14         1670 $self->dprint(1, "Comparing environments\n");
311 14         419 $self->env_diff($rv, \%new_env);
312              
313             } else {
314              
315 0         0 $@ = "Command failed -- check status and output";
316              
317             }
318              
319              
320             }
321              
322              
323              
324              
325             ###############
326             sub parse_env {
327             ###############
328 360     360 0 518 my $self = shift;
329 360         692 my $line = shift;
330              
331             # Given a line of output from $self->envcmd, return (key, value)
332 360         22937 return(split($self->envsep, $line, 2));
333              
334             }
335              
336              
337              
338             ############
339             sub squote {
340             ############
341 3     3 0 6 my $self = shift;
342 3         5 my $string = shift;
343              
344 3         97 my $qc = $self->squotechar;
345 3         114 my $ec = $self->escchar;
346              
347             # Escape existing quotes
348 3         42 $string =~ s/$qc/${qc}${ec}${qc}${qc}/g;
349              
350             # Add enclosing quotes
351 3         11 return join('', $qc, $string, $qc);
352              
353             }
354              
355             ############
356             sub dquote {
357             ############
358 45     45 0 71 my $self = shift;
359 45         65 my $string = shift;
360              
361 45         1997 my $qc = $self->dquotechar;
362 45         2343 my $ec = $self->escchar;
363              
364             # Escape existing quotes
365 45         512 $string =~ s/$qc/${qc}${ec}${qc}${qc}/g;
366              
367             # Add enclosing quotes
368 45         223 return join('', $qc, $string, $qc);
369              
370             }
371              
372              
373              
374             ###################
375             sub sourcecommand {
376             ###################
377 3     3 0 56 my $self = shift;
378 3         8 my $file = shift;
379              
380             # Given a filename, generate the 'source' command for this shell
381              
382             # Quote the file in case it contains shell-special characters
383 3         28 my $filestr = $self->squote($file);
384              
385 3         93 return(join($self->wordsep, $self->sourcecmd, $filestr));
386              
387             }
388              
389              
390             ##################
391             sub echo_command {
392             ##################
393 45     45 0 311 my $self = shift;
394 45         217 my $str = $self->dquote("@_");
395              
396 45         1961 return "echo $str";
397              
398             }
399              
400              
401              
402             ################
403             sub env_export {
404             ################
405 0     0 0 0 my $self = shift;
406 0 0       0 my %values = (@_ == 1 ? %{$_[0]} : @_);
  0         0  
407              
408 0         0 my @sets;
409 0         0 foreach my $var (sort keys %values) {
410 0 0       0 if (defined($values{$var})) {
411 0         0 push(@sets, "${var}=$values{$var}");
412             } else {
413 0         0 push(@sets, "unset $var");
414             }
415             }
416              
417 0         0 my $sets = join($self->cmdsep, @sets);
418 0         0 my $export = join($self->wordsep, 'export', sort keys %values);
419              
420 0         0 return join($self->cmdsep, $sets, $export);
421              
422             }
423              
424              
425              
426             ##############
427             sub env_diff {
428             ##############
429 14     14 0 26 my $self = shift;
430 14         36 my $rv = shift;
431 14         81 my $new_env = shift;
432              
433             # Make an ignore hash from the shell ignore list
434 14         853 my @ignores = $self->ignore;
435 14         2164 my %ignore; @ignore{@ignores} = (1) x @ignores;
  14         118  
436              
437              
438 14         803 my %old_env = $rv->start_env;
439 14         1468 foreach my $var (keys %$new_env) {
440              
441 360 100       911 unless ($ignore{$var}) {
442              
443 321 100       609 if (exists($old_env{$var})) {
444              
445 307 100       1002 if ($old_env{$var} ne $new_env->{$var}) {
446              
447             # Variable was modified
448 13         80 $self->dprint(3, "MODIFIED: $var\n");
449 13         944 my $change = Shell::EnvImporter::Change->new(
450             type => 'modified',
451             value => $new_env->{$var},
452             );
453 13         5761 $rv->changed_set($var => $change);
454             }
455              
456             } else {
457              
458             # Var was added
459 14         77 $self->dprint(3, "ADDED: $var\n");
460 14         2197 my $change = Shell::EnvImporter::Change->new(
461             type => 'added',
462             value => $new_env->{$var},
463             );
464 14         5476 $rv->changed_set($var => $change);
465              
466             }
467              
468             }
469              
470 360         1170 delete($old_env{$var});
471              
472             }
473              
474             # Whatever's left in old_env was removed
475 14         72 foreach my $var (keys %old_env) {
476 14 50       41 next if ($ignore{$var});
477 14         66 $self->dprint(3, "REMOVED: $var\n");
478 14         695 my $change = Shell::EnvImporter::Change->new(
479             type => 'removed',
480             );
481 14         4363 $rv->changed_set($var => $change);
482             }
483              
484             }
485              
486              
487             ############
488             sub dprint {
489             ############
490 141     141 0 756 my $self = shift;
491 141         222 my $level = shift;
492              
493 141         670 my($package, $filename, $line) = caller;
494              
495 141 50       6147 print STDERR "-" x $level, " $package:$line : ", @_
496             if ($self->debuglevel >= $level);
497              
498             }
499              
500              
501             1;
502              
503             __END__