Leaked source code of windows server 2003
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

201 lines
4.1 KiB

package Shell;
use 5.005_64;
use strict;
use warnings;
our($capture_stderr, $VERSION, $AUTOLOAD);
$VERSION = '0.3';
sub new { bless \$VERSION, shift } # Nothing better to bless
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/^.*:://;
eval <<"*END*";
sub $AUTOLOAD {
if (\@_ < 1) {
\$Shell::capture_stderr ? `$cmd 2>&1` : `$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;
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: <[email protected]>
To: [email protected]
From: Larry Wall <[email protected]>
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", "/tmp/passwd");
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.
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 [email protected] and Dave Cottle <[email protected]>
Changes and bug fixes by Casey Tweten <[email protected]>
=cut