Remove an unreferenced local variable in Digest-MD5

[p5sagit/p5-mst-13.2.git] / ext / Devel / PPPort / soak

#!/usr/bin/perl -w
################################################################################
#
#  soak -- Test Devel::PPPort with multiple versions of Perl.
#
#  Original Author: Paul Marquess
#
################################################################################
#
#  $Revision: 7 $
#  $Author: mhx $
#  $Date: 2005/01/31 08:10:55 +0100 $
#
################################################################################
#
#  Version 3.x, Copyright (C) 2004-2005, Marcus Holland-Moritz.
#  Version 2.x, Copyright (C) 2001, Paul Marquess.
#  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
#
#  This program is free software; you can redistribute it and/or
#  modify it under the same terms as Perl itself.
#
################################################################################

require 5.006001;

use strict;
use warnings;
use ExtUtils::MakeMaker;
use Getopt::Long;

my $VERSION = "1.000";

$| = 1 ;
my $verbose = 0 ;

# TODO -- determine what "make" program to run.
my $MAKE = 'make';

my $result = GetOptions(
	"verbose"	=> \$verbose,
	"make=s"	=> \$MAKE,
	) or Usage();

my @GoodPerls = ();

if (@ARGV)
  { @GoodPerls = @ARGV }
else 
  { @GoodPerls = FindPerls() }

my $maxlen = 0;
foreach (@GoodPerls) {
    $maxlen = length $_
        if length $_ > $maxlen ;
}
$maxlen += 3 ;

# run each through the test harness

my $bad = 0 ;
my $good = 0 ;
my $total = 0 ;

# prime the pump, so the first "make realclean" will work.
runit("perl Makefile.PL") || die "Cannot run perl Makefile.PL\n" ;

foreach my $perl (@GoodPerls)
{
   my $prefix = $verbose  ? "$perl -- " : '';
   print "Testing $perl " . ('.' x ($maxlen - length $perl)) ;

   my $ok = runit("$MAKE realclean") &&
            runit("$perl Makefile.PL") &&
            # runit("$perl Makefile.PL --with-apicheck") &&
            runit("$MAKE test");

    ++ $total;
    if ($ok) {
        ++ $good ;
        print "${prefix}ok\n";
    }
    else {
        ++ $bad ;
        print "${prefix}not ok\n" ;
    }

}

print "\n\nPassed with $good of $total versions of Perl.\n\n";
exit $bad ;


sub runit
{
    # TODO -- portability alert!!

    my $cmd = shift ;
    print "\n    Running [$cmd]\n" if $verbose ;
    my $output = `$cmd 2>&1` ;
    $output = "\n" unless defined $output;
    $output =~ s/^/      /gm;
    print "\n    Output\n$output\n" if $verbose || $? ;
    if ($?)
    {
        warn "    Running '$cmd' failed: $?\n" ;
        return 0 ;
    }
    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;
}