This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
66a0c6b0e11ebc32ddc99be1cd52390b16373758
[perl5.git] / cpan / Shell / Shell.pm
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.72_01';
10 $VERSION = eval $VERSION;
11
12 use if $] >= 5.011, 'deprecate';
13
14 sub new { bless \my $foo, shift }
15 sub DESTROY { }
16
17 sub import {
18     my $self = shift;
19     my ($callpack, $callfile, $callline) = caller;
20     my @EXPORT;
21     if (@_) {
22         @EXPORT = @_;
23     } else {
24         @EXPORT = 'AUTOLOAD';
25     }
26     foreach my $sym (@EXPORT) {
27         no strict 'refs';
28         *{"${callpack}::$sym"} = \&{"Shell::$sym"};
29     }
30 }
31
32 # NOTE: this is used to enable constant folding in 
33 # expressions like (OS eq 'MSWin32') and 
34 # (OS eq 'os2') just like it happened in  0.6  version 
35 # which used eval "string" to install subs on the fly.
36 use constant OS => $^O;
37
38 =begin private
39
40 =item B<_make_cmd>
41
42   $sub = _make_cmd($cmd);
43   $sub = $shell->_make_cmd($cmd);
44
45 Creates a closure which invokes the system command C<$cmd>.
46
47 =end private
48
49 =cut
50
51 sub _make_cmd {
52     shift if ref $_[0] && $_[0]->isa( 'Shell' );
53     my $cmd = shift;
54     my $null = File::Spec::Functions::devnull();
55     $Shell::capture_stderr ||= 0;
56     # closing over $^O, $cmd, and $null
57     return sub {
58             shift if ref $_[0] && $_[0]->isa( 'Shell' );
59             if (@_ < 1) {
60                 $Shell::capture_stderr ==  1 ? `$cmd 2>&1` : 
61                 $Shell::capture_stderr == -1 ? `$cmd 2>$null` : 
62                 `$cmd`;
63             } elsif (OS eq 'os2') {
64                 local(*SAVEOUT, *READ, *WRITE);
65
66                 open SAVEOUT, '>&STDOUT' or die;
67                 pipe READ, WRITE or die;
68                 open STDOUT, '>&WRITE' or die;
69                 close WRITE;
70
71                 my $pid = system(1, $cmd, @_);
72                 die "Can't execute $cmd: $!\n" if $pid < 0;
73
74                 open STDOUT, '>&SAVEOUT' or die;
75                 close SAVEOUT;
76
77                 if (wantarray) {
78                     my @ret = <READ>;
79                     close READ;
80                     waitpid $pid, 0;
81                     @ret;
82                 } else {
83                     local($/) = undef;
84                     my $ret = <READ>;
85                     close READ;
86                     waitpid $pid, 0;
87                     $ret;
88                 }
89             } else {
90                 my $a;
91                 my @arr = @_;
92                 unless( $Shell::raw ){
93                   if (OS eq 'MSWin32') {
94                     # XXX this special-casing should not be needed
95                     # if we do quoting right on Windows. :-(
96                     #
97                     # First, escape all quotes.  Cover the case where we
98                     # want to pass along a quote preceded by a backslash
99                     # (i.e., C<"param \""" end">).
100                     # Ugly, yup?  You know, windoze.
101                     # Enclose in quotes only the parameters that need it:
102                     #   try this: c:> dir "/w"
103                     #   and this: c:> dir /w
104                     for (@arr) {
105                         s/"/\\"/g;
106                         s/\\\\"/\\\\"""/g;
107                         $_ = qq["$_"] if /\s/;
108                     }
109                   } else {
110                     for (@arr) {
111                         s/(['\\])/\\$1/g;
112                         $_ = $_;
113                      }
114                   }
115                 }
116                 push @arr, '2>&1'        if $Shell::capture_stderr ==  1;
117                 push @arr, '2>$null' if $Shell::capture_stderr == -1;
118                 open(SUBPROC, join(' ', $cmd, @arr, '|'))
119                     or die "Can't exec $cmd: $!\n";
120                 if (wantarray) {
121                     my @ret = <SUBPROC>;
122                     close SUBPROC;        # XXX Oughta use a destructor.
123                     @ret;
124                 } else {
125                     local($/) = undef;
126                     my $ret = <SUBPROC>;
127                     close SUBPROC;
128                     $ret;
129                 }
130             }
131         };
132         }
133
134 sub AUTOLOAD {
135     shift if ref $_[0] && $_[0]->isa( 'Shell' );
136     my $cmd = $AUTOLOAD;
137     $cmd =~ s/^.*:://;
138     no strict 'refs';
139     *$AUTOLOAD = _make_cmd($cmd);
140     goto &$AUTOLOAD;
141 }
142
143 1;
144
145 __END__
146
147 =head1 NAME
148
149 Shell - run shell commands transparently within perl
150
151 =head1 SYNOPSIS
152
153    use Shell qw(cat ps cp);
154    $passwd = cat('</etc/passwd');
155    @pslines = ps('-ww'),
156    cp("/etc/passwd", "/tmp/passwd");
157
158    # object oriented 
159    my $sh = Shell->new;
160    print $sh->ls('-l');
161
162 =head1 DESCRIPTION
163
164 =head2 Caveats
165
166 This package is included as a show case, illustrating a few Perl features.
167 It shouldn't be used for production programs. Although it does provide a 
168 simple interface for obtaining the standard output of arbitrary commands,
169 there may be better ways of achieving what you need.
170
171 Running shell commands while obtaining standard output can be done with the
172 C<qx/STRING/> operator, or by calling C<open> with a filename expression that
173 ends with C<|>, giving you the option to process one line at a time.
174 If you don't need to process standard output at all, you might use C<system>
175 (in preference of doing a print with the collected standard output).
176
177 Since Shell.pm and all of the aforementioned techniques use your system's
178 shell to call some local command, none of them is portable across different 
179 systems. Note, however, that there are several built in functions and 
180 library packages providing portable implementations of functions operating
181 on files, such as: C<glob>, C<link> and C<unlink>, C<mkdir> and C<rmdir>, 
182 C<rename>, C<File::Compare>, C<File::Copy>, C<File::Find> etc.
183
184 Using Shell.pm while importing C<foo> creates a subroutine C<foo> in the
185 namespace of the importing package. Calling C<foo> with arguments C<arg1>,
186 C<arg2>,... results in a shell command C<foo arg1 arg2...>, where the 
187 function name and the arguments are joined with a blank. (See the subsection 
188 on Escaping magic characters.) Since the result is essentially a command
189 line to be passed to the shell, your notion of arguments to the Perl
190 function is not necessarily identical to what the shell treats as a
191 command line token, to be passed as an individual argument to the program.
192 Furthermore, note that this implies that C<foo> is callable by file name
193 only, which frequently depends on the setting of the program's environment.
194
195 Creating a Shell object gives you the opportunity to call any command
196 in the usual OO notation without requiring you to announce it in the
197 C<use Shell> statement. Don't assume any additional semantics being
198 associated with a Shell object: in no way is it similar to a shell
199 process with its environment or current working directory or any
200 other setting.
201
202 =head2 Escaping Magic Characters
203
204 It is, in general, impossible to take care of quoting the shell's
205 magic characters. For some obscure reason, however, Shell.pm quotes
206 apostrophes (C<'>) and backslashes (C<\>) on UNIX, and spaces and
207 quotes (C<">) on Windows.
208
209 =head2 Configuration
210
211 If you set $Shell::capture_stderr to 1, the module will attempt to
212 capture the standard error output of the process as well. This is
213 done by adding C<2E<gt>&1> to the command line, so don't try this on
214 a system not supporting this redirection.
215
216 Setting $Shell::capture_stderr to -1 will send standard error to the
217 bit bucket (i.e., the equivalent of adding C<2E<gt>/dev/null> to the
218 command line).  The same caveat regarding redirection applies.
219
220 If you set $Shell::raw to true no quoting whatsoever is done.
221
222 =head1 BUGS
223
224 Quoting should be off by default.
225
226 It isn't possible to call shell built in commands, but it can be
227 done by using a workaround, e.g. shell( '-c', 'set' ).
228
229 Capturing standard error does not work on some systems (e.g. VMS).
230
231 =head1 AUTHOR
232
233   Date: Thu, 22 Sep 94 16:18:16 -0700
234   Message-Id: <9409222318.AA17072@scalpel.netlabs.com>
235   To: perl5-porters@isu.edu
236   From: Larry Wall <lwall@scalpel.netlabs.com>
237   Subject: a new module I just wrote
238
239 Here's one that'll whack your mind a little out.
240
241     #!/usr/bin/perl
242
243     use Shell;
244
245     $foo = echo("howdy", "<funny>", "world");
246     print $foo;
247
248     $passwd = cat("</etc/passwd");
249     print $passwd;
250
251     sub ps;
252     print ps -ww;
253
254     cp("/etc/passwd", "/etc/passwd.orig");
255
256 That's maybe too gonzo.  It actually exports an AUTOLOAD to the current
257 package (and uncovered a bug in Beta 3, by the way).  Maybe the usual
258 usage should be
259
260     use Shell qw(echo cat ps cp);
261
262 Larry Wall
263
264 Changes by Jenda@Krynicky.cz and Dave Cottle <d.cottle@csc.canterbury.ac.nz>.
265
266 Changes for OO syntax and bug fixes by Casey West <casey@geeknest.com>.
267
268 C<$Shell::raw> and pod rewrite by Wolfgang Laun.
269
270 Rewritten to use closures rather than C<eval "string"> by Adriano Ferreira.
271
272 =cut