util/yaml_harness.pl

   1 package Test::Harness::YAML;
   2 use strict;
   3 use warnings;
   4
   5 use Benchmark;
   6 use Best 0.05 [ [ qw/YAML::Syck 0.85 YAML/], qw/LoadFile DumpFile/ ];
   7 use File::Spec;
   8 use Getopt::Long;
   9 use List::Util 'shuffle';
  10 use Test::Harness;
  11 use Test::TAP::Model;
  12 use Cwd;
  13 my $top = getcwd;
  14
  15 while (not -f "$top/util/prove6") {
  16     die "Not inside pugs directory\n" unless $top;
  17     $top =~ s!(.*)/(.*)!!;
  18 }
  19
  20 # Package and global declarations
  21 our @ISA = qw(Test::TAP::Model);
  22 our $SMOKERFILE = "smoker.yml";
  23 our %Config;
  24 $ENV{TEST_ALWAYS_CALLER} = 1;
  25 $Test::Harness::Verbose  = 1;
  26
  27 $| = 1;
  28
  29 sub get_config {
  30     GetOptions \%Config, qw(
  31         --concurrent|j=i    --shuffle|s   --exclude|X=s@
  32         --output-file|o=s   --recurse|r   --anonymous|a
  33         --include=s@        --dry|n       --help|h
  34     );
  35     fix_config();
  36     my $Usage = qq{Usage: $0 [OPTIONS]
  37         --help, -h              This help message.
  38         --output-file=FILE, -o  Store results in FILE [default: $Config{"output-file"}]
  39         --dry, -n               Show which tests would be run but don't run them
  40         --concurrent=N, -j      Run N test jobs concurrently (MSWin requires Paralle::ForkManager)
  41         --shuffle, -s           Run tests in random order
  42         --recurse, -r           Recurse into directories on test include list
  43         --incude=I1,[I2,...]    Include files
  44         --exclude=E1,[E2,...]   Exclude files
  45         --anonymous, -a         Do not include ~/smoker.yml data in report
  46     } . "\n";
  47     die $Usage if $Config{help};
  48 }
  49
  50 sub fix_config {
  51     $Config{"concurrent"} ||= $ENV{PUGS_TESTS_CONCURRENT} || 1;
  52     local $@;
  53     eval { require Parallel::ForkManager; };
  54     if ($@) {
  55         if ($Config{"concurrent"} > 1 && $^O =~ /MSWin32|msys/) { # On cygwin we are okay.
  56             warn "Sorry, concurrency not supported on your platform\n";
  57             $Config{"concurrent"} = 1;
  58         }
  59         require POSIX;
  60     }
  61     else {
  62         no warnings 'redefine';
  63         *run_children = sub {
  64             my ($self, $child_count, $all_tests) = @_;
  65             my $pm = Parallel::ForkManager->new($child_count);
  66
  67             for my $child (1 .. $child_count) {
  68                 my @own_tests = @{$all_tests}[grep { ($_ % $child_count) == ($child-1) } (0..$#{$all_tests})];
  69                 my $pid = $pm->start and next;
  70                 # Inside child process now
  71                 $self->{_child_num} = $child;
  72                 $self->run_test($_) for @own_tests;
  73                 $self->emit_chunk();
  74                 $pm->finish;
  75                 # Back in parent process now
  76                 push @{ $self->{_children} }, $pid;
  77             }
  78             $self->gather_results();
  79         }
  80     }
  81     $Config{"output-file"} ||= "tests.yml";
  82     $Config{"recurse"}       = 1 if not defined $Config{"recurse"};
  83     # Needed for smokeserv
  84     $Config{"pugs-path"} = $ENV{HARNESS_PERL};
  85     push @{$Config{"exclude"}}, 'Disabled' if not $Config{"exclude"} or not @{$Config{"exclude"}};
  86     _build_include_re();
  87     _build_exclude_re();
  88 }
  89
  90 get_config();
  91
  92 my $impl = "pugs";
  93
  94 @ARGV = sort map glob, "t/*/*.t", "t/*/*/*.t", "ext/*/t/*.t" unless @ARGV;
  95 @ARGV = split ' ', `$^X $top/t/spec/fudgeall $impl @ARGV`;
  96
  97 my $s = __PACKAGE__->new;
  98 $s->run;
  99 $s->emit;
 100 exit 0;
 101
 102 sub all_in {
 103     my $start = shift;
 104
 105     my @hits = ();
 106
 107     local *DH;
 108     if ( opendir( DH, $start ) ) {
 109         while ( my $file = readdir DH ) {
 110             next if $file eq File::Spec->updir || $file eq File::Spec->curdir;
 111             next if $file eq ".svn";
 112             next if $file eq "CVS";
 113             my $currfile = File::Spec->catfile( $start, $file );
 114             next if $Config{exclude_re} && $currfile =~ $Config{exclude_re};
 115
 116             if ( -d $currfile ) {
 117                 push( @hits, all_in( $currfile ) ) if $Config{recurse};
 118             } else {
 119                 push( @hits, $currfile ) if $currfile =~ $Config{include_re};
 120             }
 121         }
 122     } else {
 123         warn "$start: $!\n";
 124     }
 125
 126     return @hits;
 127 }
 128
 129
 130 # concurrency temp-file. FIXME: use a real temp file?
 131 sub emit_chunk {
 132     my($self) = @_;
 133     DumpFile("tests.$$.yml", $self->structure);
 134 }
 135
 136 sub emit {
 137     my($self) = @_;
 138     $self->{_timing}{end} = time;
 139     $self->{_timing}{duration} =
 140         $self->{_timing}{end} - $self->{_timing}{start};
 141     DumpFile($Config{"output-file"}, {
 142             meat => $self->structure,
 143             map { $_ => $self->{"_$_"} } qw{
 144                 build_info smoker config revision timing
 145         }});
 146 }
 147
 148 sub set_build_info {
 149     my($self) = @_;
 150     my $executable = $ENV{HARNESS_PERL} || "pugs";
 151     $ENV{PERL6LIB} = 'blib6/lib';
 152     $self->{_build_info} = join '', qx{$executable -V};
 153 }
 154
 155 sub _build_exclude_re {
 156     my $excl = join "|", # map { quotemeta }
 157         map { split /,/ } @{ $Config{exclude} };
 158     $Config{exclude_re} = qr/($excl)/ if $excl;
 159 }
 160
 161 sub _build_include_re {
 162     my @include = map { split /,/ } @{ $Config{include} };
 163     s/^\.// for @include;
 164     @include = ("t") unless @include;
 165     my $include_re = join( "|", map { quotemeta } @include );
 166     $Config{include_re} = qr/\.($include_re)$/;
 167 }
 168
 169 sub _init {
 170     my($self) = shift;
 171     $self->set_build_info;
 172     $self->get_smoker;
 173     $self->get_revision;
 174
 175     $Config{shuffle}+=0;
 176     $self->{_config} = \%Config;
 177     $self->{_timing}{start} = time;
 178
 179     $self->SUPER::_init(@_);
 180 }
 181
 182 sub get_smoker {
 183     my($self) = @_;
 184     if (!$Config{anonymous}) {
 185         $self->{_smoker} = eval { LoadFile($SMOKERFILE) } ||
 186             eval { LoadFile(($ENV{HOME}||'')."/$SMOKERFILE") };
 187         if (!$self->{_smoker}) {
 188             warn<<"AD";
 189 Smoker info not found. Please create a file named $SMOKERFILE
 190 either in this directory or under your home. You can use the
 191 skeleton in util/smoker-example. Alternatively, say "--anonymous"
 192 on the command line to withold your identity (and this message).
 193 AD
 194         }
 195     }
 196     #$self->{_smoker} ||= { name => "anonymous" };
 197 }
 198
 199 sub get_tests {
 200     my($self) = @_;
 201     my @tests;
 202     @ARGV = File::Spec->curdir unless @ARGV;
 203     push( @tests, -d $_ ? all_in( $_ ) : $_ ) for @ARGV;
 204
 205     @tests = grep { $_ !~ $Config{exclude_re} } @tests if $Config{exclude_re};
 206
 207     if ( @tests ) {
 208         if ($Config{shuffle}) {
 209             @tests = shuffle(@tests);
 210         } else {
 211             # default FS order isn't guaranteed sorted; and sorting
 212             # helps diffing raw YAML results.
 213             @tests = sort @tests;
 214         }
 215         if ( $Config{dry} ) {
 216             print join( "\n", @tests, "" );
 217             exit 0;
 218         } else {
 219             print "# ", scalar @tests, " tests to run\n" if $Test::Harness::debug;
 220         }
 221     }
 222     $self->{_config}{test_count} = scalar @tests;
 223     @tests;
 224 }
 225
 226 sub get_revision {
 227     my($self) = @_;
 228     my $rev_get_cmd = $Config{"pugs-path"}.' -V:pugs_revision';
 229     do { $self->{_revision} = $1 if /pugs_revision: (\d+)\r?$/ } for `@{[$rev_get_cmd]}`;
 230     $self->{_revision} ||= "unknown";
 231     print "$rev_get_cmd returns revision '@{[$self->{_revision}]}'\n";
 232 }
 233
 234 sub run {
 235     my $self = shift;
 236     return $self->SUPER::run(@_) if $Config{concurrent} == 1;
 237     my @tests = $self->get_tests;
 238     $self->run_children($Config{concurrent}, \@tests);
 239 }
 240
 241 sub run_children {
 242     my ($self, $child_count, $all_tests) = @_;
 243     for my $child (1 .. $child_count) {
 244         my @own_tests = @{$all_tests}[grep { ($_ % $child_count) == ($child-1) } (0..$#{$all_tests})];
 245         defined(my $pid = fork) or die "Can't fork: $!";
 246         if ($pid) {
 247             push @{ $self->{_children} }, $pid;
 248         } else {
 249             $self->{_child_num} = $child;
 250             $self->run_test($_) for @own_tests;
 251             $self->emit_chunk();
 252             exit 0;
 253         }
 254     }
 255     $self->gather_results();
 256 }
 257
 258 # the wait here is sequential rather than nonblocking / as-they-come, because
 259 # we want to preserve ordering anyway and it's probably okay to keep a few
 260 # zombies around for a relatively short while.
 261 sub gather_results {
 262     my($self) = @_;
 263     my $kid;
 264     for my $pid (@{ $self->{_children} }) {
 265         my $file = "tests.$pid.yml";
 266         warn sprintf "waiting for chunk #%d...\n", ++$kid;
 267         waitpid($pid, 0) or die "waitpid: $!";
 268         my $chunk = LoadFile($file) or die "can't parse chunk ($file)";
 269         push @{ $self->{meat}{test_files} }, @{$chunk->{test_files}};
 270         unlink $file or die "unlink: $!";
 271     }
 272     warn "all chunks completed.\n";
 273 }
 274
 275 sub run_test {
 276     my $self = shift;
 277     my $test = shift;
 278     my @rest = @_;
 279     my $kid  = $self->{_child_num} ? "[$self->{_child_num}] " : "";
 280
 281     local $ENV{PUGS_TIMEOUT} ||= 60;
 282     my $t = timeit( 1,
 283         sub { $self->SUPER::run_test($test, @rest) }
 284     );
 285     warn "    ".timestr($t)."\n";
 286 }
 287
 288 __END__
 289 # Simple YAML test harness written over Test::Harness::Straps.
 290 # Hacked up from mini_harness.plx in the Test::Harness dist.
 291 # (And some stuff stolen from prove, too.)
 292
 293 # Please improve me!
 294 #
 295 # TODO:
 296 # 1. Modularize this.
 297 # 2. Get to work concurrently with 'make test'
 298 # 3. 'make smoke' make target that uploads the results of this
 299 #    to a server somewhere.