scripts/sshwrap/Shell.pm

package Shell;
use 5.005_64;
use strict;
use warnings;
our($capture_stderr, $VERSION, $AUTOLOAD);

$VERSION = '0.4';

sub new { bless \$VERSION, shift } # Nothing better to bless
sub DESTROY { }

sub get_coderef {
  my $codepack = shift;
  my $method = shift;
  $codepack || return '[error]';
  $method ||= '';
  $method && ($codepack .= '::');
  return eval '\&' . $codepack . $method . ';';
}

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"} = get_coderef($self, $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: <9409222318.AA17072@scalpel.netlabs.com>
  To: perl5-porters@isu.edu
  From: Larry Wall <lwall@scalpel.netlabs.com>
  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 Jenda@Krynicky.cz and Dave Cottle <d.cottle@csc.canterbury.ac.nz>

Changes and bug fixes by Casey Tweten <crt@kiski.net>

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