[perl5.git] / lib / Shell.pm

package Shell;
use 5.006_001;
use strict;
use warnings;
use File::Spec::Functions;

our($capture_stderr, $raw, $VERSION, $AUTOLOAD);

$VERSION = '0.7';

sub new { bless \my $foo, shift }
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"};
    }
}

# NOTE: this is used to enable constant folding in 
# expressions like (OS eq 'MSWin32') and 
# (OS eq 'os2') just like it happened in  0.6  version 
# which used eval "string" to install subs on the fly.
use constant OS => $^O;

=begin private

=over

=item B<_make_cmd>

  $sub = _make_cmd($cmd);
  $sub = $shell->_make_cmd($cmd);

Creates a closure which invokes the system command C<$cmd>.

=back

=end private

=cut

sub _make_cmd {
    shift if ref $_[0] && $_[0]->isa( 'Shell' );
    my $cmd = shift;
    my $null = File::Spec::Functions::devnull();
    $Shell::capture_stderr ||= 0;
    # closing over $^O, $cmd, and $null
    return sub {
            shift if ref $_[0] && $_[0]->isa( 'Shell' );
            if (@_ < 1) {
                $Shell::capture_stderr ==  1 ? `$cmd 2>&1` : 
                $Shell::capture_stderr == -1 ? `$cmd 2>$null` : 
                `$cmd`;
            } elsif (OS 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 = @_;
                unless( $Shell::raw ){
                  if (OS 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 ==  1;
                push @arr, '2>$null' if $Shell::capture_stderr == -1;
                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;
                }
            }
        };
        }

sub AUTOLOAD {
    shift if ref $_[0] && $_[0]->isa( 'Shell' );
    my $cmd = $AUTOLOAD;
    $cmd =~ s/^.*:://;
    no strict 'refs';
    *$AUTOLOAD = _make_cmd($cmd);
    goto &$AUTOLOAD;
}

1;

__END__

=head1 NAME

Shell - run shell commands transparently within perl

=head1 SYNOPSIS

   use Shell qw(cat ps cp);
   $passwd = cat('</etc/passwd');
   @pslines = ps('-ww'),
   cp("/etc/passwd", "/tmp/passwd");

   # object oriented 
   my $sh = Shell->new;
   print $sh->ls('-l');

=head1 DESCRIPTION

=head2 Caveats

This package is included as a show case, illustrating a few Perl features.
It shouldn't be used for production programs. Although it does provide a 
simple interface for obtaining the standard output of arbitrary commands,
there may be better ways of achieving what you need.

Running shell commands while obtaining standard output can be done with the
C<qx/STRING/> operator, or by calling C<open> with a filename expression that
ends with C<|>, giving you the option to process one line at a time.
If you don't need to process standard output at all, you might use C<system>
(in preference of doing a print with the collected standard output).

Since Shell.pm and all of the aforementioned techniques use your system's
shell to call some local command, none of them is portable across different 
systems. Note, however, that there are several built in functions and 
library packages providing portable implementations of functions operating
on files, such as: C<glob>, C<link> and C<unlink>, C<mkdir> and C<rmdir>, 
C<rename>, C<File::Compare>, C<File::Copy>, C<File::Find> etc.

Using Shell.pm while importing C<foo> creates a subroutine C<foo> in the
namespace of the importing package. Calling C<foo> with arguments C<arg1>,
C<arg2>,... results in a shell command C<foo arg1 arg2...>, where the 
function name and the arguments are joined with a blank. (See the subsection 
on Escaping magic characters.) Since the result is essentially a command
line to be passed to the shell, your notion of arguments to the Perl
function is not necessarily identical to what the shell treats as a
command line token, to be passed as an individual argument to the program.
Furthermore, note that this implies that C<foo> is callable by file name
only, which frequently depends on the setting of the program's environment.

Creating a Shell object gives you the opportunity to call any command
in the usual OO notation without requiring you to announce it in the
C<use Shell> statement. Don't assume any additional semantics being
associated with a Shell object: in no way is it similar to a shell
process with its environment or current working directory or any
other setting.

=head2 Escaping Magic Characters

It is, in general, impossible to take care of quoting the shell's
magic characters. For some obscure reason, however, Shell.pm quotes
apostrophes (C<'>) and backslashes (C<\>) on UNIX, and spaces and
quotes (C<">) on Windows.

=head2 Configuration

If you set $Shell::capture_stderr to true, the module will attempt to
capture the standard error output of the process as well. This is
done by adding C<2E<gt>&1> to the command line, so don't try this on
a system not supporting this redirection.

If you set $Shell::raw to true no quoting whatsoever is done.

=head1 BUGS

Quoting should be off by default.

It isn't possible to call shell built in commands, but it can be
done by using a workaround, e.g. shell( '-c', 'set' ).

Capturing standard error does not work on some systems (e.g. VMS).

=head1 AUTHOR

  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", "/etc/passwd.orig");

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 Wall

Changes by Jenda@Krynicky.cz and Dave Cottle <d.cottle@csc.canterbury.ac.nz>.

Changes for OO syntax and bug fixes by Casey West <casey@geeknest.com>.

C<$Shell::raw> and pod rewrite by Wolfgang Laun.

Rewritten to use closures rather than C<eval "string"> by Adriano Ferreira.

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