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