lib/Shell.pm

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