cpan/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.27';
  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 possible)
 511   --verbose          be verbose
 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
 583
 584 =head1 COPYRIGHT
 585
 586 Version 3.x, Copyright (c) 2004-2013, Marcus Holland-Moritz.
 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>.
 598
 599 =cut