X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FShell.pm;h=72c7ec213760fa56de070f961fdcf863b4f63025;hb=cd22a09c8c81e5e4c639c15ad19704a0d1e0c842;hp=83cc0047db6ffab03fe70474e2608a30d7f8f236;hpb=d0b4fbd9e2c9ee9a42f5c0de27ae9f61e9e33074;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Shell.pm b/lib/Shell.pm index 83cc004..72c7ec2 100644 --- a/lib/Shell.pm +++ b/lib/Shell.pm @@ -4,9 +4,10 @@ use strict; use warnings; use File::Spec::Functions; -our($capture_stderr, $VERSION, $AUTOLOAD); +our($capture_stderr, $raw, $VERSION, $AUTOLOAD); -$VERSION = '0.5.1'; +$VERSION = '0.72_01'; +$VERSION = eval $VERSION; sub new { bless \my $foo, shift } sub DESTROY { } @@ -16,9 +17,9 @@ sub import { my ($callpack, $callfile, $callline) = caller; my @EXPORT; if (@_) { - @EXPORT = @_; + @EXPORT = @_; } else { - @EXPORT = 'AUTOLOAD'; + @EXPORT = 'AUTOLOAD'; } foreach my $sym (@EXPORT) { no strict 'refs'; @@ -26,89 +27,114 @@ sub import { } } +# NOTE: this is used to enable constant folding in +# expressions like (OS eq 'MSWin32') and +# (OS eq 'os2') just like it happened in 0.6 version +# which used eval "string" to install subs on the fly. +use constant OS => $^O; + +=begin private + +=item B<_make_cmd> + + $sub = _make_cmd($cmd); + $sub = $shell->_make_cmd($cmd); + +Creates a closure which invokes the system command C<$cmd>. + +=end private + +=cut + +sub _make_cmd { + shift if ref $_[0] && $_[0]->isa( 'Shell' ); + my $cmd = shift; + my $null = File::Spec::Functions::devnull(); + $Shell::capture_stderr ||= 0; + # closing over $^O, $cmd, and $null + return sub { + shift if ref $_[0] && $_[0]->isa( 'Shell' ); + if (@_ < 1) { + $Shell::capture_stderr == 1 ? `$cmd 2>&1` : + $Shell::capture_stderr == -1 ? `$cmd 2>$null` : + `$cmd`; + } elsif (OS eq 'os2') { + local(*SAVEOUT, *READ, *WRITE); + + open SAVEOUT, '>&STDOUT' or die; + pipe READ, WRITE or die; + open STDOUT, '>&WRITE' or die; + close WRITE; + + my $pid = system(1, $cmd, @_); + die "Can't execute $cmd: $!\n" if $pid < 0; + + open STDOUT, '>&SAVEOUT' or die; + close SAVEOUT; + + if (wantarray) { + my @ret = ; + close READ; + waitpid $pid, 0; + @ret; + } else { + local($/) = undef; + my $ret = ; + close READ; + waitpid $pid, 0; + $ret; + } + } else { + my $a; + my @arr = @_; + unless( $Shell::raw ){ + if (OS eq 'MSWin32') { + # XXX this special-casing should not be needed + # if we do quoting right on Windows. :-( + # + # First, escape all quotes. Cover the case where we + # want to pass along a quote preceded by a backslash + # (i.e., C<"param \""" end">). + # Ugly, yup? You know, windoze. + # Enclose in quotes only the parameters that need it: + # try this: c:> dir "/w" + # and this: c:> dir /w + for (@arr) { + s/"/\\"/g; + s/\\\\"/\\\\"""/g; + $_ = qq["$_"] if /\s/; + } + } else { + for (@arr) { + s/(['\\])/\\$1/g; + $_ = $_; + } + } + } + push @arr, '2>&1' if $Shell::capture_stderr == 1; + push @arr, '2>$null' if $Shell::capture_stderr == -1; + open(SUBPROC, join(' ', $cmd, @arr, '|')) + or die "Can't exec $cmd: $!\n"; + if (wantarray) { + my @ret = ; + close SUBPROC; # XXX Oughta use a destructor. + @ret; + } else { + local($/) = undef; + my $ret = ; + close SUBPROC; + $ret; + } + } + }; + } + sub AUTOLOAD { shift if ref $_[0] && $_[0]->isa( 'Shell' ); my $cmd = $AUTOLOAD; $cmd =~ s/^.*:://; - my $null = File::Spec::Functions::devnull(); - $Shell::capture_stderr ||= 0; - eval <<"*END*"; - sub $AUTOLOAD { - shift if ref \$_[0] && \$_[0]->isa( 'Shell' ); - if (\@_ < 1) { - \$Shell::capture_stderr == 1 ? `$cmd 2>&1` : - \$Shell::capture_stderr == -1 ? `$cmd 2>$null` : - `$cmd`; - } elsif ('$^O' eq 'os2') { - local(\*SAVEOUT, \*READ, \*WRITE); - - open SAVEOUT, '>&STDOUT' or die; - pipe READ, WRITE or die; - open STDOUT, '>&WRITE' or die; - close WRITE; - - my \$pid = system(1, '$cmd', \@_); - die "Can't execute $cmd: \$!\\n" if \$pid < 0; - - open STDOUT, '>&SAVEOUT' or die; - close SAVEOUT; - - if (wantarray) { - my \@ret = ; - close READ; - waitpid \$pid, 0; - \@ret; - } else { - local(\$/) = undef; - my \$ret = ; - close READ; - waitpid \$pid, 0; - \$ret; - } - } else { - my \$a; - my \@arr = \@_; - if ('$^O' eq 'MSWin32') { - # XXX this special-casing should not be needed - # if we do quoting right on Windows. :-( - # - # First, escape all quotes. Cover the case where we - # want to pass along a quote preceded by a backslash - # (i.e., C<"param \\""" end">). - # Ugly, yup? You know, windoze. - # Enclose in quotes only the parameters that need it: - # try this: c:\> dir "/w" - # and this: c:\> dir /w - for (\@arr) { - s/"/\\\\"/g; - s/\\\\\\\\"/\\\\\\\\"""/g; - \$_ = qq["\$_"] if /\\s/; - } - } else { - for (\@arr) { - s/(['\\\\])/\\\\\$1/g; - \$_ = \$_; - } - } - push \@arr, '2>&1' if \$Shell::capture_stderr == 1; - push \@arr, '2>$null' if \$Shell::capture_stderr == -1; - open(SUBPROC, join(' ', '$cmd', \@arr, '|')) - or die "Can't exec $cmd: \$!\\n"; - if (wantarray) { - my \@ret = ; - close SUBPROC; # XXX Oughta use a destructor. - \@ret; - } else { - local(\$/) = undef; - my \$ret = ; - close SUBPROC; - \$ret; - } - } - } -*END* - - die "$@\n" if $@; + no strict 'refs'; + *$AUTOLOAD = _make_cmd($cmd); goto &$AUTOLOAD; } @@ -122,10 +148,86 @@ Shell - run shell commands transparently within perl =head1 SYNOPSIS -See below. + use Shell qw(cat ps cp); + $passwd = cat('new; + print $sh->ls('-l'); =head1 DESCRIPTION +=head2 Caveats + +This package is included as a show case, illustrating a few Perl features. +It shouldn't be used for production programs. Although it does provide a +simple interface for obtaining the standard output of arbitrary commands, +there may be better ways of achieving what you need. + +Running shell commands while obtaining standard output can be done with the +C operator, or by calling C with a filename expression that +ends with C<|>, giving you the option to process one line at a time. +If you don't need to process standard output at all, you might use C +(in preference of doing a print with the collected standard output). + +Since Shell.pm and all of the aforementioned techniques use your system's +shell to call some local command, none of them is portable across different +systems. Note, however, that there are several built in functions and +library packages providing portable implementations of functions operating +on files, such as: C, C and C, C and C, +C, C, C, C etc. + +Using Shell.pm while importing C creates a subroutine C in the +namespace of the importing package. Calling C with arguments C, +C,... results in a shell command C, where the +function name and the arguments are joined with a blank. (See the subsection +on Escaping magic characters.) Since the result is essentially a command +line to be passed to the shell, your notion of arguments to the Perl +function is not necessarily identical to what the shell treats as a +command line token, to be passed as an individual argument to the program. +Furthermore, note that this implies that C is callable by file name +only, which frequently depends on the setting of the program's environment. + +Creating a Shell object gives you the opportunity to call any command +in the usual OO notation without requiring you to announce it in the +C statement. Don't assume any additional semantics being +associated with a Shell object: in no way is it similar to a shell +process with its environment or current working directory or any +other setting. + +=head2 Escaping Magic Characters + +It is, in general, impossible to take care of quoting the shell's +magic characters. For some obscure reason, however, Shell.pm quotes +apostrophes (C<'>) and backslashes (C<\>) on UNIX, and spaces and +quotes (C<">) on Windows. + +=head2 Configuration + +If you set $Shell::capture_stderr to 1, the module will attempt to +capture the standard error output of the process as well. This is +done by adding C<2E&1> to the command line, so don't try this on +a system not supporting this redirection. + +Setting $Shell::capture_stderr to -1 will send standard error to the +bit bucket (i.e., the equivalent of adding C<2E/dev/null> to the +command line). The same caveat regarding redirection applies. + +If you set $Shell::raw to true no quoting whatsoever is done. + +=head1 BUGS + +Quoting should be off by default. + +It isn't possible to call shell built in commands, but it can be +done by using a workaround, e.g. shell( '-c', 'set' ). + +Capturing standard error does not work on some systems (e.g. VMS). + +=head1 AUTHOR + Date: Thu, 22 Sep 94 16:18:16 -0700 Message-Id: <9409222318.AA17072@scalpel.netlabs.com> To: perl5-porters@isu.edu @@ -155,58 +257,14 @@ usage should be use Shell qw(echo cat ps cp); -Larry - - -If you set $Shell::capture_stderr to 1, the module will attempt to -capture the STDERR of the process as well. - -If you set $Shell::capture_stderr to -1, the module will discard the -STDERR of the process. - -The module now should work on Win32. - - Jenda - -There seemed to be a problem where all arguments to a shell command were -quoted before being executed. As in the following example: - - cat('new; - print $sh->ls; - -Casey +Larry Wall -=head1 AUTHOR +Changes by Jenda@Krynicky.cz and Dave Cottle . -Larry Wall +Changes for OO syntax and bug fixes by Casey West . -Changes by Jenda@Krynicky.cz and Dave Cottle +C<$Shell::raw> and pod rewrite by Wolfgang Laun. -Changes and bug fixes by Casey West +Rewritten to use closures rather than C by Adriano Ferreira. =cut