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