lib/Shell.pm

   1 package Shell;
   2 use 5.006_001;
   3 use strict;
   4 use warnings;
   5 use File::Spec::Functions;
   6
   7 our($capture_stderr, $raw, $VERSION, $AUTOLOAD);
   8
   9 $VERSION = '0.72_01';
  10 $VERSION = eval $VERSION;
  11
  12 sub new { bless \my $foo, shift }
  13 sub DESTROY { }
  14
  15 sub import {
  16     my $self = shift;
  17     my ($callpack, $callfile, $callline) = caller;
  18     my @EXPORT;
  19     if (@_) {
  20         @EXPORT = @_;
  21     } else {
  22         @EXPORT = 'AUTOLOAD';
  23     }
  24     foreach my $sym (@EXPORT) {
  25         no strict 'refs';
  26         *{"${callpack}::$sym"} = \&{"Shell::$sym"};
  27     }
  28 }
  29
  30 # NOTE: this is used to enable constant folding in
  31 # expressions like (OS eq 'MSWin32') and
  32 # (OS eq 'os2') just like it happened in  0.6  version
  33 # which used eval "string" to install subs on the fly.
  34 use constant OS => $^O;
  35
  36 =begin private
  37
  38 =item B<_make_cmd>
  39
  40   $sub = _make_cmd($cmd);
  41   $sub = $shell->_make_cmd($cmd);
  42
  43 Creates a closure which invokes the system command C<$cmd>.
  44
  45 =end private
  46
  47 =cut
  48
  49 sub _make_cmd {
  50     shift if ref $_[0] && $_[0]->isa( 'Shell' );
  51     my $cmd = shift;
  52     my $null = File::Spec::Functions::devnull();
  53     $Shell::capture_stderr ||= 0;
  54     # closing over $^O, $cmd, and $null
  55     return sub {
  56             shift if ref $_[0] && $_[0]->isa( 'Shell' );
  57             if (@_ < 1) {
  58                 $Shell::capture_stderr ==  1 ? `$cmd 2>&1` :
  59                 $Shell::capture_stderr == -1 ? `$cmd 2>$null` :
  60                 `$cmd`;
  61             } elsif (OS eq 'os2') {
  62                 local(*SAVEOUT, *READ, *WRITE);
  63
  64                 open SAVEOUT, '>&STDOUT' or die;
  65                 pipe READ, WRITE or die;
  66                 open STDOUT, '>&WRITE' or die;
  67                 close WRITE;
  68
  69                 my $pid = system(1, $cmd, @_);
  70                 die "Can't execute $cmd: $!\n" if $pid < 0;
  71
  72                 open STDOUT, '>&SAVEOUT' or die;
  73                 close SAVEOUT;
  74
  75                 if (wantarray) {
  76                     my @ret = <READ>;
  77                     close READ;
  78                     waitpid $pid, 0;
  79                     @ret;
  80                 } else {
  81                     local($/) = undef;
  82                     my $ret = <READ>;
  83                     close READ;
  84                     waitpid $pid, 0;
  85                     $ret;
  86                 }
  87             } else {
  88                 my $a;
  89                 my @arr = @_;
  90                 unless( $Shell::raw ){
  91                   if (OS eq 'MSWin32') {
  92                     # XXX this special-casing should not be needed
  93                     # if we do quoting right on Windows. :-(
  94                     #
  95                     # First, escape all quotes.  Cover the case where we
  96                     # want to pass along a quote preceded by a backslash
  97                     # (i.e., C<"param \""" end">).
  98                     # Ugly, yup?  You know, windoze.
  99                     # Enclose in quotes only the parameters that need it:
 100                     #   try this: c:> dir "/w"
 101                     #   and this: c:> dir /w
 102                     for (@arr) {
 103                         s/"/\\"/g;
 104                         s/\\\\"/\\\\"""/g;
 105                         $_ = qq["$_"] if /\s/;
 106                     }
 107                   } else {
 108                     for (@arr) {
 109                         s/(['\\])/\\$1/g;
 110                         $_ = $_;
 111                      }
 112                   }
 113                 }
 114                 push @arr, '2>&1'        if $Shell::capture_stderr ==  1;
 115                 push @arr, '2>$null' if $Shell::capture_stderr == -1;
 116                 open(SUBPROC, join(' ', $cmd, @arr, '|'))
 117                     or die "Can't exec $cmd: $!\n";
 118                 if (wantarray) {
 119                     my @ret = <SUBPROC>;
 120                     close SUBPROC;        # XXX Oughta use a destructor.
 121                     @ret;
 122                 } else {
 123                     local($/) = undef;
 124                     my $ret = <SUBPROC>;
 125                     close SUBPROC;
 126                     $ret;
 127                 }
 128             }
 129         };
 130         }
 131
 132 sub AUTOLOAD {
 133     shift if ref $_[0] && $_[0]->isa( 'Shell' );
 134     my $cmd = $AUTOLOAD;
 135     $cmd =~ s/^.*:://;
 136     no strict 'refs';
 137     *$AUTOLOAD = _make_cmd($cmd);
 138     goto &$AUTOLOAD;
 139 }
 140
 141 1;
 142
 143 __END__
 144
 145 =head1 NAME
 146
 147 Shell - run shell commands transparently within perl
 148
 149 =head1 SYNOPSIS
 150
 151    use Shell qw(cat ps cp);
 152    $passwd = cat('</etc/passwd');
 153    @pslines = ps('-ww'),
 154    cp("/etc/passwd", "/tmp/passwd");
 155
 156    # object oriented
 157    my $sh = Shell->new;
 158    print $sh->ls('-l');
 159
 160 =head1 DESCRIPTION
 161
 162 =head2 Caveats
 163
 164 This package is included as a show case, illustrating a few Perl features.
 165 It shouldn't be used for production programs. Although it does provide a
 166 simple interface for obtaining the standard output of arbitrary commands,
 167 there may be better ways of achieving what you need.
 168
 169 Running shell commands while obtaining standard output can be done with the
 170 C<qx/STRING/> operator, or by calling C<open> with a filename expression that
 171 ends with C<|>, giving you the option to process one line at a time.
 172 If you don't need to process standard output at all, you might use C<system>
 173 (in preference of doing a print with the collected standard output).
 174
 175 Since Shell.pm and all of the aforementioned techniques use your system's
 176 shell to call some local command, none of them is portable across different
 177 systems. Note, however, that there are several built in functions and
 178 library packages providing portable implementations of functions operating
 179 on files, such as: C<glob>, C<link> and C<unlink>, C<mkdir> and C<rmdir>,
 180 C<rename>, C<File::Compare>, C<File::Copy>, C<File::Find> etc.
 181
 182 Using Shell.pm while importing C<foo> creates a subroutine C<foo> in the
 183 namespace of the importing package. Calling C<foo> with arguments C<arg1>,
 184 C<arg2>,... results in a shell command C<foo arg1 arg2...>, where the
 185 function name and the arguments are joined with a blank. (See the subsection
 186 on Escaping magic characters.) Since the result is essentially a command
 187 line to be passed to the shell, your notion of arguments to the Perl
 188 function is not necessarily identical to what the shell treats as a
 189 command line token, to be passed as an individual argument to the program.
 190 Furthermore, note that this implies that C<foo> is callable by file name
 191 only, which frequently depends on the setting of the program's environment.
 192
 193 Creating a Shell object gives you the opportunity to call any command
 194 in the usual OO notation without requiring you to announce it in the
 195 C<use Shell> statement. Don't assume any additional semantics being
 196 associated with a Shell object: in no way is it similar to a shell
 197 process with its environment or current working directory or any
 198 other setting.
 199
 200 =head2 Escaping Magic Characters
 201
 202 It is, in general, impossible to take care of quoting the shell's
 203 magic characters. For some obscure reason, however, Shell.pm quotes
 204 apostrophes (C<'>) and backslashes (C<\>) on UNIX, and spaces and
 205 quotes (C<">) on Windows.
 206
 207 =head2 Configuration
 208
 209 If you set $Shell::capture_stderr to 1, the module will attempt to
 210 capture the standard error output of the process as well. This is
 211 done by adding C<2E<gt>&1> to the command line, so don't try this on
 212 a system not supporting this redirection.
 213
 214 Setting $Shell::capture_stderr to -1 will send standard error to the
 215 bit bucket (i.e., the equivalent of adding C<2E<gt>/dev/null> to the
 216 command line).  The same caveat regarding redirection applies.
 217
 218 If you set $Shell::raw to true no quoting whatsoever is done.
 219
 220 =head1 BUGS
 221
 222 Quoting should be off by default.
 223
 224 It isn't possible to call shell built in commands, but it can be
 225 done by using a workaround, e.g. shell( '-c', 'set' ).
 226
 227 Capturing standard error does not work on some systems (e.g. VMS).
 228
 229 =head1 AUTHOR
 230
 231   Date: Thu, 22 Sep 94 16:18:16 -0700
 232   Message-Id: <9409222318.AA17072@scalpel.netlabs.com>
 233   To: perl5-porters@isu.edu
 234   From: Larry Wall <lwall@scalpel.netlabs.com>
 235   Subject: a new module I just wrote
 236
 237 Here's one that'll whack your mind a little out.
 238
 239     #!/usr/bin/perl
 240
 241     use Shell;
 242
 243     $foo = echo("howdy", "<funny>", "world");
 244     print $foo;
 245
 246     $passwd = cat("</etc/passwd");
 247     print $passwd;
 248
 249     sub ps;
 250     print ps -ww;
 251
 252     cp("/etc/passwd", "/etc/passwd.orig");
 253
 254 That's maybe too gonzo.  It actually exports an AUTOLOAD to the current
 255 package (and uncovered a bug in Beta 3, by the way).  Maybe the usual
 256 usage should be
 257
 258     use Shell qw(echo cat ps cp);
 259
 260 Larry Wall
 261
 262 Changes by Jenda@Krynicky.cz and Dave Cottle <d.cottle@csc.canterbury.ac.nz>.
 263
 264 Changes for OO syntax and bug fixes by Casey West <casey@geeknest.com>.
 265
 266 C<$Shell::raw> and pod rewrite by Wolfgang Laun.
 267
 268 Rewritten to use closures rather than C<eval "string"> by Adriano Ferreira.
 269
 270 =cut