ext/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 #  $Revision: 19 $
  11 #  $Author: mhx $
  12 #  $Date: 2009/01/18 14:10:50 +0100 $
  13 #
  14 ################################################################################
  15 #
  16 #  Version 3.x, Copyright (C) 2004-2009, Marcus Holland-Moritz.
  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 ################################################################################
  24
  25 require 5.006001;
  26
  27 use strict;
  28 use warnings;
  29 use ExtUtils::MakeMaker;
  30 use Getopt::Long;
  31 use Pod::Usage;
  32 use File::Find;
  33 use List::Util qw(max);
  34 use Config;
  35
  36 my $VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.16 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
  37
  38 $| = 1;
  39 my %OPT = (
  40   verbose => 0,
  41   make    => $Config{make} || 'make',
  42   min     => '5.000',
  43   color   => 1,
  44 );
  45
  46 GetOptions(\%OPT, qw(verbose make=s min=s mmargs=s@ color!)) or pod2usage(2);
  47
  48 $OPT{mmargs} = [''] unless exists $OPT{mmargs};
  49 $OPT{min}    = parse_version($OPT{min}) - 1e-10;
  50
  51 sub cs($;$$) { my $x = shift; my($s, $p) = @_ ? @_ : ('', 's'); ($x, $x == 1 ? $s : $p) }
  52
  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($_)] }
  57                 @ARGV ? SearchPerls(@ARGV) : FindPerls();
  58
  59 unless (@GoodPerls) {
  60   print "Sorry, got no Perl binaries for testing.\n\n";
  61   exit 0;
  62 }
  63
  64 my $maxlen = max(map length, @GoodPerls) + 3;
  65 my $mmalen = max(map length, @{$OPT{mmargs}});
  66 $maxlen += $mmalen+3 if $mmalen > 0;
  67
  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(@_)  };
  75
  76 # prime the pump, so the first "make realclean" will work.
  77 runit("$^X Makefile.PL") && runit("$OPT{make} realclean")
  78     or $rep->die("Cannot run $^X Makefile.PL && $OPT{make} realclean\n");
  79
  80 my $tot = @GoodPerls*@{$OPT{mmargs}};
  81
  82 $rep->set(tests => $tot);
  83
  84 $rep->status(sprintf("Testing %d version%s / %d configuration%s (%d combination%s)...\n",
  85                      cs(@GoodPerls), cs(@{$OPT{mmargs}}), cs($tot)));
  86
  87 for my $perl (@GoodPerls) {
  88   for my $mm (@{$OPT{mmargs}}) {
  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);
 100
 101     $rep->warnings(['Makefile.PL' => \@warn_mfpl],
 102                    ['make'        => \@warn_make],
 103                    ['make test'   => \@warn_test]);
 104
 105     if ($ok) {
 106       $rep->passed;
 107     }
 108     else {
 109       $rep->failed;
 110     }
 111
 112     runit("$OPT{make} realclean");
 113   }
 114 }
 115
 116 exit $rep->finish;
 117
 118 sub runit
 119 {
 120   # TODO -- portability alert!!
 121
 122   my($cmd, $warn) = @_;
 123   $rep->vsay("\n    Running [$cmd]");
 124   my $output = `$cmd 2>&1`;
 125   $output = "\n" unless defined $output;
 126   $output =~ s/^/    > /gm;
 127   $rep->say("\n    Output:\n$output") if $OPT{verbose} || $?;
 128   if ($?) {
 129     $rep->warn("    Running '$cmd' failed: $?\n");
 130     return 0;
 131   }
 132   push @$warn, $output =~ /(warning: .*)/ig;
 133   return 1;
 134 }
 135
 136 sub FindPerls
 137 {
 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
 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
 153     5.9.0 5.9.1 5.9.2 5.9.3
 154   );
 155
 156   print "Searching for Perl binaries...\n";
 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
 162   my $mm = MM->new( { NAME => 'dummy' });
 163   my @path = $mm->path;
 164   my @GoodPerls;
 165
 166   for my $perl (@PerlBinaries) {
 167     if (my $abs = $mm->find_perl($perl, ["perl$perl"], \@path, 0)) {
 168       push @GoodPerls, $abs;
 169     }
 170   }
 171
 172   untie *STDOUT;
 173
 174   print "\nFound:\n", (map "    $_\n", @GoodPerls), "\n";
 175
 176   return @GoodPerls;
 177 }
 178
 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({ wanted => sub {
 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;
 194            }, follow => 1 }, $arg);
 195       printf "Found %d Perl binar%s in '%s'.\n\n", cs(@found, 'y', 'ies'), $arg;
 196       push @perls, @found;
 197     }
 198     else {
 199       push @perls, $arg;
 200     }
 201   }
 202
 203   return @perls;
 204 }
 205
 206 sub perl_version
 207 {
 208   my $perl = shift;
 209   my $ver = `$perl -e 'print \$]' 2>&1`;
 210   return $? == 0 && $ver =~ /^\d+\.\d+/ && $ver >= 5 ? $ver : 0;
 211 }
 212
 213 sub parse_version
 214 {
 215   my $ver = shift;
 216
 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
 228 package NoSTDOUT;
 229
 230 use Tie::Handle;
 231 our @ISA = qw(Tie::Handle);
 232
 233 sub TIEHANDLE { bless \(my $s = ''), shift }
 234 sub PRINT {}
 235 sub WRITE {}
 236
 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 {
 247     tests   => undef,
 248     color   => 1,
 249     verbose => 0,
 250     @_,
 251     _cur    => 0,
 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
 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
 295 sub _test
 296 {
 297   my $self = shift;
 298   return $self->_progress . "Testing "
 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;
 345   $self->{_cur}++;
 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
 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})
 515   --min=version      use at least this version of perl
 516   --mmargs=options   pass options to Makefile.PL (multiple --mmargs possible)
 517   --verbose          be verbose
 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
 589
 590 =head1 COPYRIGHT
 591
 592 Version 3.x, Copyright (c) 2004-2009, Marcus Holland-Moritz.
 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>.
 604
 605 =cut
 606