| 1 | package Shell; |
| 2 | use 5.006_001; |
| 3 | use strict; |
| 4 | use warnings; |
| 5 | our($capture_stderr, $VERSION, $AUTOLOAD); |
| 6 | |
| 7 | $VERSION = '0.4'; |
| 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 West <casey@geeknest.com> |
| 200 | |
| 201 | =cut |