22

✏️ Editing: soak

#!/usr/bin/perl -w
################################################################################
#
#  soak -- Test Perl modules with multiple Perl releases.
#
#  Original Author: Paul Marquess
#
################################################################################
#
#  Version 3.x, Copyright (C) 2004-2013, 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 = '3.36';

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

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

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

sub cs($;$$) { my $x = shift; my($s, $p) = @_ ? @_ : ('', 's'); ($x, $x == 1 ? $s : $p) }

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;

my $rep = Soak::Reporter->new( verbose => $OPT{verbose}
                             , color   => $OPT{color}
                             , width   => $maxlen
                             );

$SIG{__WARN__} = sub { $rep->warn(@_) };
$SIG{__DIE__}  = sub { $rep->die(@_)  };

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

my $tot = @GoodPerls*@{$OPT{mmargs}};

$rep->set(tests => $tot);

$rep->status(sprintf("Testing %d version%s / %d configuration%s (%d combination%s)...\n",
                     cs(@GoodPerls), cs(@{$OPT{mmargs}}), cs($tot)));

for my $perl (@GoodPerls) {
  for my $mm (@{$OPT{mmargs}}) {
    $rep->set(perl => $perl, config => $mm);

$rep->test;

my @warn_mfpl;
    my @warn_make;
    my @warn_test;

my $ok = runit("$perl Makefile.PL $mm", \@warn_mfpl) &&
             runit("$OPT{make}", \@warn_make) &&
             runit("$OPT{make} test", \@warn_test);

$rep->warnings(['Makefile.PL' => \@warn_mfpl],
                   ['make'        => \@warn_make],
                   ['make test'   => \@warn_test]);

if ($ok) {
      $rep->passed;
    }
    else {
      $rep->failed;
    }

runit("$OPT{make} realclean");
  }
}

exit $rep->finish;

sub runit
{
  # TODO -- portability alert!!

my($cmd, $warn) = @_;
  $rep->vsay("\n    Running [$cmd]");
  my $output = `$cmd 2>&1`;
  $output = "\n" unless defined $output;
  $output =~ s/^/    > /gm;
  $rep->say("\n    Output:\n$output") if $OPT{verbose} || $?;
  if ($?) {
    $rep->warn("    Running '$cmd' failed: $?\n");
    return 0;
  }
  push @$warn, $output =~ /(warning: .*)/ig;
  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.8.7 5.8.8
    5.9.0 5.9.1 5.9.2 5.9.3
  );

print "Searching for Perl binaries...\n";

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

