[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: 16 $
#  $Author: mhx $
#  $Date: 2007/08/12 23:25:33 +0200 $
#
################################################################################
#
#  Version 3.x, Copyright (C) 2004-2007, 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.13 $' =~ /(\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");

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