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