ext/Devel/PPPort/soak

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