1 | package Shell;
|
---|
2 | use 5.006_001;
|
---|
3 | use strict;
|
---|
4 | use warnings;
|
---|
5 | use File::Spec::Functions;
|
---|
6 |
|
---|
7 | our($capture_stderr, $raw, $VERSION, $AUTOLOAD);
|
---|
8 |
|
---|
9 | $VERSION = '0.6';
|
---|
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 | unless( \$Shell::raw ){
|
---|
72 | if ('$^O' eq 'MSWin32') {
|
---|
73 | # XXX this special-casing should not be needed
|
---|
74 | # if we do quoting right on Windows. :-(
|
---|
75 | #
|
---|
76 | # First, escape all quotes. Cover the case where we
|
---|
77 | # want to pass along a quote preceded by a backslash
|
---|
78 | # (i.e., C<"param \\""" end">).
|
---|
79 | # Ugly, yup? You know, windoze.
|
---|
80 | # Enclose in quotes only the parameters that need it:
|
---|
81 | # try this: c:\> dir "/w"
|
---|
82 | # and this: c:\> dir /w
|
---|
83 | for (\@arr) {
|
---|
84 | s/"/\\\\"/g;
|
---|
85 | s/\\\\\\\\"/\\\\\\\\"""/g;
|
---|
86 | \$_ = qq["\$_"] if /\\s/;
|
---|
87 | }
|
---|
88 | } else {
|
---|
89 | for (\@arr) {
|
---|
90 | s/(['\\\\])/\\\\\$1/g;
|
---|
91 | \$_ = \$_;
|
---|
92 | }
|
---|
93 | }
|
---|
94 | }
|
---|
95 | push \@arr, '2>&1' if \$Shell::capture_stderr == 1;
|
---|
96 | push \@arr, '2>$null' if \$Shell::capture_stderr == -1;
|
---|
97 | open(SUBPROC, join(' ', '$cmd', \@arr, '|'))
|
---|
98 | or die "Can't exec $cmd: \$!\\n";
|
---|
99 | if (wantarray) {
|
---|
100 | my \@ret = <SUBPROC>;
|
---|
101 | close SUBPROC; # XXX Oughta use a destructor.
|
---|
102 | \@ret;
|
---|
103 | } else {
|
---|
104 | local(\$/) = undef;
|
---|
105 | my \$ret = <SUBPROC>;
|
---|
106 | close SUBPROC;
|
---|
107 | \$ret;
|
---|
108 | }
|
---|
109 | }
|
---|
110 | }
|
---|
111 | *END*
|
---|
112 |
|
---|
113 | die "$@\n" if $@;
|
---|
114 | goto &$AUTOLOAD;
|
---|
115 | }
|
---|
116 |
|
---|
117 | 1;
|
---|
118 |
|
---|
119 | __END__
|
---|
120 |
|
---|
121 | =head1 NAME
|
---|
122 |
|
---|
123 | Shell - run shell commands transparently within perl
|
---|
124 |
|
---|
125 | =head1 SYNOPSIS
|
---|
126 |
|
---|
127 | use Shell qw(cat ps cp);
|
---|
128 | $passwd = cat('</etc/passwd');
|
---|
129 | @pslines = ps('-ww'),
|
---|
130 | cp("/etc/passwd", "/tmp/passwd");
|
---|
131 |
|
---|
132 | # object oriented
|
---|
133 | my $sh = Shell->new;
|
---|
134 | print $sh->ls('-l');
|
---|
135 |
|
---|
136 | =head1 DESCRIPTION
|
---|
137 |
|
---|
138 | =head2 Caveats
|
---|
139 |
|
---|
140 | This package is included as a show case, illustrating a few Perl features.
|
---|
141 | It shouldn't be used for production programs. Although it does provide a
|
---|
142 | simple interface for obtaining the standard output of arbitrary commands,
|
---|
143 | there may be better ways of achieving what you need.
|
---|
144 |
|
---|
145 | Running shell commands while obtaining standard output can be done with the
|
---|
146 | C<qx/STRING/> operator, or by calling C<open> with a filename expression that
|
---|
147 | ends with C<|>, giving you the option to process one line at a time.
|
---|
148 | If you don't need to process standard output at all, you might use C<system>
|
---|
149 | (in preference of doing a print with the collected standard output).
|
---|
150 |
|
---|
151 | Since Shell.pm and all of the aforementioned techniques use your system's
|
---|
152 | shell to call some local command, none of them is portable across different
|
---|
153 | systems. Note, however, that there are several built in functions and
|
---|
154 | library packages providing portable implementations of functions operating
|
---|
155 | on files, such as: C<glob>, C<link> and C<unlink>, C<mkdir> and C<rmdir>,
|
---|
156 | C<rename>, C<File::Compare>, C<File::Copy>, C<File::Find> etc.
|
---|
157 |
|
---|
158 | Using Shell.pm while importing C<foo> creates a subroutine C<foo> in the
|
---|
159 | namespace of the importing package. Calling C<foo> with arguments C<arg1>,
|
---|
160 | C<arg2>,... results in a shell command C<foo arg1 arg2...>, where the
|
---|
161 | function name and the arguments are joined with a blank. (See the subsection
|
---|
162 | on Escaping magic characters.) Since the result is essentially a command
|
---|
163 | line to be passed to the shell, your notion of arguments to the Perl
|
---|
164 | function is not necessarily identical to what the shell treats as a
|
---|
165 | command line token, to be passed as an individual argument to the program.
|
---|
166 | Furthermore, note that this implies that C<foo> is callable by file name
|
---|
167 | only, which frequently depends on the setting of the program's environment.
|
---|
168 |
|
---|
169 | Creating a Shell object gives you the opportunity to call any command
|
---|
170 | in the usual OO notation without requiring you to announce it in the
|
---|
171 | C<use Shell> statement. Don't assume any additional semantics being
|
---|
172 | associated with a Shell object: in no way is it similar to a shell
|
---|
173 | process with its environment or current working directory or any
|
---|
174 | other setting.
|
---|
175 |
|
---|
176 | =head2 Escaping Magic Characters
|
---|
177 |
|
---|
178 | It is, in general, impossible to take care of quoting the shell's
|
---|
179 | magic characters. For some obscure reason, however, Shell.pm quotes
|
---|
180 | apostrophes (C<'>) and backslashes (C<\>) on UNIX, and spaces and
|
---|
181 | quotes (C<">) on Windows.
|
---|
182 |
|
---|
183 | =head2 Configuration
|
---|
184 |
|
---|
185 | If you set $Shell::capture_stderr to true, the module will attempt to
|
---|
186 | capture the standard error output of the process as well. This is
|
---|
187 | done by adding C<2E<gt>&1> to the command line, so don't try this on
|
---|
188 | a system not supporting this redirection.
|
---|
189 |
|
---|
190 | If you set $Shell::raw to true no quoting whatsoever is done.
|
---|
191 |
|
---|
192 | =head1 BUGS
|
---|
193 |
|
---|
194 | Quoting should be off by default.
|
---|
195 |
|
---|
196 | It isn't possible to call shell built in commands, but it can be
|
---|
197 | done by using a workaround, e.g. shell( '-c', 'set' ).
|
---|
198 |
|
---|
199 | Capturing standard error does not work on some systems (e.g. VMS).
|
---|
200 |
|
---|
201 | =head1 AUTHOR
|
---|
202 |
|
---|
203 | Date: Thu, 22 Sep 94 16:18:16 -0700
|
---|
204 | Message-Id: <[email protected]>
|
---|
205 | To: [email protected]
|
---|
206 | From: Larry Wall <[email protected]>
|
---|
207 | Subject: a new module I just wrote
|
---|
208 |
|
---|
209 | Here's one that'll whack your mind a little out.
|
---|
210 |
|
---|
211 | #!/usr/bin/perl
|
---|
212 |
|
---|
213 | use Shell;
|
---|
214 |
|
---|
215 | $foo = echo("howdy", "<funny>", "world");
|
---|
216 | print $foo;
|
---|
217 |
|
---|
218 | $passwd = cat("</etc/passwd");
|
---|
219 | print $passwd;
|
---|
220 |
|
---|
221 | sub ps;
|
---|
222 | print ps -ww;
|
---|
223 |
|
---|
224 | cp("/etc/passwd", "/etc/passwd.orig");
|
---|
225 |
|
---|
226 | That's maybe too gonzo. It actually exports an AUTOLOAD to the current
|
---|
227 | package (and uncovered a bug in Beta 3, by the way). Maybe the usual
|
---|
228 | usage should be
|
---|
229 |
|
---|
230 | use Shell qw(echo cat ps cp);
|
---|
231 |
|
---|
232 | Larry Wall
|
---|
233 |
|
---|
234 | Changes by [email protected] and Dave Cottle <[email protected]>.
|
---|
235 |
|
---|
236 | Changes for OO syntax and bug fixes by Casey West <[email protected]>.
|
---|
237 |
|
---|
238 | C<$Shell::raw> and pod rewrite by Wolfgang Laun.
|
---|
239 |
|
---|
240 | =cut
|
---|