dist/Devel-PPPort/soak

   1 #!/usr/bin/perl -w
   2 ################################################################################
   3 #
   4 #  soak -- Test Perl modules with multiple Perl releases.
   5 #
   6 #  Original Author: Paul Marquess
   7 #
   8 ################################################################################
   9 #
  10 #  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
  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 ################################################################################
  18
  19 require 5.006001;
  20
  21 use strict;
  22 use warnings;
  23 use ExtUtils::MakeMaker;
  24 use Getopt::Long;
  25 use Pod::Usage;
  26 use File::Find;
  27 use List::Util qw(max);
  28 use Config;
  29
  30 my $VERSION = '3.36';
  31
  32 $| = 1;
  33 my %OPT = (
  34   verbose => 0,
  35   make    => $Config{make} || 'make',
  36   min     => '5.000',
  37   color   => 1,
  38 );
  39
  40 GetOptions(\%OPT, qw(verbose make=s min=s mmargs=s@ color!)) or pod2usage(2);
  41
  42 $OPT{mmargs} = [''] unless exists $OPT{mmargs};
  43 $OPT{min}    = parse_version($OPT{min}) - 1e-10;
  44
  45 sub cs($;$$) { my $x = shift; my($s, $p) = @_ ? @_ : ('', 's'); ($x, $x == 1 ? $s : $p) }
  46
  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($_)] }
  51                 @ARGV ? SearchPerls(@ARGV) : FindPerls();
  52
  53 unless (@GoodPerls) {
  54   print "Sorry, got no Perl binaries for testing.\n\n";
  55   exit 0;
  56 }
  57
  58 my $maxlen = max(map length, @GoodPerls) + 3;
  59 my $mmalen = max(map length, @{$OPT{mmargs}});
  60 $maxlen += $mmalen+3 if $mmalen > 0;
  61
  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(@_)  };
  69
  70 # prime the pump, so the first "make realclean" will work.
  71 runit("$^X Makefile.PL") && runit("$OPT{make} realclean")
  72     or $rep->die("Cannot run $^X Makefile.PL && $OPT{make} realclean\n");
  73
  74 my $tot = @GoodPerls*@{$OPT{mmargs}};
  75
  76 $rep->set(tests => $tot);
  77
  78 $rep->status(sprintf("Testing %d version%s / %d configuration%s (%d combination%s)...\n",
  79                      cs(@GoodPerls), cs(@{$OPT{mmargs}}), cs($tot)));
  80
  81 for my $perl (@GoodPerls) {
  82   for my $mm (@{$OPT{mmargs}}) {
  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);
  94
  95     $rep->warnings(['Makefile.PL' => \@warn_mfpl],
  96                    ['make'        => \@warn_make],
  97                    ['make test'   => \@warn_test]);
  98
  99     if ($ok) {
 100       $rep->passed;
 101     }
 102     else {
 103       $rep->failed;
 104     }
 105
 106     runit("$OPT{make} realclean");
 107   }
 108 }
 109
 110 exit $rep->finish;
 111
 112 sub runit
 113 {
 114   # TODO -- portability alert!!
 115
 116   my($cmd, $warn) = @_;
 117   $rep->vsay("\n    Running [$cmd]");
 118   my $output = `$cmd 2>&1`;
 119   $output = "\n" unless defined $output;
 120   $output =~ s/^/    > /gm;
 121   $rep->say("\n    Output:\n$output") if $OPT{verbose} || $?;
 122   if ($?) {
 123     $rep->warn("    Running '$cmd' failed: $?\n");
 124     return 0;
 125   }
 126   push @$warn, $output =~ /(warning: .*)/ig;
 127   return 1;
 128 }
 129
 130 sub FindPerls
 131 {
 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
 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
 147     5.9.0 5.9.1 5.9.2 5.9.3
 148   );
 149
 150   print "Searching for Perl binaries...\n";
 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
 156   my $mm = MM->new( { NAME => 'dummy' });
 157   my @path = $mm->path;
 158   my @GoodPerls;
 159
 160   for my $perl (@PerlBinaries) {
 161     if (my $abs = $mm->find_perl($perl, ["perl$perl"], \@path, 0)) {
 162       push @GoodPerls, $abs;
 163     }
 164   }
 165
 166   untie *STDOUT;
 167
 168   print "\nFound:\n", (map "    $_\n", @GoodPerls), "\n";
 169
 170   return @GoodPerls;
 171 }
 172
 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";
 182       find({ wanted => sub {
 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;
 188            }, follow => 1 }, $arg);
 189       printf "Found %d Perl binar%s in '%s'.\n\n", cs(@found, 'y', 'ies'), $arg;
 190       push @perls, @found;
 191     }
 192     else {
 193       push @perls, $arg;
 194     }
 195   }
 196
 197   return @perls;
 198 }
 199
 200 sub perl_version
 201 {
 202   my $perl = shift;
 203   my $ver = `$perl -e 'print \$]' 2>&1`;
 204   return $? == 0 && $ver =~ /^\d+\.\d+/ && $ver >= 5 ? $ver : 0;
 205 }
 206
 207 sub parse_version
 208 {
 209   my $ver = shift;
 210
 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
 222 package NoSTDOUT;
 223
 224 use Tie::Handle;
 225 our @ISA = qw(Tie::Handle);
 226
 227 sub TIEHANDLE { bless \(my $s = ''), shift }
 228 sub PRINT {}
 229 sub WRITE {}
 230
 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 {
 241     tests   => undef,
 242     color   => 1,
 243     verbose => 0,
 244     @_,
 245     _cur    => 0,
 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 _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
 289 sub _test
 290 {
 291   my $self = shift;
 292   return $self->_progress . "Testing "
 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;
 339   $self->{_cur}++;
 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;
 462   $self->say($self->colored(join('', @_), 'red'));
 463 }
 464
 465 sub die
 466 {
 467   my $self = shift;
 468   $self->say($self->colored(join('', 'FATAL: ', @_), 'bold red'));
 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
 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})
 509   --min=version      use at least this version of perl
 510   --mmargs=options   pass options to Makefile.PL (multiple --mmargs
 511                      possible)
 512   --verbose          be verbose
 513   --nocolor          don't use colored output
 514
 515 =head1 DESCRIPTION
 516
 517 The F<soak> utility can be used to test Perl modules with
 518 multiple Perl releases or build options. It automates the
 519 task of running F<Makefile.PL> and the modules test suite.
 520
 521 It is not primarily intended for cross-platform checking,
 522 so don't expect it to work on all platforms.
 523
 524 =head1 EXAMPLES
 525
 526 To test your favourite module, just change to its root
 527 directory (where the F<Makefile.PL> is located) and run:
 528
 529   soak
 530
 531 This will automatically look for Perl binaries installed
 532 on your system.
 533
 534 Alternatively, you can explicitly pass F<soak> a list of
 535 Perl binaries:
 536
 537   soak perl5.8.6 perl5.9.2
 538
 539 Last but not least, you can pass it a list of directories
 540 to recursively search for Perl binaries, for example:
 541
 542   soak /tmp/perl/install /usr/bin
 543
 544 All of the above examples will run
 545
 546   perl Makefile.PL
 547   make
 548   make test
 549
 550 for your module and report success or failure.
 551
 552 If your F<Makefile.PL> can take arguments, you may also
 553 want to test different configurations for your module.
 554 You can do so with the I<--mmargs> option:
 555
 556   soak --mmargs=' ' --mmargs='CCFLAGS=-Wextra' --mmargs='enable-debug'
 557
 558 This will run
 559
 560   perl Makefile.PL
 561   make
 562   make test
 563   perl Makefile.PL CCFLAGS=-Wextra
 564   make
 565   make test
 566   perl Makefile.PL enable-debug
 567   make
 568   make test
 569
 570 for each Perl binary.
 571
 572 If you have a directory full of different Perl binaries,
 573 but your module isn't expected to work with ancient perls,
 574 you can use the I<--min> option to specify the minimum
 575 version a Perl binary must have to be chosen for testing:
 576
 577   soak --min=5.8.1
 578
 579 Usually, the output of F<soak> is rather terse, to give
 580 you a good overview. If you'd like to see more of what's
 581 going on, use the I<--verbose> option:
 582
 583   soak --verbose
 584
 585 =head1 COPYRIGHT
 586
 587 Version 3.x, Copyright (c) 2004-2013, Marcus Holland-Moritz.
 588
 589 Version 2.x, Copyright (C) 2001, Paul Marquess.
 590
 591 Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
 592
 593 This program is free software; you can redistribute it and/or
 594 modify it under the same terms as Perl itself.
 595
 596 =head1 SEE ALSO
 597
 598 See L<Devel::PPPort>.
 599
 600 =cut