Re: Dual life for Shell.pm

From: "Adriano Ferreira" <a.r.ferreira@gmail.com>
Message-ID: <73ddeb6c0607060902tc471f84sf1bb841b6e9ecddf@mail.gmail.com>

p4raw-id: //depot/perl@28502

diff --git a/lib/Shell.pm b/lib/Shell.pm
index a84d9a9..1acbba7 100644 (file)
--- a/lib/Shell.pm
+++ b/lib/Shell.pm
@@ -6,7 +6,7 @@ use File::Spec::Functions;
 
 our($capture_stderr, $raw, $VERSION, $AUTOLOAD);
 
-$VERSION = '0.6';
+$VERSION = '0.7';
 
 sub new { bless \my $foo, shift }
 sub DESTROY { }
@@ -16,9 +16,9 @@ sub import {
     my ($callpack, $callfile, $callline) = caller;
     my @EXPORT;
     if (@_) {
-       @EXPORT = @_;
+        @EXPORT = @_;
     } else {
-       @EXPORT = 'AUTOLOAD';
+        @EXPORT = 'AUTOLOAD';
     }
     foreach my $sym (@EXPORT) {
         no strict 'refs';
@@ -26,91 +26,112 @@ sub import {
     }
 }
 
-sub AUTOLOAD {
+# 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
+
+=item B<_make_cmd>
+
+  $sub = _make_cmd($cmd);
+  $sub = $shell->_make_cmd($cmd);
+
+Creates a closure which invokes the system command C<$cmd>.
+
+=cut
+
+sub _make_cmd {
     shift if ref $_[0] && $_[0]->isa( 'Shell' );
-    my $cmd = $AUTOLOAD;
-    $cmd =~ s/^.*:://;
+    my $cmd = shift;
     my $null = File::Spec::Functions::devnull();
     $Shell::capture_stderr ||= 0;
-    eval <<"*END*";
-       sub $AUTOLOAD {
-           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 ('$^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 = \@_;
-               unless( \$Shell::raw ){
-                 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;
-                       \$_ = \$_;
-                   }
+    # 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;
-               }
-           }
-       }
-*END*
-
-    die "$@\n" if $@;
+                }
+                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;
 }
 
@@ -237,4 +258,6 @@ 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

diff --git a/lib/Shell.t b/lib/Shell.t
index 106cd2a..51f54a1 100644 (file)
--- a/lib/Shell.t
+++ b/lib/Shell.t
@@ -1,8 +1,10 @@
 #!./perl
 
 BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
+    if( $ENV{PERL_CORE} ) {
+       chdir 't' if -d 't';
+       @INC = '../lib';
+    }
 }
 
 use Test::More tests => 7;