new version of runperl()

Message-ID: <20011114122301.A29384@rafael>

p4raw-id: //depot/perl@12993

diff --git a/t/io/argv.t b/t/io/argv.t
index 7081c47..56b5714 100755 (executable)
--- a/t/io/argv.t
+++ b/t/io/argv.t
@@ -5,34 +5,8 @@ BEGIN {
     @INC = '../lib';
 }
 
-sub runthis {
-    my($prog, $stdin, @files) = @_;
-
-    my $cmd = '';
-    if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS' ) {
-        $cmd = qq{$^X -e "$prog"};
-        $cmd .= " ". join ' ', map qq{"$_"}, @files if @files;
-        $cmd = qq{$^X -le "print '$stdin'" | } . $cmd if defined $stdin;
-    }
-    else {
-        $cmd = qq{$^X -e '$prog' @files};
-        $cmd = qq{$^X -le 'print q{$stdin}' | } . $cmd if defined $stdin;
-    }
-
-    # The combination of $^X, pipes and STDIN is broken on VMS and
-    # will hang.
-    if( defined $stdin && $^O eq 'VMS' && $TODO ) {
-        return 0;
-    }
-
-    my $result = `$cmd`;
-    $result =~ s/\n\n/\n/ if $^O eq 'VMS'; # pipes sometimes double these
-
-    return $result;
-}
-
-    
 require "./test.pl";
+
 plan(tests => 21);
 
 use File::Spec;
@@ -43,16 +17,24 @@ open(TRY, '>Io_argv1.tmp') || (die "Can't open temp file: $!");
 print TRY "a line\n";
 close TRY;
 
-$x = runthis( 'while (<>) { print $., $_; }', undef, ('Io_argv1.tmp') x 2);
+$x = runperl(
+    prog       => 'while (<>) { print $., $_; }',
+    args       => [ 'Io_argv1.tmp', 'Io_argv1.tmp' ],
+);
 is($x, "1a line\n2a line\n", '<> from two files');
 
 {
-    local $TODO = 'The combo of STDIN, pipes and $^X is broken on VMS'
-      if $^O eq 'VMS';
-    $x = runthis( 'while (<>) { print $_; }', 'foo', 'Io_argv1.tmp', '-' );
+    $x = runperl(
+       prog    => 'while (<>) { print $_; }',
+       stdin   => "foo\n",
+       args    => [ 'Io_argv1.tmp', '-' ],
+    );
     is($x, "a line\nfoo\n", '   from a file and STDIN');
 
-    $x = runthis( 'while (<>) {print $_;}', 'foo' );
+    $x = runperl(
+       prog    => 'while (<>) { print $_; }',
+       stdin   => "foo\n",
+    );
     is($x, "foo\n", '   from just STDIN');
 }
 

diff --git a/t/test.pl b/t/test.pl
index eaf9d86..b53f020 100644 (file)
--- a/t/test.pl
+++ b/t/test.pl
@@ -169,4 +169,63 @@ USE_OK
     _ok(!$@, _where(), "use $use");
 }
 
+# runperl - Runs a separate perl interpreter.
+# Arguments :
+#   switches => [ command-line switches ]
+#   nolib    => 1 # don't use -I../lib (included by default)
+#   prog     => one-liner (avoid quotes)
+#   progfile => perl script
+#   stdin    => string to feed the stdin
+#   stderr   => redirect stderr to stdout
+#   args     => [ command-line arguments to the perl program ]
+
+my $is_mswin    = $^O eq 'MSWin32';
+my $is_netware  = $^O eq 'NetWare';
+my $is_macos    = $^O eq 'MacOS';
+my $is_vms      = $^O eq 'VMS';
+
+sub runperl {
+    my %args = @_;
+    my $runperl = $^X;
+    if (defined $args{switches}) {
+       $runperl .= ' ' . join ' ', map qq("$_"), @{ $args{switches} };
+    }
+    unless (defined $args{nolib}) {
+       if ($is_macos && $args{stderr}) {
+           $runperl .= ' -I::lib -MMac::err=unix';
+       }
+       else {
+           $runperl .= ' "-I../lib"';
+       }
+    }
+    if (defined $args{prog}) {
+       if ($is_mswin || $is_netware || $is_vms) {
+           $runperl .= qq( -e ") . $args{prog} . qq(");
+       }
+       else {
+           $runperl .= qq( -e ') . $args{prog} . qq(');
+       }
+    } elsif (defined $args{progfile}) {
+       $runperl .= qq( "$args{progfile}");
+    }
+    if (defined $args{stdin}) {
+       if ($is_mswin || $is_netware || $is_vms) {
+           $runperl = qq{$^X -e "print q(} .
+               $args{stdin} . q{)" | } . $runperl;
+       }
+       else {
+           $runperl = qq{$^X -e 'print q(} .
+               $args{stdin} . q{)' | } . $runperl;
+       }
+    }
+    if (defined $args{args}) {
+       $runperl .= ' ' . join ' ', map qq("$_"), @{ $args{args} };
+    }
+    $runperl .= ' 2>&1' if $args{stderr} && !$is_macos;
+    $runperl .= " \xB3 Dev:Null" if !defined $args{stderr} && $is_macos;
+    my $result = `$runperl`;
+    $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these
+    return $result;
+}
+
 1;