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

2 files changed, 111 insertions, 86 deletions

diff --git a/lib/Shell.pm b/lib/Shell.pm
index a84d9a9f67..1acbba7a2c 100644
--- 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 106cd2a51d..51f54a1bf8 100644
--- 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;