lib/perl5/5.6.1/Shell.pm

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