1 package Test
::Harness
::YAML
;
6 use Best
0.05 [ [ qw
/YAML::Syck 0.85 YAML/], qw
/LoadFile DumpFile/ ];
9 use List
::Util
'shuffle';
15 while (not -f
"$top/util/prove6") {
16 die "Not inside pugs directory\n" unless $top;
17 $top =~ s!(.*)/(.*)!!;
20 # Package and global declarations
21 our @ISA = qw(Test::TAP::Model);
22 our $SMOKERFILE = "smoker.yml";
24 $ENV{TEST_ALWAYS_CALLER
} = 1;
25 $Test::Harness
::Verbose
= 1;
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
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
47 die $Usage if $Config{help};
51 $Config{"concurrent"} ||= $ENV{PUGS_TESTS_CONCURRENT} || 1;
53 eval { require Parallel::ForkManager; };
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;
62 no warnings 'redefine
';
64 my ($self, $child_count, $all_tests) = @_;
65 my $pm = Parallel::ForkManager->new($child_count);
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;
75 # Back in parent process now
76 push @{ $self->{_children} }, $pid;
78 $self->gather_results();
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"}};
94 @ARGV = sort map glob, "t/*/*.t", "t/*/*/*.t", "ext/*/t/*.t" unless @ARGV;
95 @ARGV = split ' ', `$^X $top/t/spec/fudgeall $impl @ARGV`;
97 my $s = __PACKAGE__->new;
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};
116 if ( -d $currfile ) {
117 push( @hits, all_in( $currfile ) ) if $Config{recurse};
119 push( @hits, $currfile ) if $currfile =~ $Config{include_re};
130 # concurrency temp-file. FIXME: use a real temp file?
133 DumpFile("tests.$$.yml", $self->structure);
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
150 my $executable = $ENV{HARNESS_PERL} || "pugs";
151 $ENV{PERL6LIB} = 'blib6
/lib
';
152 $self->{_build_info} = join '', qx{$executable -V};
155 sub _build_exclude_re {
156 my $excl = join "|", # map { quotemeta }
157 map { split /,/ } @{ $Config{exclude} };
158 $Config{exclude_re} = qr/($excl)/ if $excl;
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)$/;
171 $self->set_build_info;
176 $self->{_config} = \%Config;
177 $self->{_timing}{start} = time;
179 $self->SUPER::_init(@_);
184 if (!$Config{anonymous}) {
185 $self->{_smoker} = eval { LoadFile($SMOKERFILE) } ||
186 eval { LoadFile(($ENV{HOME}||'')."/$SMOKERFILE") };
187 if (!$self->{_smoker}) {
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).
196 #$self->{_smoker} ||= { name => "anonymous" };
202 @ARGV = File
::Spec
->curdir unless @ARGV;
203 push( @tests, -d
$_ ? all_in
( $_ ) : $_ ) for @ARGV;
205 @tests = grep { $_ !~ $Config{exclude_re
} } @tests if $Config{exclude_re
};
208 if ($Config{shuffle
}) {
209 @tests = shuffle
(@tests);
211 # default FS order isn't guaranteed sorted; and sorting
212 # helps diffing raw YAML results.
213 @tests = sort @tests;
215 if ( $Config{dry
} ) {
216 print join( "\n", @tests, "" );
219 print "# ", scalar @tests, " tests to run\n" if $Test::Harness
::debug
;
222 $self->{_config
}{test_count
} = scalar @tests;
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";
236 return $self->SUPER::run
(@_) if $Config{concurrent
} == 1;
237 my @tests = $self->get_tests;
238 $self->run_children($Config{concurrent
}, \
@tests);
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: $!";
247 push @
{ $self->{_children
} }, $pid;
249 $self->{_child_num
} = $child;
250 $self->run_test($_) for @own_tests;
255 $self->gather_results();
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.
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: $!";
272 warn "all chunks completed.\n";
279 my $kid = $self->{_child_num
} ?
"[$self->{_child_num}] " : "";
281 local $ENV{PUGS_TIMEOUT
} ||= 60;
283 sub { $self->SUPER::run_test
($test, @rest) }
285 warn " ".timestr
($t)."\n";
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.)
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.