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: 13 $
  11 #  $Author: mhx $
  12 #  $Date: 2006/07/08 16:58:56 +0200 $
  13 #
  14 ################################################################################
  15 #
  16 #  Version 3.x, Copyright (C) 2004-2006, 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.10 $' =~ /(\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 $rep->status(sprintf("Testing %d version%s / %d configuration%s (%d combination%s)...\n",
  81                      cs(@GoodPerls), cs(@{$OPT{mmargs}}), cs(@GoodPerls*@{$OPT{mmargs}})));
  82
  83 for my $perl (@GoodPerls) {
  84   for my $mm (@{$OPT{mmargs}}) {
  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);
  96
  97     $rep->warnings(['Makefile.PL' => \@warn_mfpl],
  98                    ['make'        => \@warn_make],
  99                    ['make test'   => \@warn_test]);
 100
 101     if ($ok) {
 102       $rep->passed;
 103     }
 104     else {
 105       $rep->failed;
 106     }
 107
 108     runit("$OPT{make} realclean");
 109   }
 110 }
 111
 112 exit $rep->finish;
 113
 114 sub runit
 115 {
 116   # TODO -- portability alert!!
 117
 118   my($cmd, $warn) = @_;
 119   $rep->vsay("\n    Running [$cmd]");
 120   my $output = `$cmd 2>&1`;
 121   $output = "\n" unless defined $output;
 122   $output =~ s/^/    > /gm;
 123   $rep->say("\n    Output:\n$output") if $OPT{verbose} || $?;
 124   if ($?) {
 125     $rep->warn("    Running '$cmd' failed: $?\n");
 126     return 0;
 127   }
 128   push @$warn, $output =~ /(warning: .*)/ig;
 129   return 1;
 130 }
 131
 132 sub FindPerls
 133 {
 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
 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
 149     5.9.0 5.9.1 5.9.2 5.9.3
 150   );
 151
 152   print "Searching for Perl binaries...\n";
 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
 158   my $mm = MM->new( { NAME => 'dummy' });
 159   my @path = $mm->path;
 160   my @GoodPerls;
 161
 162   for my $perl (@PerlBinaries) {
 163     if (my $abs = $mm->find_perl($perl, ["perl$perl"], \@path, 0)) {
 164       push @GoodPerls, $abs;
 165     }
 166   }
 167
 168   untie *STDOUT;
 169
 170   print "\nFound:\n", (map "    $_\n", @GoodPerls), "\n";
 171
 172   return @GoodPerls;
 173 }
 174
 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 {
 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;
 190            }, $arg);
 191       printf "Found %d Perl binar%s in '%s'.\n\n", cs(@found, 'y', 'ies'), $arg;
 192       push @perls, @found;
 193     }
 194     else {
 195       push @perls, $arg;
 196     }
 197   }
 198
 199   return @perls;
 200 }
 201
 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
 209 sub parse_version
 210 {
 211   my $ver = shift;
 212
 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
 224 package NoSTDOUT;
 225
 226 use Tie::Handle;
 227 our @ISA = qw(Tie::Handle);
 228
 229 sub TIEHANDLE { bless \(my $s = ''), shift }
 230 sub PRINT {}
 231 sub WRITE {}
 232
 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
 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})
 499   --min=version      use at least this version of perl
 500   --mmargs=options   pass options to Makefile.PL (multiple --mmargs possible)
 501   --verbose          be verbose
 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
 573
 574 =head1 COPYRIGHT
 575
 576 Version 3.x, Copyright (c) 2004-2006, Marcus Holland-Moritz.
 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>.
 588
 589 =cut
 590