my $mm = MM->new( { NAME => 'dummy' });
  my @path = $mm->path;
  my @GoodPerls;

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({ wanted => 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;
           }, follow => 1 }, $arg);
      printf "Found %d Perl binar%s in '%s'.\n\n", cs(@found, '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 =~ /^\d+\.\d+/ && $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 {}

package Soak::Reporter;

use strict;

sub cs($;$$) { my $x = shift; my($s, $p) = @_ ? @_ : ('', 's'); ($x, $x == 1 ? $s : $p) }

sub new
{
  my $class = shift;
  bless {
    tests   => undef,
    color   => 1,
    verbose => 0,
    @_,
    _cur    => 0,
    _atbol  => 1,
    _total  => 0,
    _good   => [],
    _bad    => [],
  }, $class;
}

sub colored
{
  my $self = shift;

if ($self->{color}) {
    my $c = eval {
      require Term::ANSIColor;
      Term::ANSIColor::colored(@_);
    };

if ($@) {
      $self->{color} = 0;
    }
    else {
      return $c;
    }
  }

return $_[0];
}

sub _config
{
  my $self = shift;
  return $self->{config} =~ /\S+/ ? " ($self->{config})" : '';
}

sub _progress
{
  my $self = shift;
  return '' unless defined $self->{tests};
  my $tlen = length $self->{tests};
  my $text = sprintf "[%${tlen}d/%${tlen}d] ", $self->{_cur}, $self->{tests};
  return $self->colored($text, 'bold');
}

sub _test
{
  my $self = shift;
  return $self->_progress . "Testing "
         . $self->colored($self->{perl}, 'blue')
         . $self->colored($self->_config, 'green');
}

sub _testlen
{
  my $self = shift;
  return length("Testing " . $self->{perl} . $self->_config);
}

sub _dots
{
  my $self = shift;
  return '.' x $self->_dotslen;
}

sub _dotslen
{
  my $self = shift;
  return $self->{width} - length($self->{perl} . $self->_config);
}

sub _sep
{
  my $self = shift;
  my $width = shift;
  $self->print($self->colored('-'x$width, 'bold'), "\n");
}

sub _vsep
{
  goto &_sep if $_[0]->{verbose};
}

sub set
{
  my $self = shift;
  while (@_) {
    my($k, $v) = splice @_, 0, 2;
    $self->{$k} = $v;
  }
}

sub test
{
  my $self = shift;
  $self->{_cur}++;
  $self->_vsep($self->_testlen);
  $self->print($self->_test, $self->{verbose} ? "\n" : ' ' . $self->_dots . ' ');
  $self->_vsep($self->_testlen);
}

sub _warnings
{
  my($self, $mode) = @_;

my $warnings = 0;
  my $differ   = 0;

for my $w (@{$self->{_warnings}}) {
    if (@{$w->[1]}) {
      $warnings += @{$w->[1]};
      $differ++;
    }
  }

my $rv = '';

if ($warnings) {
    if ($mode eq 'summary') {
      $rv .= sprintf " (%d warning%s", cs($warnings);
    }
    else {
      $rv .= "\n";
    }

for my $w (@{$self->{_warnings}}) {
      if (@{$w->[1]}) {
        if ($mode eq 'detail') {
          $rv .= "  Warnings during '$w->[0]':\n";
          my $cnt = 1;
          for my $msg (@{$w->[1]}) {
            $rv .= sprintf "    [%d] %s", $cnt++, $msg;
          }
          $rv .= "\n";
        }
        else {
          unless ($self->{verbose}) {
            $rv .= $differ == 1 ? " during " . $w->[0]
                                : sprintf(", %d during %s", scalar @{$w->[1]}, $w->[0]);
          }
        }
      }
    }

if ($mode eq 'summary') {
      $rv .= ')';
    }
  }

return $rv;
}

sub _result
{
  my($self, $text, $color) = @_;
  my $sum = $self->_warnings('summary');
  my $len = $self->_testlen + $self->_dotslen + length($text) + length($sum) + 2;

$self->_vsep($len);
  $self->print($self->_test, ' ', $self->_dots, ' ') if $self->{verbose} || $self->{_atbol};
  $self->print($self->colored($text, $color));
  $self->print($self->colored($sum, 'red'));
  $self->print("\n");
  $self->_vsep($len);
  $self->print($self->_warnings('detail')) if $self->{verbose};
  $self->{_total}++;
}

sub passed
{
  my $self = shift;
  $self->_result(@_, 'ok', 'bold green');
  push @{$self->{_good}}, [$self->{perl}, $self->{config}];
}

sub failed
{
  my $self = shift;
  $self->_result(@_, 'not ok', 'bold red');
  push @{$self->{_bad}}, [$self->{perl}, $self->{config}];
}

sub warnings
{
  my $self = shift;
  $self->{_warnings} = \@_;
}

sub _tobol
{
  my $self = shift;
  print "\n" unless $self->{_atbol};
  $self->{_atbol} = 1;
}

sub print
{
  my $self = shift;
  my $text = join '', @_;
  print $text;
  $self->{_atbol} = $text =~ /[\r\n]$/;
}

sub say
{
  my $self = shift;
  $self->_tobol;
  $self->print(@_, "\n");
}

sub vsay
{
  goto &say if $_[0]->{verbose};
}

sub warn
{
  my $self = shift;
  $self->say($self->colored(join('', @_), 'red'));
}

sub die
{
  my $self = shift;
  $self->say($self->colored(join('', 'FATAL: ', @_), 'bold red'));
  exit -1;
}

sub status
{
  my($self, $text) = @_;
  $self->_tobol;
  $self->print($self->colored($text, 'bold'), "\n");
}

sub finish
{
  my $self = shift;

if (@{$self->{_bad}}) {
    $self->status("\nFailed with:");
    for my $fail (@{$self->{_bad}}) {
      my($perl, $cfg) = @$fail;
      $self->set(config => $cfg);
      $self->say("    ", $self->colored($perl, 'blue'), $self->colored($self->_config, 'green'));
    }
  }

$self->status(sprintf("\nPassed with %d of %d combination%s.\n",
                        scalar @{$self->{_good}}, cs($self->{_total})));

return scalar @{$self->{_bad}};
}

__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
  --nocolor          don't use colored output

=head1 DESCRIPTION

The F<soak> utility can be used to test Perl modules with
multiple Perl releases or build options. It automates the
task of running F<Makefile.PL> and the modules test suite.

It is not primarily intended for cross-platform checking,
so don't expect it to work on all platforms.

=head1 EXAMPLES

To test your favourite module, just change to its root
directory (where the F<Makefile.PL> is located) and run:

soak

This will automatically look for Perl binaries installed
on your system.

Alternatively, you can explicitly pass F<soak> a list of
Perl binaries:

soak perl5.8.6 perl5.9.2

Last but not least, you can pass it a list of directories
to recursively search for Perl binaries, for example:

soak /tmp/perl/install /usr/bin

All of the above examples will run

perl Makefile.PL
  make
  make test

for your module and report success or failure.

If your F<Makefile.PL> can take arguments, you may also
want to test different configurations for your module.
You can do so with the I<--mmargs> option:

soak --mmargs=' ' --mmargs='CCFLAGS=-Wextra' --mmargs='enable-debug'

This will run

perl Makefile.PL
  make
  make test
  perl Makefile.PL CCFLAGS=-Wextra
  make
  make test
  perl Makefile.PL enable-debug
  make
  make test

for each Perl binary.

If you have a directory full of different Perl binaries,
but your module isn't expected to work with ancient perls,
you can use the I<--min> option to specify the minimum
version a Perl binary must have to be chosen for testing:

soak --min=5.8.1

Usually, the output of F<soak> is rather terse, to give
you a good overview. If you'd like to see more of what's
going on, use the I<--verbose> option:

soak --verbose

=head1 COPYRIGHT

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

MR SKB