File Coverage

blib/lib/Env/Modify.pm
Criterion Covered Total %
statement 141 162 87.0
branch 41 62 66.1
condition 10 18 55.5
subroutine 22 24 91.6
pod 8 8 100.0
total 222 274 81.0


line stmt bran cond sub pod time code
1             package Env::Modify;
2 7     7   125188 use strict;
  7         12  
  7         206  
3 7     7   30 use warnings;
  7         12  
  7         219  
4 7     7   31 use base 'Exporter';
  7         11  
  7         740  
5 7     7   4013 use Shell::GetEnv '0.09';
  7         200800  
  7         263  
6             #use String::ShellQuote; # nah, just borrow from String::ShellQuote
7 7     7   4109 use File::Spec::Functions 'catfile';
  7         4625  
  7         482  
8 7     7   39 use File::Temp;
  7         18  
  7         3126  
9              
10             *DEBUG = *DEVNULL; open DEVNULL,'>/dev/null';
11             our $DEBUG && (*DEBUG = *STDERR);
12             our $SHELL = 'sh';
13             our $CHDIR = 0;
14              
15             our $VERSION = '0.01';
16             our @EXPORT_OK = qw(system readpipe qx backticks source
17             readpipe_list qx_list backticks_list);
18             my @readpipe_exp = qw(readpipe readpipe_list qx_list backticks_list);
19             our %EXPORT_TAGS = ('system' => ['system'],
20             'readpipe' => [@readpipe_exp],
21             'qx' => ['qx','backticks', @readpipe_exp],
22             'backticks' => ['qx','backticks', @readpipe_exp],
23             'all' => ['system', 'qx','backticks', 'source', @readpipe_exp],
24             'chdir' => [],
25             'sh' => [], 'bash' => [], 'csh' => [], 'dash' => [],
26             'ksh' => [], 'tcsh' => [], 'zsh' => [] );
27              
28              
29             # default attributes that go to all Shell::GetEnv constructors
30             our %CMDOPT = (
31             startup => 0,
32             login => 0,
33             interactive => 0,
34             verbose => 0,
35             );
36              
37             our %ENVSOPT = (
38             ZapDeleted => 1
39             );
40              
41             our $TEMPDIR = File::Temp::tempdir( CLEANUP => 1 );
42              
43             my $calls = 0;
44              
45             # RT115330 describes a bug with overloaded readpipe function.
46             # It was fixed in Perl v5.20.0
47             our $_RT115330 = $] < 5.020000;
48              
49             sub import {
50             # Handle the CORE::GLOBAL::readpipe bug (RT#115330) differently depending
51             # on whether the caller primarily uses qx(), `backticks`, or readpipe.
52             # The bug was fixed in Perl v5.20.0
53 7     7   84 my %tags = map {; $_ => 1 } grep /^:/, @_;
  6         22  
54 7         11 my $cgreadpipe = 0;
55 7 100 66     70 if ($tags{":qx"} || $tags{":backticks"} || $tags{":all"}) {
    100 66        
56             *CORE::GLOBAL::readpipe = sub {
57 6     6   4956 local $_RT115330 = $] < 5.020000;
58 6         27 return _readpipe_mod_env(@_);
59 2         14 };
60 2         3 $cgreadpipe = 1;
61             } elsif ($tags{":readpipe"}) {
62             # CORE::GLOBAL::readpipe will not be respected for Perl
63             *CORE::GLOBAL::readpipe = sub {
64 7     7   5318 local $_RT115330 = 0;
65 7         36 return _readpipe_mod_env(@_);
66 1         4 };
67 1         2 $cgreadpipe = 1;
68             }
69              
70 7 100 66     33 if ($tags{":system"} || $tags{":all"}) {
71 7     7   37 no warnings 'once';
  7         7  
  7         968  
72 2         7 *CORE::GLOBAL::system = \&Env::Modify::system;
73             }
74 7 100       20 if ($tags{":chdir"}) {
75 1         2 $CHDIR = 1;
76             }
77 7         12 for my $shell ('zsh','tcsh','ksh','dash','csh','bash','sh') {
78 49 50       94 if ($tags{":$shell"}) {
79 0         0 $SHELL = $shell;
80             }
81             }
82 7 100       17 if ($cgreadpipe) {
83 3         480 __PACKAGE__->export_to_level(1, __PACKAGE__, @_[1..$#_]);
84 3         6 my $callpkg = caller;
85 7     7   32 no strict 'refs';
  7         7  
  7         223  
86 7     7   27 no warnings 'redefine';
  7         9  
  7         5599  
87 3         5 *{$callpkg . "::readpipe"} = \&CORE::GLOBAL::readpipe;
  3         6186  
88             } else {
89 4         384 goto &Exporter::import;
90             }
91             }
92              
93 4     4 1 2780 sub backticks {goto &readpipe }
94 3     3 1 1981 sub qx { goto &readpipe }
95 0     0 1 0 sub backticks_list { goto &readpipe_list }
96 0     0 1 0 sub qx_list { goto &readpipe_list }
97             sub readpipe {
98 7     7 1 25 local $_RT115330 = 0;
99 7         62 return _readpipe_mod_env(@_);
100             }
101              
102             sub readpipe_list {
103 1     1 1 10 local $_RT115330 = 0;
104 1 50       13 my $cmd = @_ > 1 ? _sh_quote(@_) : $_[0];
105 1         7 return _readpipe_mod_env($cmd);
106             }
107              
108             sub system {
109 35     35 1 63609 my @cmd = @_;
110 35 100       240 my $cmd = @cmd > 1 ? _sh_quote(@cmd) : $cmd[0];
111 35         123 $calls++;
112 35         235 my $stub = "$calls.$$";
113 35         360 my $stdout = catfile( $TEMPDIR, $stub . "-stdout");
114 35         198 my $stderr = catfile( $TEMPDIR, $stub . "-stderr");
115 35         570 my $getenv = Shell::GetEnv->new( $SHELL, $cmd,
116             { %CMDOPT, echo => 0,
117             stdout => $stdout, stderr => $stderr } );
118 26         789752 $getenv->import_envs( %ENVSOPT );
119              
120 26 100       5951 if (-s $stderr) {
121 6         120 open my $err, '>&2'; # or warn "print to unopened filehandle?"
122 6         137 open my $fh, '<', $stderr;
123 6         16 print {$err} <$fh>;
  6         152  
124 6         42 close $fh;
125 6         517 close $err;
126             }
127 26 100       382 if (-s $stdout) {
128 4         63 open my $out, '>&1'; # or warn "print to unopened filehandle?"
129 4         87 open my $fh, '<', $stdout;
130 4         11 print {$out} <$fh>;
  4         82  
131 4         25 close $fh;
132 4         695 close $out;
133             }
134 26         2526 unlink $stdout, $stderr;
135 26         163 my $status = _status($getenv->status);
136 26 100       156 $CHDIR && chdir $ENV{PWD};
137 26         823 return $? = $status;
138             }
139              
140             sub source {
141 3     3 1 3500 my ($file,@args) = @_;
142 3 50       22 if ($SHELL eq 'tcsh') {
    50          
    50          
143 0         0 $file = _sh_quote($file,@args);
144 0         0 return Env::Modify::system( "source $file" );
145             } elsif ($SHELL eq 'csh') {
146 0         0 $file = _sh_quote($file,@args);
147 0         0 return Env::Modify::system("source $file");
148             } elsif ($SHELL eq 'ksh') {
149             # . $file is supposed to work, but it doesn't
150 0         0 $file = _sh_quote($file,@args);
151 0         0 return Env::Modify::system("eval \$(cat $file)");
152             } else {
153 3         17 return Env::Modify::system( ". " . _sh_quote($file,@args) );
154             }
155             }
156              
157             sub _readpipe_mod_env {
158 21     21   55 my ($cmd) = @_;
159              
160 21 50       79 if ($_RT115330) {
161 0 0       0 if ($cmd !~ /"/) {
162 0         0 $cmd = eval qq["$cmd"];
163             } else {
164 0         0 for my $delim ('#',',', qw(! ' ; " @ $ % ^ & * - = +
165             : . / ? ~ ` 00)) {
166 0 0       0 if ($cmd eq '00') {
    0          
167 0         0 warn __PACKAGE__,"::_readpipe_mod_env: ",
168             "reinterpolation of $cmd neglected";
169             } elsif ($cmd !~ /\Q$delim/) {
170 0         0 $cmd = eval qq[qq$delim$cmd$delim];
171 0         0 last;
172             }
173             }
174             }
175             }
176 21         50 $calls++;
177 21         102 my $stub = "$calls.$$";
178 21         248 my $stdout = catfile( $TEMPDIR, $stub . "-stdout");
179 21         170 my $stderr = catfile( $TEMPDIR, $stub . "-stderr");
180 21         395 my $getenv = Shell::GetEnv->new( $SHELL, $cmd,
181             { %CMDOPT, echo => 0,
182             stdout => $stdout, stderr => $stderr } );
183 21         626941 $getenv->import_envs( %ENVSOPT );
184 21         4719 my @out;
185             {
186 21 50       74 local $/ = wantarray ? $/ : undef;
  21         202  
187 7     7   87 no warnings 'io'; # in case open $fh touches fd 1 or 2
  7         14  
  7         4238  
188 21         825 open my $fh, '<', $stdout;
189 21         893 @out = <$fh>;
190 21         152 close $fh;
191 21 100       408 if (-s $stderr) {
192 9         149 open my $err, '>&=2'; # or warn "print to unopened filehandle?"
193 9         230 open my $fh, '<', $stderr;
194 9         224 my @err = <$fh>;
195 9         94 print {$err} @err;
  9         116  
196 9         599 close $err;
197 9         122 close $fh;
198             }
199             }
200 21         2883 unlink $stdout, $stderr;
201 21 100       150 $CHDIR && chdir $ENV{PWD};
202 21         155 $? = _status($getenv->status);
203 21 50       830 return wantarray ? @out : $out[0];
204             }
205              
206             sub _status {
207 47     47   470 my $ge_status = shift;
208              
209             # http://tldp.org/LDP/abs/html/exitcodes.html
210             # treat exit code 128+n as command terminated by signal ?
211             # may not be portable to non-POSIX OS or other shells
212 47         90 my $status = $ge_status;
213 47 100       245 if ($status > 128) {
214 1         5 $status = $status - 128;
215             } else {
216 46         153 $status = $status << 8;
217             }
218             }
219              
220             sub _sh_quote { # borrowed heavily from String::ShellQuote 1.04
221 12     12   4576 my @in = @_;
222 12 50       56 return '' unless @in;
223 12         41 my ($ret, $saw_non_equal, @err) = ('', 0);
224 12         40 foreach (@in) {
225 37 50 33     204 if (!defined $_ or $_ eq '') {
226 0         0 $_ = "''";
227 0         0 next;
228             }
229             s/\x00//g &&
230 37 50       114 push @err, "No way to quote string containing null (\\000) bytes";
231 37         49 my $escape = 0;
232 37 50       236 if (/=/) {
233 0 0       0 $escape = 1 if !$saw_non_equal;
234             } else {
235 37         37 $saw_non_equal = 1;
236             }
237 37 100       129 $escape = 1 if m|[^\w!%+,\-./:=@^]|;
238 37 100 33     174 if ($escape || (!$saw_non_equal && /=/)) {
      66        
239 12         30 s/'/'\\''/g; # ' -> '\''
240              
241             # make multiple ' in a row look simpler
242             # '\'''\'''\'' -> '"'''"'
243 12         25 s|((?:'\\''){2,})|q{'"} . (q{'} x (length($1) / 4)) . q{"'}|ge;
  0         0  
244 12         35 $_ = "'$_'";
245 12         18 s/^''//;
246 12         24 s/''$//;
247             }
248             } continue {
249 37         100 $ret .= "$_ ";
250             }
251 12         34 chop $ret;
252 12 50       46 if (@err) {
253 0         0 warn __PACKAGE__ . "::sh_quote: @err";
254             }
255 12         70 return $ret;
256             }
257              
258             1;
259              
260             =head1 NAME
261              
262             Env::Modify - affect Perl %ENV from subshell
263              
264             =head1 VERSION
265              
266             0.01
267              
268             =head1 SYNOPSIS
269              
270             use Env::Modify 'system', ':readpipe';
271              
272             $ENV{FOO}="bar";
273             system('echo $FOO'); # "bar"
274             system('FOO=baz');
275             print $ENV{FOO}; # "baz"
276              
277             # on Perl <=v5.8.8, say "Env::Modify::readpipe" instead
278             $out = qx(BAR=123; export BAR; echo hello);
279             print $ENV{BAR}; # "123"
280             print $out; # "hello";
281              
282             ###
283              
284             use Env::Modify 'source', ':bash', ':chdir';
285             open ENV, '>my_env.sh';
286             print ENV "export MEANING_OF_LIFE=42\n";
287             print ENV "cd \$HOME\n";
288             print ENV "cd .cpan\n";
289             close ENV;
290             my $status = source("my_env.sh");
291             print $ENV{MEANING_OF_LIFE}; # "42"
292             print "Current dir: ",Cwd::getcwd(),"\n"; # "/home/mob/.cpan"
293              
294              
295             =head1 DESCRIPTION
296              
297             New Perl programmers are often confused about how the C call
298             interacts with the environment, and they wonder why this code:
299              
300             system('export foo=bar');
301             system('echo $foo');
302              
303             behaves differently from
304              
305             system('export foo=bar; echo $foo');
306              
307             or why when they run this code
308              
309             system("chdir \$HOME/scripts");
310             system("source my.env");
311             system("./my_script.sh");
312              
313             all the environment variables that they carefully set in C
314             are ignored by C<./my_script.sh>.
315              
316             The reason these codes do not meet the new user's expectations
317             is that subshells, such as those launched by C, receive
318             their own copy of the operating system environment and can only
319             make changes to that local environment.
320              
321             This module seeks to overcome that limitation, allowing
322             C calls (and C/C/backticks) calls
323             to affect the local environment. It uses the clever mechanism
324             in Diab Jerius's L module to copy
325             the environment of the subshell back to the calling environment.
326              
327             =head1 FUNCTIONS
328              
329             =head2 system
330              
331             =head2 EXIT_CODE = system LIST
332              
333             Acts like the builtin L command,
334             but any changes made to the subshell environment are preserved
335             and copied to the calling environment.
336              
337             Like the builtin call, the return value is the exit status of
338             the command as returned by the L call.
339              
340             When you import the C command into your calling
341             package (with C),
342             C installs the C
343             function to the C namespace (see
344             L), making it
345             available anywhere that your program makes a call to C.
346              
347             =head2 readpipe
348              
349             =head2 readpipe(EXPR)
350              
351             =head2 Env::Modify::qx(EXPR), &qx(EXPR)
352              
353             =head2 backticks(EXPR)
354              
355             Executes a system command and returns the standard output of
356             the command. In scalar context, the output comes back as a single
357             (potentially multi-line) string. In list context, returns a list
358             of lines (however lines are defined with L or
359             L).
360              
361             Unlike the builtin C command, any changes made by the
362             system command to the subshell environment are preserved and
363             copied back to the calling environment.
364              
365             When any of the functions C, C, or C
366             or any of the tags C<:readpipe>, C<:qx>, C<:backticks>, or
367             C<:all> are imported into the calling namespace,
368             this module installs the C function to
369             the C namespace. As described in
370             L, an override
371             for the C function also overrides the operators
372             C<``> and C. Note that C was not supported
373             as an overridable function for the C package
374             until Perl v5.8.9. If your version of perl is older than that,
375             you will need to use function names and not C or
376             backticks notation to get this module to modify your
377             environment.
378              
379             See the L<"RT115330"> section for another important caveat
380             about the C set of functions, and how to structure
381             your C statement to make best use of
382             this module.
383              
384             =head2 readpipe_list LIST
385              
386             =head2 backticks_list LIST
387              
388             =head2 qx_list LIST
389              
390             Convenience functions to accommodate external commands with
391             shell metacharacters. Like the L<"readpipe"> function,
392             but may take a list of arguments the way that Perl's
393             C function does. Compare:
394              
395             $output = readpipe("ls -l \"My Documents\" Videos*");
396             $output = readpipe_list("ls","-l","My Documents","Videos*");
397              
398             (See also:
399             L.)
400              
401             =head2 source FILE LIST
402              
403             Like the shell built-in command of the same name (also called
404             C<.> in some shells), executes the shell
405             commands in a file and incorporates any modifications to the
406             subshell's environment into the calling environment.
407              
408             That is, if C contains
409              
410             FOO=123
411             NUM_HOME_FILES=$(ls $HOME | wc -l)
412             export FOO NUM_HOME_FILES
413              
414             then you could run
415              
416             use Env::Modify 'source';
417             source("my_env.sh");
418             print "FOO is $ENV{FOO}\n"; # expect: "123"
419             print "There are $ENV{NUM_HOME_FILES} in the home dir\n";
420              
421             =head1 RT115330
422              
423             L<"perlbug RT#115330"|https://rt.perl.org/Ticket/Display.html?id=115330>
424             described an issue with Perl code that sets the C<*CORE::GLOBAL::readpipe>
425             function, like this module does.
426             This bug was fixed in Perl v5.20.0
427             and if you are not using an older version of Perl than that, you
428             are not affected by this bug and you may stop reading.
429              
430             The short version is that the arguments received by the
431             C function are correct when you
432             use the keyword C to call the function, and they
433             need to be interpolated an extra time when you use backticks
434             or the C construction.
435              
436             The form of the C statement should resemble the way
437             that you I invoke the C command. If your
438             code literally calls the C function, then you
439             should load this module with
440              
441             use Env::Modify ':readpipe';
442              
443             If your code usually uses the C construct or backticks
444             to invoke C, then you should load the module with
445             either
446              
447             use Env::Modify ':qx';
448             use Env::Modify ':backticks';
449              
450             (these two calls are equivalent). This will have the effect
451             of interpolating the input one last time before the input
452             is passed to the shell.
453              
454             If your code uses both C and C/backticks,
455             you can always workaround this bug using fully-qualified function
456             names like C,
457             C, or
458             C. All of these function calls
459             will receive correctly interpolated input.
460              
461             =head1 MODULE VARIABLES
462              
463             =head2 $SHELL
464              
465             The shell that the L module will use to run
466             an external command. This must be a value supported by
467             L, namely one of C, C, C,
468             C, C, C, or C.
469             Defaults to C.
470              
471             The value of C<$SHELL> can also be set by specifing a tag
472             with the shell name when this module is imported. For
473             example, to specify C as the shell for this module
474             to use, load this module like
475              
476             use Env::Modify ':bash';
477              
478             =head2 $CHDIR
479              
480             If C<$Env::Modify::CHDIR> is set to a true value, then any
481             change of the current working directory in a subshell will
482             also affect the working directory in the calling (Perl)
483             environment. That is, you can say
484              
485             chdir "/some/path";
486             $f = -f "bar"; # -f /some/path/bar
487             system("cd foo");
488             $g = -f "bar"; # -f /some/path/foo/bar
489              
490             You can also enable this feature at import time with the
491             C<:chdir> tag.
492              
493             =head2 %CMDOPT
494              
495             A set of options that are passed to the L
496             constructor. See the C method in L.
497              
498             # don't load startup files (.profile, .bashrc, etc.)
499             # when system() runs below
500             local $Env::Modify::CMDOPT{startup} = 0;
501             Env::Modify::system("FOO=bar; export FOO");
502              
503              
504             =head2 %ENVSOPT
505              
506             A set of options that are passed to the C
507             method of L. See the C method
508             in L.
509              
510             # don't remove entries from Perl environment
511             local $Env::Modify::ENVSOPT{ZapDeleted} = 0;
512             source("./script_that_erases_PATH_var.sh");
513             print "PATH is still $ENV{PATH}"; # not erased
514              
515             =head1 EXPORT
516              
517             This module has four functions that can be exported into the
518             calling namespace: C, C, C, and C.
519             As C is a Perl language construction and not just a keyword,
520             if you import the C function you would either have to use
521             a fully qualified function name or a sigil to use it:
522              
523             package My::Pkg;
524             use Env::Modify 'qx';
525             ...
526             $out1 = qx($cmd1); # calls Perl built-in, not Env::Modify::qx !
527             $out2 = &qx($cmd2); # calls Env::Modify::qx
528             $out3 = My::Pkg::qx($cmd3); # calls Env::Modify::qx
529              
530             The tag C<:system> exports the C function into the calling
531             namespace and also sets the C function, so that
532             all C calls in any package in any part of your script will
533             use the C function.
534              
535             The tags C<:readpipe>, C<:qx>, or C<:backticks> export the
536             C, C, and C functions into the calling
537             namespace, and also set the C function,
538             so that all C calls, C constructions, or
539             backticks expressions in any package and in any part of your script
540             will use the C function. If you are
541             vulnerable to L<"RT115330"> (see above), then you should use
542             C<:readpipe> if your script generally uses C to
543             capture output from external programs and use C<:qx> or C<:backticks>
544             if your script generally uses C or backticks.
545              
546             The C<:all> tag behaves like C<:system> + C<:backticks>.
547              
548             You may also specify the C<:chdir> tag to enable the "chdir"
549             feature (see C<$CHDIR> under L<"MODULE VARIABLES">), or a tag
550             with the name of a shell like C<:sh>, C<:bash>, etc.
551             to specify the default shell for this module to run external
552             commands (see C<$SHELL> under L<"MODULE VARIABLES">).
553              
554             =head1 LIMITATIONS
555              
556             =over 4
557              
558             =item Portability
559              
560             C can only work on systems where L
561             will work, namely systems where POSIX-y type shells are
562             installed.
563              
564             =item Buffering
565              
566             With a regular C or C/C/backticks call,
567             lines from the standard error stream of the external command
568             (and from the standard output stream in the case of C)
569             are written to the terminal as the external program produces
570             them. Because of the nature of how this module recovers and
571             transfers the environment of the subshell, C
572             functions will hold onto external program output, and not
573             publish it to your Perl script's terminal until the command
574             has completed. This may cause
575             L,
576             and for that, the author of this module apologizes.
577              
578             =item Interlaced standard output and standard error
579              
580             In a regular C call that writes to both standard
581             output and standard error, lines from the output stream
582             and error stream will often be interleaved on your terminal.
583             Because of the nature of how this module recovers and
584             transfers the environment of the subshell, C
585             calls will not interleave error and output this way. All
586             of the standard error output, if any, will be written to
587             the terminal (file descriptor 2, which is usually but not
588             necessarily STDERR), followed by all standard output being
589             written to the terminal (file descriptor 1).
590              
591             =back
592              
593             =head1 DEPENDENCIES
594              
595             L provides the mechanism for copying a subshell's
596             environment back into the calling environment.
597              
598             =head1 SUPPORT
599              
600             You can find documentation for this module with the perldoc command.
601              
602             perldoc Env::Modify
603              
604             You can also look for information at:
605              
606             =over 4
607              
608             =item * RT: CPAN's request tracker
609              
610             L
611              
612             =item * AnnoCPAN: Annotated CPAN documentation
613              
614             L
615              
616             =item * CPAN Ratings
617              
618             L
619              
620             =item * Search CPAN
621              
622             L
623              
624             =back
625              
626             =head1 AUTHOR
627              
628             Marty O'Brien, C<< >>
629              
630             =head1 COPYRIGHT AND LICENSE
631              
632             Copyright (c) 2016, Marty O'Brien
633              
634             This library is free software; you can redistribute it and/or modify
635             it under the same terms as Perl itself, either Perl version 5.8.8 or,
636             at your option, any later version of Perl 5 you may have available.
637              
638             See http://dev.perl.org/licenses/ for more information.
639              
640             =cut
641              
642             # TODO: open2, open3 that modifies environment
643             # test on openbsd, Cygwin, other systems