ext/Devel/PPPort/soak

   1 #!/usr/bin/perl -w
   2 ################################################################################
   3 #
   4 #  soak -- Test Perl modules with multiple Perl releases.
   5 #
   6 #  Original Author: Paul Marquess
   7 #
   8 ################################################################################
   9 #
  10 #  $Revision: 9 $
  11 #  $Author: mhx $
  12 #  $Date: 2006/01/14 18:07:57 +0100 $
  13 #
  14 ################################################################################
  15 #
  16 #  Version 3.x, Copyright (C) 2004-2006, Marcus Holland-Moritz.
  17 #  Version 2.x, Copyright (C) 2001, Paul Marquess.
  18 #  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
  19 #
  20 #  This program is free software; you can redistribute it and/or
  21 #  modify it under the same terms as Perl itself.
  22 #
  23 ################################################################################
  24
  25 require 5.006001;
  26
  27 use strict;
  28 use warnings;
  29 use ExtUtils::MakeMaker;
  30 use Getopt::Long;
  31 use Pod::Usage;
  32 use List::Util qw(max);
  33 use Config;
  34
  35 my $VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.08_01 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
  36
  37 $| = 1;
  38 my $verbose = 0;
  39 my $MAKE = $Config{make} || 'make';
  40 my %OPT = (
  41   verbose => 0,
  42   make    => $Config{make} || 'make',
  43 );
  44
  45 GetOptions(\%OPT, qw(verbose make=s mmargs=s@)) or pod2usage(2);
  46
  47 $OPT{mmargs} = [''] unless exists $OPT{mmargs};
  48
  49 my @GoodPerls = @ARGV ? @ARGV : FindPerls();
  50 my $maxlen = max(map length, @GoodPerls) + 3;
  51 my $mmalen = max(map length, @{$OPT{mmargs}});
  52 $maxlen += $mmalen+3 if $mmalen > 0;
  53
  54 # run each through the test harness
  55 my(@good, @bad, $total);
  56
  57 # prime the pump, so the first "make realclean" will work.
  58 runit("$^X Makefile.PL") && runit("$MAKE realclean")
  59     or die "Cannot run $^X Makefile.PL && $MAKE realclean\n";
  60
  61 for my $perl (@GoodPerls) {
  62   for my $mm (@{$OPT{mmargs}}) {
  63     my $config = $mm =~ /\S+/ ? " ($mm)" : '';
  64     my $prefix = $verbose ? "$perl$config -- " : '';
  65     print "Testing $perl$config " . ('.' x ($maxlen - length($perl.$config)));
  66
  67     my $ok = runit("$perl Makefile.PL $mm") &&
  68              # runit("$perl Makefile.PL --with-apicheck") &&
  69              runit("$MAKE test");
  70
  71     $total++;
  72     if ($ok) {
  73       push @good, [$perl, $mm];
  74       print "${prefix}ok\n";
  75     }
  76     else {
  77       push @bad, [$perl, $mm];
  78       print "${prefix}not ok\n";
  79     }
  80
  81     runit("$MAKE realclean");
  82   }
  83 }
  84
  85 if ($verbose && @bad) {
  86   print "\nFailed with:\n", map "    $_\n", @bad;
  87 }
  88 print "\nPassed with ", scalar @good, " of $total versions/configurations.\n\n";
  89 exit scalar @bad;
  90
  91 sub runit
  92 {
  93   # TODO -- portability alert!!
  94
  95   my $cmd = shift;
  96   print "\n    Running [$cmd]\n" if $verbose;
  97   my $output = `$cmd 2>&1`;
  98   $output = "\n" unless defined $output;
  99   $output =~ s/^/      /gm;
 100   print "\n    Output\n$output\n" if $verbose || $?;
 101   if ($?) {
 102     warn "    Running '$cmd' failed: $?\n";
 103     return 0;
 104   }
 105   return 1;
 106 }
 107
 108 sub FindPerls
 109 {
 110   # TODO -- need to decide how far back we go.
 111   # TODO -- get list of user releases prior to 5.004
 112   # TODO -- does not work on Windows (at least)
 113
 114   # find versions of Perl that are available
 115   my @PerlBinaries = qw(
 116     5.000
 117     5.001
 118     5.002
 119     5.003
 120     5.004 5.00401 5.00402 5.00403 5.00404 5.00405
 121     5.005 5.00501 5.00502 5.00503 5.00504
 122     5.6.0 5.6.1 5.6.2
 123     5.7.0 5.7.1 5.7.2 5.7.3
 124     5.8.0 5.8.1 5.8.2 5.8.3 5.8.4 5.8.5 5.8.6
 125     5.9.0 5.9.1
 126   );
 127
 128   print "Searching for Perl binaries...\n";
 129   my $mm = MM->new( { NAME => 'dummy' });
 130   my @path = $mm->path;
 131   my @GoodPerls;
 132
 133   # find_perl will send a warning to STDOUT if it can't find
 134   # the requested perl, so need to temporarily silence STDOUT.
 135   tie *STDOUT, 'NoSTDOUT';
 136
 137   for my $perl (@PerlBinaries) {
 138     if (my $abs = $mm->find_perl($perl, ["perl$perl"], \@path, 0)) {
 139       push @GoodPerls, $abs;
 140     }
 141   }
 142
 143   untie *STDOUT;
 144
 145   print "\nFound:\n", (map "    $_\n", @GoodPerls), "\n";
 146
 147   return @GoodPerls;
 148 }
 149
 150 package NoSTDOUT;
 151
 152 use Tie::Handle;
 153 our @ISA = qw(Tie::Handle);
 154
 155 sub TIEHANDLE { bless \(my $s = ''), shift }
 156 sub PRINT {}
 157 sub WRITE {}
 158
 159 __END__
 160
 161 =head1 NAME
 162
 163 soak - Test Perl modules with multiple Perl releases
 164
 165 =head1 SYNOPSIS
 166
 167   soak [options] [perl ...]
 168
 169   --make=program     override name of make program ($Config{make})
 170   --mmargs=options   pass options to Makefile.PL (multiple --mmargs possible)
 171   --verbose          be verbose
 172
 173 =head1 COPYRIGHT
 174
 175 Version 3.x, Copyright (c) 2004-2006, Marcus Holland-Moritz.
 176
 177 Version 2.x, Copyright (C) 2001, Paul Marquess.
 178
 179 Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
 180
 181 This program is free software; you can redistribute it and/or
 182 modify it under the same terms as Perl itself.
 183
 184 =head1 SEE ALSO
 185
 186 See L<Devel::PPPort>.
 187
 188 =cut
 189