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: 12 $
  11 #  $Author: mhx $
  12 #  $Date: 2006/05/22 20:26:02 +0200 $
  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 File::Find;
  33 use List::Util qw(max);
  34 use Config;
  35
  36 my $VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.08_05 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
  37
  38 $| = 1;
  39 my $verbose = 0;
  40 my $MAKE = $Config{make} || 'make';
  41 my %OPT = (
  42   verbose => 0,
  43   make    => $Config{make} || 'make',
  44   min     => '5.000',
  45 );
  46
  47 GetOptions(\%OPT, qw(verbose make=s min=s mmargs=s@)) or pod2usage(2);
  48
  49 $OPT{mmargs} = [''] unless exists $OPT{mmargs};
  50 $OPT{min}    = parse_version($OPT{min}) - 1e-10;
  51
  52 my @GoodPerls = map  { $_->[0] }
  53                 sort { $a->[1] <=> $b->[1] or $a->[0] cmp $b->[0] }
  54                 grep { $_->[1] >= $OPT{min} }
  55                 map  { [$_ => perl_version($_)] }
  56                 @ARGV ? SearchPerls(@ARGV) : FindPerls();
  57
  58 unless (@GoodPerls) {
  59   print "Sorry, got no Perl binaries for testing.\n\n";
  60   exit 0;
  61 }
  62
  63 my $maxlen = max(map length, @GoodPerls) + 3;
  64 my $mmalen = max(map length, @{$OPT{mmargs}});
  65 $maxlen += $mmalen+3 if $mmalen > 0;
  66
  67 # run each through the test harness
  68 my(@good, @bad, $total);
  69
  70 # prime the pump, so the first "make realclean" will work.
  71 runit("$^X Makefile.PL") && runit("$MAKE realclean")
  72     or die "Cannot run $^X Makefile.PL && $MAKE realclean\n";
  73
  74 print "Testing ", scalar @GoodPerls, " versions/configurations...\n\n";
  75
  76 for my $perl (@GoodPerls) {
  77   for my $mm (@{$OPT{mmargs}}) {
  78     my $config = $mm =~ /\S+/ ? " ($mm)" : '';
  79     my $prefix = $verbose ? "$perl$config -- " : '';
  80     print "Testing $perl$config " . ('.' x ($maxlen - length($perl.$config)));
  81
  82     my $ok = runit("$perl Makefile.PL $mm") &&
  83              # runit("$perl Makefile.PL --with-apicheck") &&
  84              runit("$MAKE test");
  85
  86     $total++;
  87     if ($ok) {
  88       push @good, [$perl, $mm];
  89       print "${prefix}ok\n";
  90     }
  91     else {
  92       push @bad, [$perl, $mm];
  93       print "${prefix}not ok\n";
  94     }
  95
  96     runit("$MAKE realclean");
  97   }
  98 }
  99
 100 if (@bad) {
 101   print "\nFailed with:\n";
 102   for my $fail (@bad) {
 103     my($perl, $mm) = @$fail;
 104     my $config = $mm =~ /\S+/ ? " ($mm)" : '';
 105     print "    $perl$config\n";
 106   }
 107 }
 108
 109 print "\nPassed with ", scalar @good, " of $total versions/configurations.\n\n";
 110 exit scalar @bad;
 111
 112 sub runit
 113 {
 114   # TODO -- portability alert!!
 115
 116   my $cmd = shift;
 117   print "\n    Running [$cmd]\n" if $verbose;
 118   my $output = `$cmd 2>&1`;
 119   $output = "\n" unless defined $output;
 120   $output =~ s/^/      /gm;
 121   print "\n    Output\n$output\n" if $verbose || $?;
 122   if ($?) {
 123     warn "    Running '$cmd' failed: $?\n";
 124     return 0;
 125   }
 126   return 1;
 127 }
 128
 129 sub FindPerls
 130 {
 131   # TODO -- need to decide how far back we go.
 132   # TODO -- get list of user releases prior to 5.004
 133   # TODO -- does not work on Windows (at least)
 134
 135   # find versions of Perl that are available
 136   my @PerlBinaries = qw(
 137     5.000
 138     5.001
 139     5.002
 140     5.003
 141     5.004 5.00401 5.00402 5.00403 5.00404 5.00405
 142     5.005 5.00501 5.00502 5.00503 5.00504
 143     5.6.0 5.6.1 5.6.2
 144     5.7.0 5.7.1 5.7.2 5.7.3
 145     5.8.0 5.8.1 5.8.2 5.8.3 5.8.4 5.8.5 5.8.6
 146     5.9.0 5.9.1
 147   );
 148
 149   print "Searching for Perl binaries...\n";
 150   my $mm = MM->new( { NAME => 'dummy' });
 151   my @path = $mm->path;
 152   my @GoodPerls;
 153
 154   # find_perl will send a warning to STDOUT if it can't find
 155   # the requested perl, so need to temporarily silence STDOUT.
 156   tie *STDOUT, 'NoSTDOUT';
 157
 158   for my $perl (@PerlBinaries) {
 159     if (my $abs = $mm->find_perl($perl, ["perl$perl"], \@path, 0)) {
 160       push @GoodPerls, $abs;
 161     }
 162   }
 163
 164   untie *STDOUT;
 165
 166   print "\nFound:\n", (map "    $_\n", @GoodPerls), "\n";
 167
 168   return @GoodPerls;
 169 }
 170
 171 sub SearchPerls
 172 {
 173   my @args = @_;
 174   my @perls;
 175
 176   for my $arg (@args) {
 177     if (-d $arg) {
 178       my @found;
 179       print "Searching for Perl binaries in '$arg'...\n";
 180       find(sub {
 181              $File::Find::name =~ m!perl5[\w._]+$!
 182                  and -f $File::Find::name
 183                  and -x $File::Find::name
 184                  and perl_version($File::Find::name)
 185                  and push @found, $File::Find::name;
 186            }, $arg);
 187       printf "Found %d Perl binar%s in '%s'.\n\n", scalar @found, @found == 1 ? 'y' : 'ies', $arg;
 188       push @perls, @found;
 189     }
 190     else {
 191       push @perls, $arg;
 192     }
 193   }
 194
 195   return @perls;
 196 }
 197
 198 sub perl_version
 199 {
 200   my $perl = shift;
 201   my $ver = `$perl -e 'print \$]' 2>&1`;
 202   return $? == 0 && $ver >= 5 ? $ver : 0;
 203 }
 204
 205 sub parse_version
 206 {
 207   my $ver = shift;
 208
 209   if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
 210     return $1 + 1e-3*$2 + 1e-6*$3;
 211   }
 212   elsif ($ver =~ /^\d+\.[\d_]+$/) {
 213     $ver =~ s/_//g;
 214     return $ver;
 215   }
 216
 217   die "cannot parse version '$ver'\n";
 218 }
 219
 220 package NoSTDOUT;
 221
 222 use Tie::Handle;
 223 our @ISA = qw(Tie::Handle);
 224
 225 sub TIEHANDLE { bless \(my $s = ''), shift }
 226 sub PRINT {}
 227 sub WRITE {}
 228
 229 __END__
 230
 231 =head1 NAME
 232
 233 soak - Test Perl modules with multiple Perl releases
 234
 235 =head1 SYNOPSIS
 236
 237   soak [options] [perl ...]
 238
 239   --make=program     override name of make program ($Config{make})
 240   --min=version      use at least this version of perl
 241   --mmargs=options   pass options to Makefile.PL (multiple --mmargs possible)
 242   --verbose          be verbose
 243
 244 =head1 COPYRIGHT
 245
 246 Version 3.x, Copyright (c) 2004-2006, Marcus Holland-Moritz.
 247
 248 Version 2.x, Copyright (C) 2001, Paul Marquess.
 249
 250 Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
 251
 252 This program is free software; you can redistribute it and/or
 253 modify it under the same terms as Perl itself.
 254
 255 =head1 SEE ALSO
 256
 257 See L<Devel::PPPort>.
 258
 259 =cut
 260