This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
support C<use Shell> on Windows (reworked a patch suggested
[perl5.git] / lib / Shell.pm
CommitLineData
a0d0e21e 1package Shell;
253924a2 2use vars qw($capture_stderr $VERSION);
a0d0e21e 3
253924a2 4$VERSION = '0.2';
4633a7c4 5
a0d0e21e
LW
6sub import {
7 my $self = shift;
8 my ($callpack, $callfile, $callline) = caller;
9 my @EXPORT;
10 if (@_) {
11 @EXPORT = @_;
12 }
13 else {
14 @EXPORT = 'AUTOLOAD';
15 }
16 foreach $sym (@EXPORT) {
17 *{"${callpack}::$sym"} = \&{"Shell::$sym"};
18 }
19};
20
21AUTOLOAD {
22 my $cmd = $AUTOLOAD;
23 $cmd =~ s/^.*:://;
253924a2
GS
24 eval <<"*END*";
25 sub $AUTOLOAD {
4633a7c4 26 if (\@_ < 1) {
253924a2 27 \$Shell::capture_stderr ? `$cmd 2>&1` : `$cmd`;
4633a7c4 28 }
253924a2 29 elsif ('$^O' eq 'os2') {
4633a7c4
LW
30 local(\*SAVEOUT, \*READ, \*WRITE);
31
32 open SAVEOUT, '>&STDOUT' or die;
33 pipe READ, WRITE or die;
34 open STDOUT, '>&WRITE' or die;
35 close WRITE;
36
253924a2
GS
37 my \$pid = system(1, '$cmd', \@_);
38 die "Can't execute $cmd: \$!\\n" if \$pid < 0;
4633a7c4
LW
39
40 open STDOUT, '>&SAVEOUT' or die;
41 close SAVEOUT;
42
43 if (wantarray) {
44 my \@ret = <READ>;
45 close READ;
46 waitpid \$pid, 0;
47 \@ret;
48 }
49 else {
50 local(\$/) = undef;
51 my \$ret = <READ>;
52 close READ;
53 waitpid \$pid, 0;
54 \$ret;
55 }
a0d0e21e
LW
56 }
57 else {
253924a2
GS
58 my \$a;
59 my \@arr = \@_;
60 if ('$^O' eq 'MSWin32') {
61 # XXX this special-casing should not be needed
62 # if we do quoting right on Windows. :-(
63 #
64 # First, escape all quotes. Cover the case where we
65 # want to pass along a quote preceded by a backslash
66 # (i.e., C<"param \\""" end">).
67 # Ugly, yup? You know, windoze.
68 # Enclose in quotes only the parameters that need it:
69 # try this: c:\> dir "/w"
70 # and this: c:\> dir /w
71 for (\@arr) {
72 s/"/\\\\"/g;
73 s/\\\\\\\\"/\\\\\\\\"""/g;
74 \$_ = qq["\$_"] if /\s/;
75 }
76 }
77 else {
78 for (\@arr) {
79 s/(['\\\\])/\\\\\$1/g;
80 \$_ = "'\$_'";
81 }
82 }
83 push \@arr, '2>&1' if \$Shell::capture_stderr;
84 open(SUBPROC, join(' ', '$cmd', \@arr, '|'))
85 or die "Can't exec $cmd: \$!\\n";
a0d0e21e
LW
86 if (wantarray) {
87 my \@ret = <SUBPROC>;
88 close SUBPROC; # XXX Oughta use a destructor.
89 \@ret;
90 }
91 else {
92 local(\$/) = undef;
93 my \$ret = <SUBPROC>;
94 close SUBPROC;
95 \$ret;
96 }
97 }
98 }
253924a2
GS
99*END*
100
101 die "$@\n" if $@;
a0d0e21e
LW
102 goto &$AUTOLOAD;
103}
104
1051;
a5f75d66
AD
106__END__
107
108=head1 NAME
109
110Shell - run shell commands transparently within perl
111
112=head1 SYNOPSIS
113
114See below.
115
116=head1 DESCRIPTION
117
118 Date: Thu, 22 Sep 94 16:18:16 -0700
119 Message-Id: <9409222318.AA17072@scalpel.netlabs.com>
120 To: perl5-porters@isu.edu
121 From: Larry Wall <lwall@scalpel.netlabs.com>
122 Subject: a new module I just wrote
123
124Here's one that'll whack your mind a little out.
125
126 #!/usr/bin/perl
127
128 use Shell;
129
130 $foo = echo("howdy", "<funny>", "world");
131 print $foo;
132
133 $passwd = cat("</etc/passwd");
134 print $passwd;
135
136 sub ps;
137 print ps -ww;
138
139 cp("/etc/passwd", "/tmp/passwd");
140
141That's maybe too gonzo. It actually exports an AUTOLOAD to the current
142package (and uncovered a bug in Beta 3, by the way). Maybe the usual
143usage should be
144
145 use Shell qw(echo cat ps cp);
146
147Larry
148
149
253924a2
GS
150If you set $Shell::capture_stderr to 1, the module will attempt to
151capture the STDERR of the process as well.
152
153The module now should work on Win32.
154
155 Jenda
156
a5f75d66
AD
157=head1 AUTHOR
158
159Larry Wall
160
253924a2
GS
161Changes by Jenda@Krynicky.cz and Dave Cottle <d.cottle@csc.canterbury.ac.nz>
162
a5f75d66 163=cut