[p5sagit/p5-mst-13.2.git] / ext / Devel / PPPort / soak

#!/usr/bin/perl -w
################################################################################
#
#  soak -- Test Perl modules with multiple Perl releases.
#
#  Original Author: Paul Marquess
#
################################################################################
#
#  $Revision: 13 $
#  $Author: mhx $
#  $Date: 2006/07/08 16:58:56 +0200 $
#
################################################################################
#
#  Version 3.x, Copyright (C) 2004-2006, 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 = do { my @r = '$Snapshot: /Devel-PPPort/3.09_02 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };

$| = 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");

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

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(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;
           }, $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 >= 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 {
    color   => 1,
    verbose => 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 _test
{
  my $self = shift;
  return "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->_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

Version 3.x, Copyright (c) 2004-2006, 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.

=head1 SEE ALSO

See L<Devel::PPPort>.

=cut
Commit	Line	Data
adfe19db	1	#!/usr/bin/perl -w
	2	################################################################################
	3	#
4a582685	4	# soak -- Test Perl modules with multiple Perl releases.
adfe19db	5	#
	6	# Original Author: Paul Marquess
	7	#
	8	################################################################################
	9	#
56093a11	10	# $Revision: 13 $
adfe19db	11	# $Author: mhx $
56093a11	12	# $Date: 2006/07/08 16:58:56 +0200 $
44284200	13	#
adfe19db	14	################################################################################
44284200	15	#
0d0f8426	16	# Version 3.x, Copyright (C) 2004-2006, Marcus Holland-Moritz.
adfe19db	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	################################################################################
44284200	24
44284200	25	require 5.006001;
dbda3434	26
adfe19db	27	use strict;
adfe19db	28	use warnings;
dbda3434	29	use ExtUtils::MakeMaker;
44284200	30	use Getopt::Long;
4a582685	31	use Pod::Usage;
c07deaaf	32	use File::Find;
4a582685	33	use List::Util qw(max);
4a582685	34	use Config;
44284200	35
aef0a14c	36	my $VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.09_02 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
0a7c7f4f	37
4a582685	38	$\| = 1;
4a582685	39	my %OPT = (
	40	verbose => 0,
	41	make => $Config{make} \|\| 'make',
c07deaaf	42	min => '5.000',
56093a11	43	color => 1,
4a582685	44	);
0a7c7f4f	45
56093a11	46	GetOptions(\%OPT, qw(verbose make=s min=s mmargs=s@ color!)) or pod2usage(2);
dbda3434	47
4a582685	48	$OPT{mmargs} = [''] unless exists $OPT{mmargs};
c07deaaf	49	$OPT{min} = parse_version($OPT{min}) - 1e-10;
dbda3434	50
56093a11	51	sub cs($;$$) { my $x = shift; my($s, $p) = @_ ? @_ : ('', 's'); ($x, $x == 1 ? $s : $p) }
56093a11	52
0c96388f	53	my @GoodPerls = map { $_->[0] }
	54	sort { $a->[1] <=> $b->[1] or $a->[0] cmp $b->[0] }
	55	grep { $_->[1] >= $OPT{min} }
	56	map { [$_ => perl_version($_)] }
c07deaaf	57	@ARGV ? SearchPerls(@ARGV) : FindPerls();
0c96388f	58
	59	unless (@GoodPerls) {
	60	print "Sorry, got no Perl binaries for testing.\n\n";
	61	exit 0;
	62	}
	63
4a582685	64	my $maxlen = max(map length, @GoodPerls) + 3;
	65	my $mmalen = max(map length, @{$OPT{mmargs}});
	66	$maxlen += $mmalen+3 if $mmalen > 0;
0a7c7f4f	67
56093a11	68	my $rep = Soak::Reporter->new( verbose => $OPT{verbose}
	69	, color => $OPT{color}
	70	, width => $maxlen
	71	);
	72
	73	$SIG{__WARN__} = sub { $rep->warn(@_) };
	74	$SIG{__DIE__} = sub { $rep->die(@_) };
0a7c7f4f	75
adfe19db	76	# prime the pump, so the first "make realclean" will work.
56093a11	77	runit("$^X Makefile.PL") && runit("$OPT{make} realclean")
56093a11	78	or $rep->die("Cannot run $^X Makefile.PL && $OPT{make} realclean\n");
dbda3434	79
56093a11	80	$rep->status(sprintf("Testing %d version%s / %d configuration%s (%d combination%s)...\n",
56093a11	81	cs(@GoodPerls), cs(@{$OPT{mmargs}}), cs(@GoodPerls*@{$OPT{mmargs}})));
c07deaaf	82
4a582685	83	for my $perl (@GoodPerls) {
4a582685	84	for my $mm (@{$OPT{mmargs}}) {
56093a11	85	$rep->set(perl => $perl, config => $mm);
	86
	87	$rep->test;
	88
	89	my @warn_mfpl;
	90	my @warn_make;
	91	my @warn_test;
	92
	93	my $ok = runit("$perl Makefile.PL $mm", \@warn_mfpl) &&
	94	runit("$OPT{make}", \@warn_make) &&
	95	runit("$OPT{make} test", \@warn_test);
dbda3434	96
56093a11	97	$rep->warnings(['Makefile.PL' => \@warn_mfpl],
	98	['make' => \@warn_make],
	99	['make test' => \@warn_test]);
0a7c7f4f	100
0a7c7f4f	101	if ($ok) {
56093a11	102	$rep->passed;
0a7c7f4f	103	}
0a7c7f4f	104	else {
56093a11	105	$rep->failed;
0a7c7f4f	106	}
0a7c7f4f	107
56093a11	108	runit("$OPT{make} realclean");
4a582685	109	}
0a7c7f4f	110	}
0a7c7f4f	111
56093a11	112	exit $rep->finish;
0a7c7f4f	113
	114	sub runit
	115	{
4a582685	116	# TODO -- portability alert!!
4a582685	117
56093a11	118	my($cmd, $warn) = @_;
56093a11	119	$rep->vsay("\n Running [$cmd]");
4a582685	120	my $output = `$cmd 2>&1`;
4a582685	121	$output = "\n" unless defined $output;
56093a11	122	$output =~ s/^/ > /gm;
56093a11	123	$rep->say("\n Output:\n$output") if $OPT{verbose} \|\| $?;
4a582685	124	if ($?) {
56093a11	125	$rep->warn(" Running '$cmd' failed: $?\n");
4a582685	126	return 0;
4a582685	127	}
56093a11	128	push @$warn, $output =~ /(warning: .*)/ig;
4a582685	129	return 1;
44284200	130	}
	131
	132	sub FindPerls
	133	{
4a582685	134	# TODO -- need to decide how far back we go.
	135	# TODO -- get list of user releases prior to 5.004
	136	# TODO -- does not work on Windows (at least)
	137
	138	# find versions of Perl that are available
	139	my @PerlBinaries = qw(
	140	5.000
	141	5.001
	142	5.002
	143	5.003
	144	5.004 5.00401 5.00402 5.00403 5.00404 5.00405
	145	5.005 5.00501 5.00502 5.00503 5.00504
	146	5.6.0 5.6.1 5.6.2
	147	5.7.0 5.7.1 5.7.2 5.7.3
56093a11	148	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
56093a11	149	5.9.0 5.9.1 5.9.2 5.9.3
4a582685	150	);
	151
	152	print "Searching for Perl binaries...\n";
4a582685	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
56093a11	158	my $mm = MM->new( { NAME => 'dummy' });
	159	my @path = $mm->path;
	160	my @GoodPerls;
	161
4a582685	162	for my $perl (@PerlBinaries) {
	163	if (my $abs = $mm->find_perl($perl, ["perl$perl"], \@path, 0)) {
	164	push @GoodPerls, $abs;
44284200	165	}
4a582685	166	}
	167
	168	untie *STDOUT;
44284200	169
4a582685	170	print "\nFound:\n", (map " $_\n", @GoodPerls), "\n";
	171
	172	return @GoodPerls;
44284200	173	}
44284200	174
c07deaaf	175	sub SearchPerls
	176	{
	177	my @args = @_;
	178	my @perls;
	179
	180	for my $arg (@args) {
	181	if (-d $arg) {
	182	my @found;
	183	print "Searching for Perl binaries in '$arg'...\n";
	184	find(sub {
0c96388f	185	$File::Find::name =~ m!perl5[\w._]+$!
	186	and -f $File::Find::name
	187	and -x $File::Find::name
	188	and perl_version($File::Find::name)
	189	and push @found, $File::Find::name;
c07deaaf	190	}, $arg);
56093a11	191	printf "Found %d Perl binar%s in '%s'.\n\n", cs(@found, 'y', 'ies'), $arg;
c07deaaf	192	push @perls, @found;
	193	}
	194	else {
	195	push @perls, $arg;
	196	}
	197	}
	198
	199	return @perls;
	200	}
	201
0c96388f	202	sub perl_version
	203	{
	204	my $perl = shift;
	205	my $ver = `$perl -e 'print \$]' 2>&1`;
	206	return $? == 0 && $ver >= 5 ? $ver : 0;
	207	}
	208
c07deaaf	209	sub parse_version
	210	{
	211	my $ver = shift;
	212
c07deaaf	213	if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
	214	return $1 + 1e-3$2 + 1e-6$3;
	215	}
	216	elsif ($ver =~ /^\d+\.[\d_]+$/) {
	217	$ver =~ s/_//g;
	218	return $ver;
	219	}
	220
	221	die "cannot parse version '$ver'\n";
	222	}
	223
44284200	224	package NoSTDOUT;
	225
	226	use Tie::Handle;
	227	our @ISA = qw(Tie::Handle);
	228
4a582685	229	sub TIEHANDLE { bless \(my $s = ''), shift }
	230	sub PRINT {}
	231	sub WRITE {}
	232
56093a11	233	package Soak::Reporter;
	234
	235	use strict;
	236
	237	sub cs($;$$) { my $x = shift; my($s, $p) = @_ ? @_ : ('', 's'); ($x, $x == 1 ? $s : $p) }
	238
	239	sub new
	240	{
	241	my $class = shift;
	242	bless {
	243	color => 1,
	244	verbose => 0,
	245	@_,
	246	_atbol => 1,
	247	_total => 0,
	248	_good => [],
	249	_bad => [],
	250	}, $class;
	251	}
	252
	253	sub colored
	254	{
	255	my $self = shift;
	256
	257	if ($self->{color}) {
	258	my $c = eval {
	259	require Term::ANSIColor;
	260	Term::ANSIColor::colored(@_);
	261	};
	262
	263	if ($@) {
	264	$self->{color} = 0;
	265	}
	266	else {
	267	return $c;
	268	}
	269	}
	270
	271	return $_[0];
	272	}
	273
	274	sub _config
	275	{
	276	my $self = shift;
	277	return $self->{config} =~ /\S+/ ? " ($self->{config})" : '';
	278	}
	279
	280	sub _test
	281	{
	282	my $self = shift;
	283	return "Testing "
	284	. $self->colored($self->{perl}, 'blue')
	285	. $self->colored($self->_config, 'green');
	286	}
	287
	288	sub _testlen
	289	{
	290	my $self = shift;
	291	return length("Testing " . $self->{perl} . $self->_config);
	292	}
	293
	294	sub _dots
	295	{
	296	my $self = shift;
297	return '.' x $self->_dotslen;
298	}
299
300	sub _dotslen
301	{
302	my $self = shift;
303	return $self->{width} - length($self->{perl} . $self->_config);
304	}
305
306	sub _sep
307	{
308	my $self = shift;
309	my $width = shift;
310	$self->print($self->colored('-'x$width, 'bold'), "\n");
311	}
312
313	sub _vsep
314	{
315	goto &_sep if $_[0]->{verbose};
316	}
317
318	sub set
319	{
320	my $self = shift;
321	while (@_) {
322	my($k, $v) = splice @_, 0, 2;
323	$self->{$k} = $v;
324	}
325	}
326
327	sub test
328	{
329	my $self = shift;
330	$self->_vsep($self->_testlen);
331	$self->print($self->_test, $self->{verbose} ? "\n" : ' ' . $self->_dots . ' ');
332	$self->_vsep($self->_testlen);
333	}
334
335	sub _warnings
336	{
337	my($self, $mode) = @_;
338
339	my $warnings = 0;
340	my $differ = 0;
341
342	for my $w (@{$self->{_warnings}}) {
343	if (@{$w->[1]}) {
344	$warnings += @{$w->[1]};
345	$differ++;
346	}
347	}
348
349	my $rv = '';
350
351	if ($warnings) {
352	if ($mode eq 'summary') {
353	$rv .= sprintf " (%d warning%s", cs($warnings);
354	}
355	else {
356	$rv .= "\n";
357	}
358
359	for my $w (@{$self->{_warnings}}) {
360	if (@{$w->[1]}) {
361	if ($mode eq 'detail') {
362	$rv .= " Warnings during '$w->[0]':\n";
363	my $cnt = 1;
364	for my $msg (@{$w->[1]}) {
365	$rv .= sprintf " [%d] %s", $cnt++, $msg;
366	}
367	$rv .= "\n";
368	}
369	else {
370	unless ($self->{verbose}) {
371	$rv .= $differ == 1 ? " during " . $w->[0]
372	: sprintf(", %d during %s", scalar @{$w->[1]}, $w->[0]);
373	}
374	}
375	}
376	}
377
378	if ($mode eq 'summary') {
379	$rv .= ')';
380	}
381	}
382
383	return $rv;
384	}
385
386	sub _result
387	{
388	my($self, $text, $color) = @_;
389	my $sum = $self->_warnings('summary');
390	my $len = $self->_testlen + $self->_dotslen + length($text) + length($sum) + 2;
391
392	$self->_vsep($len);
393	$self->print($self->_test, ' ', $self->_dots, ' ') if $self->{verbose} \|\| $self->{_atbol};
394	$self->print($self->colored($text, $color));
395	$self->print($self->colored($sum, 'red'));
396	$self->print("\n");
397	$self->_vsep($len);
398	$self->print($self->_warnings('detail')) if $self->{verbose};
399	$self->{_total}++;
400	}
401
402	sub passed
403	{
404	my $self = shift;
405	$self->_result(@_, 'ok', 'bold green');
406	push @{$self->{_good}}, [$self->{perl}, $self->{config}];
407	}
408
409	sub failed
410	{
411	my $self = shift;
412	$self->_result(@_, 'not ok', 'bold red');
413	push @{$self->{_bad}}, [$self->{perl}, $self->{config}];
414	}
415
416	sub warnings
417	{
418	my $self = shift;
419	$self->{_warnings} = \@_;
420	}
421
422	sub _tobol
423	{
424	my $self = shift;
425	print "\n" unless $self->{_atbol};
426	$self->{_atbol} = 1;
427	}
428
429	sub print
430	{
431	my $self = shift;
432	my $text = join '', @_;
433	print $text;
434	$self->{_atbol} = $text =~ /[\r\n]$/;
435	}
436
437	sub say
438	{
439	my $self = shift;
440	$self->_tobol;
441	$self->print(@_, "\n");
442	}
443
444	sub vsay
445	{
446	goto &say if $_[0]->{verbose};
447	}
448
449	sub warn
450	{
451	my $self = shift;
452	$self->say($self->colored(join('', @_), 'red'));
453	}
454
455	sub die
456	{
457	my $self = shift;
458	$self->say($self->colored(join('', 'FATAL: ', @_), 'bold red'));
459	exit -1;
460	}
461
462	sub status
463	{
464	my($self, $text) = @_;
465	$self->_tobol;
466	$self->print($self->colored($text, 'bold'), "\n");
467	}
468
469	sub finish
470	{
471	my $self = shift;
472
473	if (@{$self->{_bad}}) {
474	$self->status("\nFailed with:");
475	for my $fail (@{$self->{_bad}}) {
476	my($perl, $cfg) = @$fail;
477	$self->set(config => $cfg);
478	$self->say(" ", $self->colored($perl, 'blue'), $self->colored($self->_config, 'green'));
479	}
480	}
481
482	$self->status(sprintf("\nPassed with %d of %d combination%s.\n",
483	scalar @{$self->{_good}}, cs($self->{_total})));
484
485	return scalar @{$self->{_bad}};
486	}
487
4a582685	488	__END__
	489
	490	=head1 NAME
	491
	492	soak - Test Perl modules with multiple Perl releases
	493
	494	=head1 SYNOPSIS
	495
	496	soak [options] [perl ...]
	497
	498	--make=program override name of make program ($Config{make})
c07deaaf	499	--min=version use at least this version of perl
4a582685	500	--mmargs=options pass options to Makefile.PL (multiple --mmargs possible)
4a582685	501	--verbose be verbose
56093a11	502	--nocolor don't use colored output
	503
	504	=head1 DESCRIPTION
	505
	506	The F<soak> utility can be used to test Perl modules with
	507	multiple Perl releases or build options. It automates the
	508	task of running F<Makefile.PL> and the modules test suite.
	509
	510	It is not primarily intended for cross-platform checking,
	511	so don't expect it to work on all platforms.
	512
	513	=head1 EXAMPLES
	514
	515	To test your favourite module, just change to its root
	516	directory (where the F<Makefile.PL> is located) and run:
	517
	518	soak
	519
	520	This will automatically look for Perl binaries installed
	521	on your system.
	522
	523	Alternatively, you can explicitly pass F<soak> a list of
	524	Perl binaries:
	525
	526	soak perl5.8.6 perl5.9.2
	527
	528	Last but not least, you can pass it a list of directories
	529	to recursively search for Perl binaries, for example:
	530
	531	soak /tmp/perl/install /usr/bin
	532
	533	All of the above examples will run
	534
	535	perl Makefile.PL
	536	make
	537	make test
	538
	539	for your module and report success or failure.
	540
	541	If your F<Makefile.PL> can take arguments, you may also
	542	want to test different configurations for your module.
	543	You can do so with the I<--mmargs> option:
	544
	545	soak --mmargs=' ' --mmargs='CCFLAGS=-Wextra' --mmargs='enable-debug'
	546
	547	This will run
	548
	549	perl Makefile.PL
	550	make
	551	make test
	552	perl Makefile.PL CCFLAGS=-Wextra
	553	make
	554	make test
	555	perl Makefile.PL enable-debug
	556	make
	557	make test
	558
	559	for each Perl binary.
	560
	561	If you have a directory full of different Perl binaries,
	562	but your module isn't expected to work with ancient perls,
	563	you can use the I<--min> option to specify the minimum
	564	version a Perl binary must have to be chosen for testing:
	565
566	soak --min=5.8.1
567
568	Usually, the output of F<soak> is rather terse, to give
569	you a good overview. If you'd like to see more of what's
570	going on, use the I<--verbose> option:
571
572	soak --verbose
4a582685	573
	574	=head1 COPYRIGHT
	575
0d0f8426	576	Version 3.x, Copyright (c) 2004-2006, Marcus Holland-Moritz.
4a582685	577
	578	Version 2.x, Copyright (C) 2001, Paul Marquess.
	579
	580	Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
	581
	582	This program is free software; you can redistribute it and/or
	583	modify it under the same terms as Perl itself.
	584
	585	=head1 SEE ALSO
	586
	587	See L<Devel::PPPort>.
adfe19db	588
4a582685	589	=cut
adfe19db	590