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