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