PPPort update from Paul Marquess.

p4raw-id: //depot/perl@13434

1 files changed, 115 insertions, 45 deletions

diff --git a/ext/Devel/PPPort/soak b/ext/Devel/PPPort/soak
index 35afd320df..5ff5b41c9d 100644
--- a/ext/Devel/PPPort/soak
+++ b/ext/Devel/PPPort/soak
@@ -1,56 +1,41 @@
 
+# soak: Test Devel::PPPort with multiple versions of Perl.
+#
+# Author:	Paul Marquess
+#
+
+require 5.006001;
 
 use strict ;
+use warnings ;
 use ExtUtils::MakeMaker;
+use Getopt::Long;
+
+my $VERSION = "1.000";
 
 $| = 1 ;
 my $verbose = 0 ;
 
-# TODO -- Get MM->new to output less MakeMaker progress guff
-my $mm = MM->new( { NAME => 'dummy' });
-
 # TODO -- determine what "make" program to run.
 my $MAKE = 'make';
 
+my $result = GetOptions(
+	"verbose"	=> \$verbose,
+	"make=s"	=> \$MAKE,
+	) or Usage();
 
-# TODO -- need to decide how far back we go.
+my @GoodPerls = ();
 
-# find all version of Perl that are available
-my @PerlBinaries = qw( 
-	5.004        
-	5.00401      
-	5.00402      
-	5.00403      
-	5.00404      
-	5.00405      
-	5.005                         
-	5.00501                       
-	5.00502      
-	5.00503                     
-	5.6.0        
-	5.6.1 
-	5.7.0
-	5.7.1
-	5.7.2      
-	);
+if (@ARGV)
+  { @GoodPerls = @ARGV }
+else 
+  { @GoodPerls = FindPerls() }
 
-print "Searching for Perl binaries...\n" ;
-my @GoodPerls = ();
 my $maxlen = 0;
-my @path = $mm->path();
-foreach my $perl (@PerlBinaries) {
-    # TODO -- find_perl will send a warning to STDOUT if it can't find 
-    #         the requested perl, so need to temporarily close STDOUT.
-
-    if (my $abs = $mm->find_perl($perl, ["perl$perl"], [@path], 0)) {
-        push @GoodPerls, $abs ;
-        $maxlen = length $abs
-             if length $abs > $maxlen ;
-    }
+foreach (@GoodPerls) {
+    $maxlen = length $_
+        if length $_ > $maxlen ;
 }
-print "\n\nFound ";
-foreach (@GoodPerls) { print "$_\n" }
-print "\n\n";
 $maxlen += 3 ;
 
 # run each through the test harness
@@ -83,7 +68,7 @@ foreach my $perl (@GoodPerls)
 
 }
 
-print "\n\nPassed with $good of $total versions of Perl.\n";
+print "\n\nPassed with $good of $total versions of Perl.\n\n";
 exit $bad ;
 
 
@@ -93,17 +78,102 @@ sub runit
 
     my $cmd = shift ;
     print "\n    Running [$cmd]\n" if $verbose ;
-    my $file = "/tmp/abc.$$" ;
-    unlink $file ;
     my $output = `$cmd 2>&1` ;
+    $output = "\n" unless defined $output;
     $output =~ s/^/      /gm;
-    print "    Output\n$output\n" if $verbose || $? ;
+    print "\n    Output\n$output\n" if $verbose || $? ;
     if ($?)
     {
-        return 0 unless $verbose ;
-        warn "    $cmd failed: $?\n" ;
-        exit ;
+        warn "    Running '$cmd' failed: $?\n" ;
+        return 0 ;
     }
-    unlink $file ;
     return 1 ;
 }                   
+
+sub Usage
+{
+    die <<EOM;
+
+usage: soak [OPT] [perl...]
+
+  OPT
+    -m make	- the name of the make program. Default "make"
+    -v		- verbose
+
+EOM
+
+}
+
+sub FindPerls
+{
+    # TODO -- need to decide how far back we go.
+    # TODO -- get list of user releases prior to 5.004
+
+    # find all version of Perl that are available
+    my @PerlBinaries = qw( 
+	5.000        
+	5.001        
+	5.002        
+	5.003        
+	5.004        
+	5.00401      
+	5.00402      
+	5.00403      
+	5.00404      
+	5.00405      
+	5.005                         
+	5.00501                       
+	5.00502      
+	5.00503                     
+	5.6.0        
+	5.6.1 
+	5.7.0
+	5.7.1
+	5.7.2      
+	);
+
+    print "Searching for Perl binaries...\n" ;
+    my @GoodPerls = ();
+    my $maxlen = 0;
+    my $mm = MM->new( { NAME => 'dummy' });
+    my @path = $mm->path();
+
+    # find_perl will send a warning to STDOUT if it can't find 
+    # the requested perl, so need to temporarily silence STDOUT.
+    tie(*STDOUT, 'NoSTDOUT');
+
+    foreach my $perl (@PerlBinaries) {
+        if (my $abs = $mm->find_perl($perl, ["perl$perl"], [@path], 0)) {
+            push @GoodPerls, $abs ;
+        }
+    }
+    untie *STDOUT;
+    
+    print "\n\nFound\n";
+    foreach (@GoodPerls) { print "    $_\n" }
+    print "\n\n";
+
+    return @GoodPerls;
+}
+
+package NoSTDOUT;
+
+use Tie::Handle;
+our @ISA = qw(Tie::Handle);
+
+sub TIEHANDLE 
+{
+    my ($class) = @_;
+    my $buf = "";
+    bless \$buf, $class;
+}
+ 
+sub PRINT 
+{
+    my $self = shift;
+}                
+ 
+sub WRITE 
+{
+    my $self = shift;
+}