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, $VERSION, $AUTOLOAD);
   8
   9 $VERSION = '0.5.2';
  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 sub AUTOLOAD {
  30     shift if ref $_[0] && $_[0]->isa( 'Shell' );
  31     my $cmd = $AUTOLOAD;
  32     $cmd =~ s/^.*:://;
  33     my $null = File::Spec::Functions::devnull();
  34     $Shell::capture_stderr ||= 0;
  35     eval <<"*END*";
  36         sub $AUTOLOAD {
  37             shift if ref \$_[0] && \$_[0]->isa( 'Shell' );
  38             if (\@_ < 1) {
  39                 \$Shell::capture_stderr ==  1 ? `$cmd 2>&1` :
  40                 \$Shell::capture_stderr == -1 ? `$cmd 2>$null` :
  41                 `$cmd`;
  42             } elsif ('$^O' eq 'os2') {
  43                 local(\*SAVEOUT, \*READ, \*WRITE);
  44
  45                 open SAVEOUT, '>&STDOUT' or die;
  46                 pipe READ, WRITE or die;
  47                 open STDOUT, '>&WRITE' or die;
  48                 close WRITE;
  49
  50                 my \$pid = system(1, '$cmd', \@_);
  51                 die "Can't execute $cmd: \$!\\n" if \$pid < 0;
  52
  53                 open STDOUT, '>&SAVEOUT' or die;
  54                 close SAVEOUT;
  55
  56                 if (wantarray) {
  57                     my \@ret = <READ>;
  58                     close READ;
  59                     waitpid \$pid, 0;
  60                     \@ret;
  61                 } else {
  62                     local(\$/) = undef;
  63                     my \$ret = <READ>;
  64                     close READ;
  65                     waitpid \$pid, 0;
  66                     \$ret;
  67                 }
  68             } else {
  69                 my \$a;
  70                 my \@arr = \@_;
  71                 if ('$^O' eq 'MSWin32') {
  72                     # XXX this special-casing should not be needed
  73                     # if we do quoting right on Windows. :-(
  74                     #
  75                     # First, escape all quotes.  Cover the case where we
  76                     # want to pass along a quote preceded by a backslash
  77                     # (i.e., C<"param \\""" end">).
  78                     # Ugly, yup?  You know, windoze.
  79                     # Enclose in quotes only the parameters that need it:
  80                     #   try this: c:\> dir "/w"
  81                     #   and this: c:\> dir /w
  82                     for (\@arr) {
  83                         s/"/\\\\"/g;
  84                         s/\\\\\\\\"/\\\\\\\\"""/g;
  85                         \$_ = qq["\$_"] if /\\s/;
  86                     }
  87                 } else {
  88                     for (\@arr) {
  89                         s/(['\\\\])/\\\\\$1/g;
  90                         \$_ = \$_;
  91                     }
  92                 }
  93                 push \@arr, '2>&1'        if \$Shell::capture_stderr ==  1;
  94                 push \@arr, '2>$null' if \$Shell::capture_stderr == -1;
  95                 open(SUBPROC, join(' ', '$cmd', \@arr, '|'))
  96                     or die "Can't exec $cmd: \$!\\n";
  97                 if (wantarray) {
  98                     my \@ret = <SUBPROC>;
  99                     close SUBPROC;      # XXX Oughta use a destructor.
 100                     \@ret;
 101                 } else {
 102                     local(\$/) = undef;
 103                     my \$ret = <SUBPROC>;
 104                     close SUBPROC;
 105                     \$ret;
 106                 }
 107             }
 108         }
 109 *END*
 110
 111     die "$@\n" if $@;
 112     goto &$AUTOLOAD;
 113 }
 114
 115 1;
 116
 117 __END__
 118
 119 =head1 NAME
 120
 121 Shell - run shell commands transparently within perl
 122
 123 =head1 SYNOPSIS
 124
 125 See below.
 126
 127 =head1 DESCRIPTION
 128
 129   Date: Thu, 22 Sep 94 16:18:16 -0700
 130   Message-Id: <9409222318.AA17072@scalpel.netlabs.com>
 131   To: perl5-porters@isu.edu
 132   From: Larry Wall <lwall@scalpel.netlabs.com>
 133   Subject: a new module I just wrote
 134
 135 Here's one that'll whack your mind a little out.
 136
 137     #!/usr/bin/perl
 138
 139     use Shell;
 140
 141     $foo = echo("howdy", "<funny>", "world");
 142     print $foo;
 143
 144     $passwd = cat("</etc/passwd");
 145     print $passwd;
 146
 147     sub ps;
 148     print ps -ww;
 149
 150     cp("/etc/passwd", "/etc/passwd.orig");
 151
 152 That's maybe too gonzo.  It actually exports an AUTOLOAD to the current
 153 package (and uncovered a bug in Beta 3, by the way).  Maybe the usual
 154 usage should be
 155
 156     use Shell qw(echo cat ps cp);
 157
 158 Larry
 159
 160
 161 If you set $Shell::capture_stderr to 1, the module will attempt to
 162 capture the STDERR of the process as well.
 163
 164 If you set $Shell::capture_stderr to -1, the module will discard the
 165 STDERR of the process.
 166
 167 The module now should work on Win32.
 168
 169  Jenda
 170
 171 There seemed to be a problem where all arguments to a shell command were
 172 quoted before being executed.  As in the following example:
 173
 174  cat('</etc/passwd');
 175  ls('*.pl');
 176
 177 really turned into:
 178
 179  cat '</etc/passwd'
 180  ls '*.pl'
 181
 182 instead of:
 183
 184   cat </etc/passwd
 185   ls *.pl
 186
 187 and of course, this is wrong.
 188
 189 I have fixed this bug, it was brought up by Wolfgang Laun [ID 20000326.008]
 190
 191 Casey
 192
 193 =head2 OBJECT ORIENTED SYNTAX
 194
 195 Shell now has an OO interface.  Good for namespace conservation
 196 and shell representation.
 197
 198  use Shell;
 199  my $sh = Shell->new;
 200  print $sh->ls;
 201
 202 Casey
 203
 204 =head1 AUTHOR
 205
 206 Larry Wall
 207
 208 Changes by Jenda@Krynicky.cz and Dave Cottle <d.cottle@csc.canterbury.ac.nz>
 209
 210 Changes and bug fixes by Casey West <casey@geeknest.com>
 211
 212 =cut