[perl5.git] / cpan / Devel-PPPort / 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.35';

$| = 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

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.

=head1 SEE ALSO

See L<Devel::PPPort>.

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