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