ext/Devel/PPPort/soak

   1
   2 # soak: Test Devel::PPPort with multiple versions of Perl.
   3 #
   4 # Author:       Paul Marquess
   5 #
   6
   7 require 5.006001;
   8
   9 use strict ;
  10 use warnings ;
  11 use ExtUtils::MakeMaker;
  12 use Getopt::Long;
  13
  14 my $VERSION = "1.000";
  15
  16 $| = 1 ;
  17 my $verbose = 0 ;
  18
  19 # TODO -- determine what "make" program to run.
  20 my $MAKE = 'make';
  21
  22 my $result = GetOptions(
  23         "verbose"       => \$verbose,
  24         "make=s"        => \$MAKE,
  25         ) or Usage();
  26
  27 my @GoodPerls = ();
  28
  29 if (@ARGV)
  30   { @GoodPerls = @ARGV }
  31 else
  32   { @GoodPerls = FindPerls() }
  33
  34 my $maxlen = 0;
  35 foreach (@GoodPerls) {
  36     $maxlen = length $_
  37         if length $_ > $maxlen ;
  38 }
  39 $maxlen += 3 ;
  40
  41 # run each through the test harness
  42
  43 my $bad = 0 ;
  44 my $good = 0 ;
  45 my $total = 0 ;
  46
  47 # prime the pump, so the first "make clean" will work.
  48 runit("perl Makefile.PL") || die "Cannot run perl Makefile.PL\n" ;
  49
  50 foreach my $perl (@GoodPerls)
  51 {
  52    my $prefix = "$perl -- " if $verbose ;
  53    print "Testing $perl " . ('.' x ($maxlen - length $perl)) ;
  54
  55    my $ok = runit("$MAKE clean") &&
  56             runit("$perl Makefile.PL") &&
  57             runit("$MAKE test") ;
  58
  59     ++ $total;
  60     if ($ok) {
  61         ++ $good ;
  62         print "${prefix}ok\n";
  63     }
  64     else {
  65         ++ $bad ;
  66         print "${prefix}not ok\n" ;
  67     }
  68
  69 }
  70
  71 print "\n\nPassed with $good of $total versions of Perl.\n\n";
  72 exit $bad ;
  73
  74
  75 sub runit
  76 {
  77     # TODO -- portability alert!!
  78
  79     my $cmd = shift ;
  80     print "\n    Running [$cmd]\n" if $verbose ;
  81     my $output = `$cmd 2>&1` ;
  82     $output = "\n" unless defined $output;
  83     $output =~ s/^/      /gm;
  84     print "\n    Output\n$output\n" if $verbose || $? ;
  85     if ($?)
  86     {
  87         warn "    Running '$cmd' failed: $?\n" ;
  88         return 0 ;
  89     }
  90     return 1 ;
  91 }
  92
  93 sub Usage
  94 {
  95     die <<EOM;
  96
  97 usage: soak [OPT] [perl...]
  98
  99   OPT
 100     -m make     - the name of the make program. Default "make"
 101     -v          - verbose
 102
 103 EOM
 104
 105 }
 106
 107 sub FindPerls
 108 {
 109     # TODO -- need to decide how far back we go.
 110     # TODO -- get list of user releases prior to 5.004
 111
 112     # find all version of Perl that are available
 113     my @PerlBinaries = qw(
 114         5.000
 115         5.001
 116         5.002
 117         5.003
 118         5.004
 119         5.00401
 120         5.00402
 121         5.00403
 122         5.00404
 123         5.00405
 124         5.005
 125         5.00501
 126         5.00502
 127         5.00503
 128         5.6.0
 129         5.6.1
 130         5.7.0
 131         5.7.1
 132         5.7.2
 133         );
 134
 135     print "Searching for Perl binaries...\n" ;
 136     my @GoodPerls = ();
 137     my $maxlen = 0;
 138     my $mm = MM->new( { NAME => 'dummy' });
 139     my @path = $mm->path();
 140
 141     # find_perl will send a warning to STDOUT if it can't find
 142     # the requested perl, so need to temporarily silence STDOUT.
 143     tie(*STDOUT, 'NoSTDOUT');
 144
 145     foreach my $perl (@PerlBinaries) {
 146         if (my $abs = $mm->find_perl($perl, ["perl$perl"], [@path], 0)) {
 147             push @GoodPerls, $abs ;
 148         }
 149     }
 150     untie *STDOUT;
 151
 152     print "\n\nFound\n";
 153     foreach (@GoodPerls) { print "    $_\n" }
 154     print "\n\n";
 155
 156     return @GoodPerls;
 157 }
 158
 159 package NoSTDOUT;
 160
 161 use Tie::Handle;
 162 our @ISA = qw(Tie::Handle);
 163
 164 sub TIEHANDLE
 165 {
 166     my ($class) = @_;
 167     my $buf = "";
 168     bless \$buf, $class;
 169 }
 170
 171 sub PRINT
 172 {
 173     my $self = shift;
 174 }
 175
 176 sub WRITE
 177 {
 178     my $self = shift;
 179 }