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