path: root/ext/Devel/PPPort/soak

#!/usr/bin/perl -w
################################################################################
#
#  soak -- Test Perl modules with multiple Perl releases.
#
#  Original Author: Paul Marquess
#
################################################################################
#
#  $Revision: 12 $
#  $Author: mhx $
#  $Date: 2006/05/22 20:26:02 +0200 $
#
################################################################################
#
#  Version 3.x, Copyright (C) 2004-2006, 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;
use Pod::Usage;
use File::Find;
use List::Util qw(max);
use Config;

my $VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.08_07 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };

$| = 1;
my $verbose = 0;
my $MAKE = $Config{make} || 'make';
my %OPT = (
  verbose => 0,
  make    => $Config{make} || 'make',
  min     => '5.000',
);

GetOptions(\%OPT, qw(verbose make=s min=s mmargs=s@)) or pod2usage(2);

$OPT{mmargs} = [''] unless exists $OPT{mmargs};
$OPT{min}    = parse_version($OPT{min}) - 1e-10;

my @GoodPerls = map  { $_->[0] }
                sort { $a->[1] <=> $b->[1] or $a->[0] cmp $b->[0] }
                grep { $_->[1] >= $OPT{min} }
                map  { [$_ => perl_version($_)] }
                @ARGV ? SearchPerls(@ARGV) : FindPerls();

unless (@GoodPerls) {
  print "Sorry, got no Perl binaries for testing.\n\n";
  exit 0;
}

my $maxlen = max(map length, @GoodPerls) + 3;
my $mmalen = max(map length, @{$OPT{mmargs}});
$maxlen += $mmalen+3 if $mmalen > 0;

# run each through the test harness
my(@good, @bad, $total);

# prime the pump, so the first "make realclean" will work.
runit("$^X Makefile.PL") && runit("$MAKE realclean")
    or die "Cannot run $^X Makefile.PL && $MAKE realclean\n";

print "Testing ", scalar @GoodPerls, " versions/configurations...\n\n";

for my $perl (@GoodPerls) {
  for my $mm (@{$OPT{mmargs}}) {
    my $config = $mm =~ /\S+/ ? " ($mm)" : '';
    my $prefix = $verbose ? "$perl$config -- " : '';
    print "Testing $perl$config " . ('.' x ($maxlen - length($perl.$config)));

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

    $total++;
    if ($ok) {
      push @good, [$perl, $mm];
      print "${prefix}ok\n";
    }
    else {
      push @bad, [$perl, $mm];
      print "${prefix}not ok\n";
    }

    runit("$MAKE realclean");
  }
}

if (@bad) {
  print "\nFailed with:\n";
  for my $fail (@bad) {
    my($perl, $mm) = @$fail;
    my $config = $mm =~ /\S+/ ? " ($mm)" : '';
    print "    $perl$config\n";
  }
}

print "\nPassed with ", scalar @good, " of $total versions/configurations.\n\n";
exit scalar @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 FindPerls
{
  # TODO -- need to decide how far back we go.
  # TODO -- get list of user releases prior to 5.004
  # TODO -- does not work on Windows (at least)

  # find versions 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.00504
    5.6.0 5.6.1 5.6.2
    5.7.0 5.7.1 5.7.2 5.7.3
    5.8.0 5.8.1 5.8.2 5.8.3 5.8.4 5.8.5 5.8.6
    5.9.0 5.9.1
  );

  print "Searching for Perl binaries...\n";
  my $mm = MM->new( { NAME => 'dummy' });
  my @path = $mm->path;
  my @GoodPerls;

  # 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';

  for my $perl (@PerlBinaries) {
    if (my $abs = $mm->find_perl($perl, ["perl$perl"], \@path, 0)) {
      push @GoodPerls, $abs;
    }
  }

  untie *STDOUT;

  print "\nFound:\n", (map "    $_\n", @GoodPerls), "\n";

  return @GoodPerls;
}

sub SearchPerls
{
  my @args = @_;
  my @perls;

  for my $arg (@args) {
    if (-d $arg) {
      my @found;
      print "Searching for Perl binaries in '$arg'...\n";
      find(sub {
             $File::Find::name =~ m!perl5[\w._]+$!
                 and -f $File::Find::name
                 and -x $File::Find::name
                 and perl_version($File::Find::name)
                 and push @found, $File::Find::name;
           }, $arg);
      printf "Found %d Perl binar%s in '%s'.\n\n", scalar @found, @found == 1 ? 'y' : 'ies', $arg;
      push @perls, @found;
    }
    else {
      push @perls, $arg;
    }
  }

  return @perls;
}

sub perl_version
{
  my $perl = shift;
  my $ver = `$perl -e 'print \$]' 2>&1`;
  return $? == 0 && $ver >= 5 ? $ver : 0;
}

sub parse_version
{
  my $ver = shift;

  if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
    return $1 + 1e-3*$2 + 1e-6*$3;
  }
  elsif ($ver =~ /^\d+\.[\d_]+$/) {
    $ver =~ s/_//g;
    return $ver;
  }

  die "cannot parse version '$ver'\n";
}

package NoSTDOUT;

use Tie::Handle;
our @ISA = qw(Tie::Handle);

sub TIEHANDLE { bless \(my $s = ''), shift }
sub PRINT {}
sub WRITE {}

__END__

=head1 NAME

soak - Test Perl modules with multiple Perl releases

=head1 SYNOPSIS

  soak [options] [perl ...]

  --make=program     override name of make program ($Config{make})
  --min=version      use at least this version of perl
  --mmargs=options   pass options to Makefile.PL (multiple --mmargs possible)
  --verbose          be verbose

=head1 COPYRIGHT

Version 3.x, Copyright (c) 2004-2006, 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.

=head1 SEE ALSO

See L<Devel::PPPort>.

=cut