File Coverage

support/Test/Harness.pm

Criterion	Covered	Total	%
statement	152	328	46.3
branch	44	142	31.0
condition	9	39	23.1
subroutine	23	30	76.7
pod	2	9	22.2
total	230	548	42.0

line	stmt	bran	cond	sub	pod	time	code
1							# -- Mode: cperl; cperl-indent-level: 4 --
2
3							package Test::Harness;
4
5							require 5.00405;
6	1			1		37	use Test::Harness::Straps;
	1					10
	1					22
7	1			1		19	use Test::Harness::Assert;
	1					9
	1					20
8	1			1		15	use Exporter;
	1					9
	1					14
9	1			1		36	use Benchmark;
	1					10
	1					18
10	1			1		16	use Config;
	1					10
	1					15
11	1			1		15	use strict;
	1					9
	1					1319
12
13
14	1					17	use vars qw(
15							$VERSION
16							@ISA @EXPORT @EXPORT_OK
17							$Verbose $Switches $Debug
18							$verbose $switches $debug
19							$Columns
20							$Timer
21							$ML $Last_ML_Print
22							$Strap
23							$has_time_hires
24	1			1		14	);
	1					9
25
26							BEGIN {
27	1			1		9	eval "use Time::HiRes 'time'";
	1			1		16
	1					9
	1					16
28	1					23	$has_time_hires = !$@;
29							}
30
31							=head1 NAME
32
33							Test::Harness - Run Perl standard test scripts with statistics
34
35							=head1 VERSION
36
37							Version 2.62
38
39							=cut
40
41							$VERSION = '2.62';
42
43							# Backwards compatibility for exportable variable names.
44							verbose = Verbose;
45							switches = Switches;
46							debug = Debug;
47
48							$ENV{HARNESS_ACTIVE} = 1;
49							$ENV{HARNESS_VERSION} = $VERSION;
50
51							END {
52							# For VMS.
53							delete $ENV{HARNESS_ACTIVE};
54							delete $ENV{HARNESS_VERSION};
55							}
56
57							my $Files_In_Dir = $ENV{HARNESS_FILELEAK_IN_DIR};
58
59							$Strap = Test::Harness::Straps->new;
60
61	0			0	0	0	sub strap { return $Strap };
62
63							@ISA = ('Exporter');
64							@EXPORT = qw(&runtests);
65							@EXPORT_OK = qw(&execute_tests $verbose $switches);
66
67							$Verbose = $ENV{HARNESS_VERBOSE} \|\| 0;
68							$Debug = $ENV{HARNESS_DEBUG} \|\| 0;
69							$Switches = "-w";
70							$Columns = $ENV{HARNESS_COLUMNS} \|\| $ENV{COLUMNS} \|\| 80;
71							$Columns--; # Some shells have trouble with a full line of text.
72							$Timer = $ENV{HARNESS_TIMER} \|\| 0;
73
74							=head1 SYNOPSIS
75
76							use Test::Harness;
77
78							runtests(@test_files);
79
80							=head1 DESCRIPTION
81
82							B<STOP!> If all you want to do is write a test script, consider
83							using Test::Simple. Test::Harness is the module that reads the
84							output from Test::Simple, Test::More and other modules based on
85							Test::Builder. You don't need to know about Test::Harness to use
86							those modules.
87
88							Test::Harness runs tests and expects output from the test in a
89							certain format. That format is called TAP, the Test Anything
90							Protocol. It is defined in L<Test::Harness::TAP>.
91
92							C<Test::Harness::runtests(@tests)> runs all the testscripts named
93							as arguments and checks standard output for the expected strings
94							in TAP format.
95
96							The F<prove> utility is a thin wrapper around Test::Harness.
97
98							=head2 Taint mode
99
100							Test::Harness will honor the C<-T> or C<-t> in the #! line on your
101							test files. So if you begin a test with:
102
103							#!perl -T
104
105							the test will be run with taint mode on.
106
107							=head2 Configuration variables.
108
109							These variables can be used to configure the behavior of
110							Test::Harness. They are exported on request.
111
112							=over 4
113
114							=item C<$Test::Harness::Verbose>
115
116							The package variable C<$Test::Harness::Verbose> is exportable and can be
117							used to let C<runtests()> display the standard output of the script
118							without altering the behavior otherwise. The F<prove> utility's C<-v>
119							flag will set this.
120
121							=item C<$Test::Harness::switches>
122
123							The package variable C<$Test::Harness::switches> is exportable and can be
124							used to set perl command line options used for running the test
125							script(s). The default value is C<-w>. It overrides C<HARNESS_PERL_SWITCHES>.
126
127							=item C<$Test::Harness::Timer>
128
129							If set to true, and C<Time::HiRes> is available, print elapsed seconds
130							after each test file.
131
132							=back
133
134
135							=head2 Failure
136
137							When tests fail, analyze the summary report:
138
139							t/base..............ok
140							t/nonumbers.........ok
141							t/ok................ok
142							t/test-harness......ok
143							t/waterloo..........dubious
144							Test returned status 3 (wstat 768, 0x300)
145							DIED. FAILED tests 1, 3, 5, 7, 9, 11, 13, 15, 17, 19
146							Failed 10/20 tests, 50.00% okay
147							Failed Test Stat Wstat Total Fail List of Failed
148							---------------------------------------------------------------
149							t/waterloo.t 3 768 20 10 1 3 5 7 9 11 13 15 17 19
150							Failed 1/5 test scripts, 80.00% okay. 10/44 subtests failed, 77.27% okay.
151
152							Everything passed but F<t/waterloo.t>. It failed 10 of 20 tests and
153							exited with non-zero status indicating something dubious happened.
154
155							The columns in the summary report mean:
156
157							=over 4
158
159							=item B<Failed Test>
160
161							The test file which failed.
162
163							=item B<Stat>
164
165							If the test exited with non-zero, this is its exit status.
166
167							=item B<Wstat>
168
169							The wait status of the test.
170
171							=item B<Total>
172
173							Total number of tests expected to run.
174
175							=item B<Fail>
176
177							Number which failed, either from "not ok" or because they never ran.
178
179							=item B<List of Failed>
180
181							A list of the tests which failed. Successive failures may be
182							abbreviated (ie. 15-20 to indicate that tests 15, 16, 17, 18, 19 and
183							20 failed).
184
185							=back
186
187
188							=head1 FUNCTIONS
189
190							The following functions are available.
191
192							=head2 runtests( @test_files )
193
194							This runs all the given I<@test_files> and divines whether they passed
195							or failed based on their output to STDOUT (details above). It prints
196							out each individual test which failed along with a summary report and
197							a how long it all took.
198
199							It returns true if everything was ok. Otherwise it will C<die()> with
200							one of the messages in the DIAGNOSTICS section.
201
202							=cut
203
204							sub runtests {
205	1			1	1	34862	my(@tests) = @_;
206
207	1					14	local ($\, $,);
208
209	1					13	my ($tot, $failedtests,$todo_passed) = execute_tests(tests => \@tests);
210	1					180	print get_results($tot, $failedtests,$todo_passed);
211
212	1					71	my $ok = _all_ok($tot);
213
214	1		25			52	assert(($ok xor keys %$failedtests),
215							q{ok status jives with $failedtests});
216
217	1	50				11	if (! $ok) {
218	0					0	die("Failed $tot->{bad}/$tot->{tests} test programs. " .
219	0					0	"@{[$tot->{max} - $tot->{ok}]}/$tot->{max} subtests failed.\n");
220							}
221
222	1					247	return $ok;
223							}
224
225							# my $ok = _all_ok(\%tot);
226							# Tells you if this test run is overall successful or not.
227
228							sub _all_ok {
229	2			2		22	my($tot) = shift;
230
231	2	50	33			52	return $tot->{bad} == 0 && ($tot->{max} \|\| $tot->{skipped}) ? 1 : 0;
			33
232							}
233
234							# Returns all the files in a directory. This is shorthand for backwards
235							# compatibility on systems where C<glob()> doesn't work right.
236
237							sub _globdir {
238	0			0		0	local *DIRH;
239
240	0					0	opendir DIRH, shift;
241	0					0	my @f = readdir DIRH;
242	0					0	closedir DIRH;
243
244	0					0	return @f;
245							}
246
247							=head2 execute_tests( tests => \@test_files, out => \*FH )
248
249							Runs all the given C<@test_files> (just like C<runtests()>) but
250							doesn't generate the final report. During testing, progress
251							information will be written to the currently selected output
252							filehandle (usually C<STDOUT>), or to the filehandle given by the
253							C<out> parameter. The I<out> is optional.
254
255							Returns a list of two values, C<$total> and C<$failed>, describing the
256							results. C<$total> is a hash ref summary of all the tests run. Its
257							keys and values are this:
258
259							bonus Number of individual todo tests unexpectedly passed
260							max Number of individual tests ran
261							ok Number of individual tests passed
262							sub_skipped Number of individual tests skipped
263							todo Number of individual todo tests
264
265							files Number of test files ran
266							good Number of test files passed
267							bad Number of test files failed
268							tests Number of test files originally given
269							skipped Number of test files skipped
270
271							If C<< $total->{bad} == 0 >> and C<< $total->{max} > 0 >>, you've
272							got a successful test.
273
274							C<$failed> is a hash ref of all the test scripts that failed. Each key
275							is the name of a test script, each value is another hash representing
276							how that script failed. Its keys are these:
277
278							name Name of the test which failed
279							estat Script's exit value
280							wstat Script's wait status
281							max Number of individual tests
282							failed Number which failed
283							canon List of tests which failed (as string).
284
285							C<$failed> should be empty if everything passed.
286
287							=cut
288
289							sub execute_tests {
290	1			1	1	12	my %args = @_;
291	1					9	my @tests = @{$args{tests}};
	1					537
292	1		33			22	my $out = $args{out} \|\| select();
293
294							# We allow filehandles that are symbolic refs
295	1			1		25	no strict 'refs';
	1					11
	1					18
296	1					12	_autoflush($out);
297	1					10	_autoflush(\*STDERR);
298
299	1					9	my %failedtests;
300	1					9	my %todo_passed;
301
302							# Test-wide totals.
303	1					20	my(%tot) = (
304							bonus => 0,
305							max => 0,
306							ok => 0,
307							files => 0,
308							bad => 0,
309							good => 0,
310							tests => scalar @tests,
311							sub_skipped => 0,
312							todo => 0,
313							skipped => 0,
314							bench => 0,
315							);
316
317	1					9	my @dir_files;
318	1	50				11	@dir_files = _globdir $Files_In_Dir if defined $Files_In_Dir;
319	1					18	my $run_start_time = new Benchmark;
320
321	1					130	my $width = _leader_width(@tests);
322	1					12	foreach my $tfile (@tests) {
323	58					1644	$Last_ML_Print = 0; # so each test prints at least once
324	58					3465	my($leader, $ml) = _mk_leader($tfile, $width);
325	58					681	local $ML = $ml;
326
327	58					33508	print $out $leader;
328
329	58					611	$tot{files}++;
330
331	58					1820	$Strap->{_seen_header} = 0;
332	58	50				587	if ( $Test::Harness::Debug ) {
333	0					0	print $out "# Running: ", $Strap->_command_line($tfile), "\n";
334							}
335	58	50				689	my $test_start_time = $Timer ? time : 0;
336							my %results = $Strap->analyze_file($tfile) or
337	58	50				3315	do { warn $Strap->{error}, "\n"; next };
	0					0
	0					0
338	58					725	my $elapsed;
339	58	50				538	if ( $Timer ) {
340	0					0	$elapsed = time - $test_start_time;
341	0	0				0	if ( $has_time_hires ) {
342	0					0	$elapsed = sprintf( " %8d ms", $elapsed*1000 );
343							}
344							else {
345	0	0				0	$elapsed = sprintf( " %8s s", $elapsed ? $elapsed : "<1" );
346							}
347							}
348							else {
349	58					687	$elapsed = "";
350							}
351
352							# state of the current test.
353	50334					1293728	my @failed = grep { !$results{details}[$_-1]{ok} }
	58					21084
354	58					676	1..@{$results{details}};
355	50334	50				1537344	my @todo_pass = grep { $results{details}[$_-1]{actual_ok} &&
	58					6822
356							$results{details}[$_-1]{type} eq 'todo' }
357	58					11286	1..@{$results{details}};
358
359	58					15126	my %test = (
360							ok => $results{ok},
361							'next' => $Strap->{'next'},
362							max => $results{max},
363							failed => \@failed,
364							todo_pass => \@todo_pass,
365							todo => $results{todo},
366							bonus => $results{bonus},
367							skipped => $results{skip},
368							skip_reason => $results{skip_reason},
369							skip_all => $Strap->{skip_all},
370							ml => $ml,
371							);
372
373	58					1873	$tot{bonus} += $results{bonus};
374	58					2433	$tot{max} += $results{max};
375	58					617	$tot{ok} += $results{ok};
376	58					607	$tot{todo} += $results{todo};
377	58					4223	$tot{sub_skipped} += $results{skip};
378
379	58					1997	my($estatus, $wstatus) = @results{qw(exit wait)};
380
381	58	50				663	if ($results{passing}) {
382							# XXX Combine these first two
383	58	100	66			4698	if ($test{max} and $test{skipped} + $test{bonus}) {
		50	0
		0
384	6					53	my @msg;
385	6	50				2981	push(@msg, "$test{skipped}/$test{max} skipped: $test{skip_reason}")
386							if $test{skipped};
387	6	50				63	if ($test{bonus}) {
388	0					0	my ($txt, $canon) = _canondetail($test{todo},0,'TODO passed',
389	0					0	@{$test{todo_pass}});
390	0					0	$todo_passed{$tfile} = {
391							canon => $canon,
392							max => $test{todo},
393							failed => $test{bonus},
394							name => $tfile,
395							estat => '',
396							wstat => '',
397							};
398
399	0					0	push(@msg, "$test{bonus}/$test{max} unexpectedly succeeded\n$txt");
400							}
401	6					13865	print $out "$test{ml}ok$elapsed\n ".join(', ', @msg)."\n";
402							}
403							elsif ( $test{max} ) {
404	52					46794	print $out "$test{ml}ok$elapsed\n";
405							}
406							elsif ( defined $test{skip_all} and length $test{skip_all} ) {
407	0					0	print $out "skipped\n all skipped: $test{skip_all}\n";
408	0					0	$tot{skipped}++;
409							}
410							else {
411	0					0	print $out "skipped\n all skipped: no reason given\n";
412	0					0	$tot{skipped}++;
413							}
414	58					10510	$tot{good}++;
415							}
416							else {
417							# List unrun tests as failures.
418	0	0				0	if ($test{'next'} <= $test{max}) {
419	0					0	push @{$test{failed}}, $test{'next'}..$test{max};
	0					0
420							}
421							# List overruns as failures.
422							else {
423	0					0	my $details = $results{details};
424	0					0	foreach my $overrun ($test{max}+1..@$details) {
425	0	0				0	next unless ref $details->[$overrun-1];
426	0					0	push @{$test{failed}}, $overrun
	0					0
427							}
428							}
429
430	0	0				0	if ($wstatus) {
		0
431	0					0	$failedtests{$tfile} = _dubious_return(\%test, \%tot,
432							$estatus, $wstatus);
433	0					0	$failedtests{$tfile}{name} = $tfile;
434							}
435							elsif($results{seen}) {
436	0	0	0			0	if (@{$test{failed}} and $test{max}) {
	0					0
437	0					0	my ($txt, $canon) = _canondetail($test{max},$test{skipped},'Failed',
438	0					0	@{$test{failed}});
439	0					0	print $out "$test{ml}$txt";
440	0					0	$failedtests{$tfile} = { canon => $canon,
441							max => $test{max},
442	0					0	failed => scalar @{$test{failed}},
443							name => $tfile,
444							estat => '',
445							wstat => '',
446							};
447							}
448							else {
449	0					0	print $out "Don't know which tests failed: got $test{ok} ok, ".
450							"expected $test{max}\n";
451	0					0	$failedtests{$tfile} = { canon => '??',
452							max => $test{max},
453							failed => '??',
454							name => $tfile,
455							estat => '',
456							wstat => '',
457							};
458							}
459	0					0	$tot{bad}++;
460							}
461							else {
462	0					0	print $out "FAILED before any test output arrived\n";
463	0					0	$tot{bad}++;
464	0					0	$failedtests{$tfile} = { canon => '??',
465							max => '??',
466							failed => '??',
467							name => $tfile,
468							estat => '',
469							wstat => '',
470							};
471							}
472							}
473
474	58	50				4541	if (defined $Files_In_Dir) {
475	0					0	my @new_dir_files = _globdir $Files_In_Dir;
476	0	0				0	if (@new_dir_files != @dir_files) {
477	0					0	my %f;
478	0					0	@f{@new_dir_files} = (1) x @new_dir_files;
479	0					0	delete @f{@dir_files};
480	0					0	my @f = sort keys %f;
481	0					0	print $out "LEAKED FILES: @f\n";
482	0					0	@dir_files = @new_dir_files;
483							}
484							}
485							} # foreach test
486	1					183	$tot{bench} = timediff(new Benchmark, $run_start_time);
487
488	1					254	$Strap->_restore_PERL5LIB;
489
490	1					233	return(\%tot, \%failedtests, \%todo_passed);
491							}
492
493							# Turns on autoflush for the handle passed
494							sub _autoflush {
495	2			2		19	my $flushy_fh = shift;
496	2					23	my $old_fh = select $flushy_fh;
497	2					21	$\| = 1;
498	2					25	select $old_fh;
499							}
500
501							=for private _mk_leader
502
503							my($leader, $ml) = _mk_leader($test_file, $width);
504
505							Generates the 't/foo........' leader for the given C<$test_file> as well
506							as a similar version which will overwrite the current line (by use of
507							\r and such). C<$ml> may be empty if Test::Harness doesn't think you're
508							on TTY.
509
510							The C<$width> is the width of the "yada/blah.." string.
511
512							=cut
513
514							sub _mk_leader {
515	58			58		2234	my($te, $width) = @_;
516	58					8427	chomp($te);
517	58					3341	$te =~ s/\.\w+$/./;
518
519	58	50				5709	if ($^O eq 'VMS') {
520	0					0	$te =~ s/^.*\.t\./\[.t./s;
521							}
522	58					5100	my $leader = "$te" . '.' x ($width - length($te));
523	58					2322	my $ml = "";
524
525	58	50	33			3794	if ( -t STDOUT and not $ENV{HARNESS_NOTTY} and not $Verbose ) {
			33
526	58					671	$ml = "\r" . (' ' x 77) . "\r$leader"
527							}
528
529	58					3413	return($leader, $ml);
530							}
531
532							=for private _leader_width
533
534							my($width) = _leader_width(@test_files);
535
536							Calculates how wide the leader should be based on the length of the
537							longest test name.
538
539							=cut
540
541							sub _leader_width {
542	1			1		9	my $maxlen = 0;
543	1					9	my $maxsuflen = 0;
544	1					11	foreach (@_) {
545	58	50				11165	my $suf = /\.(\w+)$/ ? $1 : '';
546	58					9354	my $len = length;
547	58					470	my $suflen = length $suf;
548	58	100				520	$maxlen = $len if $len > $maxlen;
549	58	100				2153	$maxsuflen = $suflen if $suflen > $maxsuflen;
550							}
551							# + 3 : we want three dots between the test name and the "ok"
552	1					17	return $maxlen + 3 - $maxsuflen;
553							}
554
555							sub get_results {
556	1			1	0	17	my $tot = shift;
557	1					11	my $failedtests = shift;
558	1					11	my $todo_passed = shift;
559
560	1					10	my $out = '';
561
562	1					121	my $bonusmsg = _bonusmsg($tot);
563
564	1	50				30	if (_all_ok($tot)) {
		0
		0
565	1					16	$out .= "All tests successful$bonusmsg.\n";
566	1	50				18	if ($tot->{bonus}) {
567	0					0	my($fmt_top, $fmt) = _create_fmts("Passed TODO",$todo_passed);
568							# Now write to formats
569	0					0	$out .= swrite( $fmt_top );
570	0	0				0	for my $script (sort keys %{$todo_passed\|\|{}}) {
	0					0
571	0					0	my $Curtest = $todo_passed->{$script};
572	0					0	$out .= swrite( $fmt, @{ $Curtest }{qw(name estat wstat max failed canon)} );
	0					0
573							}
574							}
575							}
576							elsif (!$tot->{tests}){
577	0					0	die "FAILED--no tests were run for some reason.\n";
578							}
579							elsif (!$tot->{max}) {
580	0	0				0	my $blurb = $tot->{tests}==1 ? "script" : "scripts";
581	0					0	die "FAILED--$tot->{tests} test $blurb could be run, ".
582							"alas--no output ever seen\n";
583							}
584							else {
585	0					0	my $subresults = sprintf( " %d/%d subtests failed.",
586							$tot->{max} - $tot->{ok}, $tot->{max} );
587
588	0					0	my($fmt_top, $fmt1, $fmt2) = _create_fmts("Failed Test",$failedtests);
589
590							# Now write to formats
591	0					0	$out .= swrite( $fmt_top );
592	0					0	for my $script (sort keys %$failedtests) {
593	0					0	my $Curtest = $failedtests->{$script};
594	0					0	$out .= swrite( $fmt1, @{ $Curtest }{qw(name estat wstat max failed canon)} );
	0					0
595	0					0	$out .= swrite( $fmt2, $Curtest->{canon} );
596							}
597	0	0				0	if ($tot->{bad}) {
598	0					0	$bonusmsg =~ s/^,\s*//;
599	0	0				0	$out .= "$bonusmsg.\n" if $bonusmsg;
600	0					0	$out .= "Failed $tot->{bad}/$tot->{tests} test scripts.$subresults\n";
601							}
602							}
603
604	1					101	$out .= sprintf("Files=%d, Tests=%d, %s\n",
605							$tot->{files}, $tot->{max}, timestr($tot->{bench}, 'nop'));
606	1					739	return $out;
607							}
608
609							sub swrite {
610	0			0	0	0	my $format = shift;
611	0					0	$^A = '';
612	0					0	formline($format,@_);
613	0					0	my $out = $^A;
614	0					0	$^A = '';
615	0					0	return $out;
616							}
617
618
619							my %Handlers = (
620							header => \&header_handler,
621							test => \&test_handler,
622							bailout => \&bailout_handler,
623							);
624
625							$Strap->{callback} = \&strap_callback;
626							sub strap_callback {
627	87284			87284	0	2145714	my($self, $line, $type, $totals) = @_;
628	87284	50				2053474	print $line if $Verbose;
629
630	87284					1241395	my $meth = $Handlers{$type};
631	87284	100				2712220	$meth->($self, $line, $type, $totals) if $meth;
632							};
633
634
635							sub header_handler {
636	58			58	0	2952	my($self, $line, $type, $totals) = @_;
637
638	58	50				774	warn "Test header seen more than once!\n" if $self->{_seen_header};
639
640	58					685	$self->{_seen_header}++;
641
642	58	50	33			3416	warn "1..M can only appear at the beginning or end of tests\n"
643							if $totals->{seen} &&
644							$totals->{max} < $totals->{seen};
645							};
646
647							sub test_handler {
648	50334			50334	0	1612775	my($self, $line, $type, $totals) = @_;
649
650	50334					1421406	my $curr = $totals->{seen};
651	50334					1348930	my $next = $self->{'next'};
652	50334					784200	my $max = $totals->{max};
653	50334					1171369	my $detail = $totals->{details}[-1];
654
655	50334	50				1524435	if( $detail->{ok} ) {
656	50334					2242265	_print_ml_less("ok $curr/$max");
657
658	50334	100				1633893	if( $detail->{type} eq 'skip' ) {
659	556	100				6128	$totals->{skip_reason} = $detail->{reason}
660							unless defined $totals->{skip_reason};
661	556	50				5742	$totals->{skip_reason} = 'various reasons'
662							if $totals->{skip_reason} ne $detail->{reason};
663							}
664							}
665							else {
666	0					0	_print_ml("NOK $curr");
667							}
668
669	50334	50				4174074	if( $curr > $next ) {
		50
670	0					0	print "Test output counter mismatch [test $curr]\n";
671							}
672							elsif( $curr < $next ) {
673	0					0	print "Confused test output: test $curr answered after ".
674							"test ", $next - 1, "\n";
675							}
676
677							};
678
679							sub bailout_handler {
680	0			0	0	0	my($self, $line, $type, $totals) = @_;
681
682	0	0				0	die "FAILED--Further testing stopped" .
683							($self->{bailout_reason} ? ": $self->{bailout_reason}\n" : ".\n");
684							};
685
686
687							sub _print_ml {
688	366	50		366		423374	print join '', $ML, @_ if $ML;
689							}
690
691
692							# Print updates only once per second.
693							sub _print_ml_less {
694	50334			50334		1989344	my $now = CORE::time;
695	50334	100				1475718	if ( $Last_ML_Print != $now ) {
696	366					7173	_print_ml(@_);
697	366					12802	$Last_ML_Print = $now;
698							}
699							}
700
701							sub _bonusmsg {
702	1			1		11	my($tot) = @_;
703
704	1					28	my $bonusmsg = '';
705	1	0				580	$bonusmsg = (" ($tot->{bonus} subtest".($tot->{bonus} > 1 ? 's' : '').
		50
706							" UNEXPECTEDLY SUCCEEDED)")
707							if $tot->{bonus};
708
709	1	50				18	if ($tot->{skipped}) {
		50
710	0	0				0	$bonusmsg .= ", $tot->{skipped} test"
711							. ($tot->{skipped} != 1 ? 's' : '');
712	0	0				0	if ($tot->{sub_skipped}) {
713	0	0				0	$bonusmsg .= " and $tot->{sub_skipped} subtest"
714							. ($tot->{sub_skipped} != 1 ? 's' : '');
715							}
716	0					0	$bonusmsg .= ' skipped';
717							}
718							elsif ($tot->{sub_skipped}) {
719	1	50				21	$bonusmsg .= ", $tot->{sub_skipped} subtest"
720							. ($tot->{sub_skipped} != 1 ? 's' : '')
721							. " skipped";
722							}
723	1					19	return $bonusmsg;
724							}
725
726							# Test program go boom.
727							sub _dubious_return {
728	0			0			my($test, $tot, $estatus, $wstatus) = @_;
729
730	0						my $failed = '??';
731	0						my $canon = '??';
732
733	0						printf "$test->{ml}dubious\n\tTest returned status $estatus ".
734							"(wstat %d, 0x%x)\n",
735							$wstatus,$wstatus;
736	0	0					print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS';
737
738	0						$tot->{bad}++;
739
740	0	0					if ($test->{max}) {
741	0	0	0				if ($test->{'next'} == $test->{max} + 1 and not @{$test->{failed}}) {
	0
742	0						print "\tafter all the subtests completed successfully\n";
743	0						$failed = 0; # But we do not set $canon!
744							}
745							else {
746	0						push @{$test->{failed}}, $test->{'next'}..$test->{max};
	0
747	0						$failed = @{$test->{failed}};
	0
748	0						(my $txt, $canon) = _canondetail($test->{max},$test->{skipped},'Failed',@{$test->{failed}});
	0
749	0						print "DIED. ",$txt;
750							}
751							}
752
753	0		0				return { canon => $canon, max => $test->{max} \|\| '??',
754							failed => $failed,
755							estat => $estatus, wstat => $wstatus,
756							};
757							}
758
759
760							sub _create_fmts {
761	0			0			my $failed_str = shift;
762	0						my $failedtests = shift;
763
764	0						my ($type) = split /\s/,$failed_str;
765	0						my $short = substr($type,0,4);
766	0	0					my $total = $short eq 'Pass' ? 'TODOs' : 'Total';
767	0						my $middle_str = " Stat Wstat $total $short ";
768	0						my $list_str = "List of $type";
769
770							# Figure out our longest name string for formatting purposes.
771	0						my $max_namelen = length($failed_str);
772	0						foreach my $script (keys %$failedtests) {
773	0						my $namelen = length $failedtests->{$script}->{name};
774	0	0					$max_namelen = $namelen if $namelen > $max_namelen;
775							}
776
777	0						my $list_len = $Columns - length($middle_str) - $max_namelen;
778	0	0					if ($list_len < length($list_str)) {
779	0						$list_len = length($list_str);
780	0						$max_namelen = $Columns - length($middle_str) - $list_len;
781	0	0					if ($max_namelen < length($failed_str)) {
782	0						$max_namelen = length($failed_str);
783	0						$Columns = $max_namelen + length($middle_str) + $list_len;
784							}
785							}
786
787	0						my $fmt_top = sprintf("%-${max_namelen}s", $failed_str)
788							. $middle_str
789							. $list_str . "\n"
790							. "-" x $Columns
791							. "\n";
792
793	0						my $fmt1 = "@" . "<" x ($max_namelen - 1)
794							. " @>> @>>>> @>>>> @>>> "
795							. "^" . "<" x ($list_len - 1) . "\n";
796	0						my $fmt2 = "~~" . " " x ($Columns - $list_len - 2) . "^"
797							. "<" x ($list_len - 1) . "\n";
798
799	0						return($fmt_top, $fmt1, $fmt2);
800							}
801
802							sub _canondetail {
803	0			0			my $max = shift;
804	0						my $skipped = shift;
805	0						my $type = shift;
806	0						my @detail = @_;
807	0						my %seen;
808	0						@detail = sort {$a <=> $b} grep !$seen{$_}++, @detail;
	0
809	0						my $detail = @detail;
810	0						my @result = ();
811	0						my @canon = ();
812	0						my $min;
813	0						my $last = $min = shift @detail;
814	0						my $canon;
815	0						my $uc_type = uc($type);
816	0	0					if (@detail) {
817	0						for (@detail, $detail[-1]) { # don't forget the last one
818	0	0	0				if ($_ > $last+1 \|\| $_ == $last) {
819	0	0					push @canon, ($min == $last) ? $last : "$min-$last";
820	0						$min = $_;
821							}
822	0						$last = $_;
823							}
824	0						local $" = ", ";
825	0						push @result, "$uc_type tests @canon\n";
826	0						$canon = join ' ', @canon;
827							}
828							else {
829	0						push @result, "$uc_type test $last\n";
830	0						$canon = $last;
831							}
832
833	0	0					return (join("", @result), $canon)
834							if $type=~/todo/i;
835	0						push @result, "\t$type $detail/$max tests, ";
836	0	0					if ($max) {
837	0						push @result, sprintf("%.2f",100*(1-$detail/$max)), "% okay";
838							}
839							else {
840	0						push @result, "?% okay";
841							}
842	0						my $ender = 's' x ($skipped > 1);
843	0	0					if ($skipped) {
844	0						my $good = $max - $detail - $skipped;
845	0						my $skipmsg = " (less $skipped skipped test$ender: $good okay, ";
846	0	0					if ($max) {
847	0						my $goodper = sprintf("%.2f",100*($good/$max));
848	0						$skipmsg .= "$goodper%)";
849							}
850							else {
851	0						$skipmsg .= "?%)";
852							}
853	0						push @result, $skipmsg;
854							}
855	0						push @result, "\n";
856	0						my $txt = join "", @result;
857	0						return ($txt, $canon);
858							}
859
860							1;
861							__END__
862
863
864							=head1 EXPORT
865
866							C<&runtests> is exported by Test::Harness by default.
867
868							C<&execute_tests>, C<$verbose>, C<$switches> and C<$debug> are
869							exported upon request.
870
871							=head1 DIAGNOSTICS
872
873							=over 4
874
875							=item C<All tests successful.\nFiles=%d, Tests=%d, %s>
876
877							If all tests are successful some statistics about the performance are
878							printed.
879
880							=item C<FAILED tests %s\n\tFailed %d/%d tests, %.2f%% okay.>
881
882							For any single script that has failing subtests statistics like the
883							above are printed.
884
885							=item C<Test returned status %d (wstat %d)>
886
887							Scripts that return a non-zero exit status, both C<$? E<gt>E<gt> 8>
888							and C<$?> are printed in a message similar to the above.
889
890							=item C<Failed 1 test, %.2f%% okay. %s>
891
892							=item C<Failed %d/%d tests, %.2f%% okay. %s>
893
894							If not all tests were successful, the script dies with one of the
895							above messages.
896
897							=item C<FAILED--Further testing stopped: %s>
898
899							If a single subtest decides that further testing will not make sense,
900							the script dies with this message.
901
902							=back
903
904							=head1 ENVIRONMENT VARIABLES THAT TEST::HARNESS SETS
905
906							Test::Harness sets these before executing the individual tests.
907
908							=over 4
909
910							=item C<HARNESS_ACTIVE>
911
912							This is set to a true value. It allows the tests to determine if they
913							are being executed through the harness or by any other means.
914
915							=item C<HARNESS_VERSION>
916
917							This is the version of Test::Harness.
918
919							=back
920
921							=head1 ENVIRONMENT VARIABLES THAT AFFECT TEST::HARNESS
922
923							=over 4
924
925							=item C<HARNESS_COLUMNS>
926
927							This value will be used for the width of the terminal. If it is not
928							set then it will default to C<COLUMNS>. If this is not set, it will
929							default to 80. Note that users of Bourne-sh based shells will need to
930							C<export COLUMNS> for this module to use that variable.
931
932							=item C<HARNESS_COMPILE_TEST>
933
934							When true it will make harness attempt to compile the test using
935							C<perlcc> before running it.
936
937							B<NOTE> This currently only works when sitting in the perl source
938							directory!
939
940							=item C<HARNESS_DEBUG>
941
942							If true, Test::Harness will print debugging information about itself as
943							it runs the tests. This is different from C<HARNESS_VERBOSE>, which prints
944							the output from the test being run. Setting C<$Test::Harness::Debug> will
945							override this, or you can use the C<-d> switch in the F<prove> utility.
946
947							=item C<HARNESS_FILELEAK_IN_DIR>
948
949							When set to the name of a directory, harness will check after each
950							test whether new files appeared in that directory, and report them as
951
952							LEAKED FILES: scr.tmp 0 my.db
953
954							If relative, directory name is with respect to the current directory at
955							the moment runtests() was called. Putting absolute path into
956							C<HARNESS_FILELEAK_IN_DIR> may give more predictable results.
957
958							=item C<HARNESS_NOTTY>
959
960							When set to a true value, forces it to behave as though STDOUT were
961							not a console. You may need to set this if you don't want harness to
962							output more frequent progress messages using carriage returns. Some
963							consoles may not handle carriage returns properly (which results in a
964							somewhat messy output).
965
966							=item C<HARNESS_PERL>
967
968							Usually your tests will be run by C<$^X>, the currently-executing Perl.
969							However, you may want to have it run by a different executable, such as
970							a threading perl, or a different version.
971
972							If you're using the F<prove> utility, you can use the C<--perl> switch.
973
974							=item C<HARNESS_PERL_SWITCHES>
975
976							Its value will be prepended to the switches used to invoke perl on
977							each test. For example, setting C<HARNESS_PERL_SWITCHES> to C<-W> will
978							run all tests with all warnings enabled.
979
980							=item C<HARNESS_TIMER>
981
982							Setting this to true will make the harness display the number of
983							milliseconds each test took. You can also use F<prove>'s C<--timer>
984							switch.
985
986							=item C<HARNESS_VERBOSE>
987
988							If true, Test::Harness will output the verbose results of running
989							its tests. Setting C<$Test::Harness::verbose> will override this,
990							or you can use the C<-v> switch in the F<prove> utility.
991
992							=back
993
994							=head1 EXAMPLE
995
996							Here's how Test::Harness tests itself
997
998							$ cd ~/src/devel/Test-Harness
999							$ perl -Mblib -e 'use Test::Harness qw(&runtests $verbose);
1000							$verbose=0; runtests @ARGV;' t/*.t
1001							Using /home/schwern/src/devel/Test-Harness/blib
1002							t/base..............ok
1003							t/nonumbers.........ok
1004							t/ok................ok
1005							t/test-harness......ok
1006							All tests successful.
1007							Files=4, Tests=24, 2 wallclock secs ( 0.61 cusr + 0.41 csys = 1.02 CPU)
1008
1009							=head1 SEE ALSO
1010
1011							The included F<prove> utility for running test scripts from the command line,
1012							L<Test> and L<Test::Simple> for writing test scripts, L<Benchmark> for
1013							the underlying timing routines, and L<Devel::Cover> for test coverage
1014							analysis.
1015
1016							=head1 TODO
1017
1018							Provide a way of running tests quietly (ie. no printing) for automated
1019							validation of tests. This will probably take the form of a version
1020							of runtests() which rather than printing its output returns raw data
1021							on the state of the tests. (Partially done in Test::Harness::Straps)
1022
1023							Document the format.
1024
1025							Fix HARNESS_COMPILE_TEST without breaking its core usage.
1026
1027							Figure a way to report test names in the failure summary.
1028
1029							Rework the test summary so long test names are not truncated as badly.
1030							(Partially done with new skip test styles)
1031
1032							Add option for coverage analysis.
1033
1034							Trap STDERR.
1035
1036							Implement Straps total_results()
1037
1038							Remember exit code
1039
1040							Completely redo the print summary code.
1041
1042							Implement Straps callbacks. (experimentally implemented)
1043
1044							Straps->analyze_file() not taint clean, don't know if it can be
1045
1046							Fix that damned VMS nit.
1047
1048							Add a test for verbose.
1049
1050							Change internal list of test results to a hash.
1051
1052							Fix stats display when there's an overrun.
1053
1054							Fix so perls with spaces in the filename work.
1055
1056							Keeping whittling away at _run_all_tests()
1057
1058							Clean up how the summary is printed. Get rid of those damned formats.
1059
1060							=head1 BUGS
1061
1062							Please report any bugs or feature requests to
1063							C<bug-test-harness at rt.cpan.org>, or through the web interface at
1064							L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>.
1065							I will be notified, and then you'll automatically be notified of progress on
1066							your bug as I make changes.
1067
1068							=head1 SUPPORT
1069
1070							You can find documentation for this module with the F<perldoc> command.
1071
1072							perldoc Test::Harness
1073
1074							You can get docs for F<prove> with
1075
1076							prove --man
1077
1078							You can also look for information at:
1079
1080							=over 4
1081
1082							=item * AnnoCPAN: Annotated CPAN documentation
1083
1084							L<http://annocpan.org/dist/Test-Harness>
1085
1086							=item * CPAN Ratings
1087
1088							L<http://cpanratings.perl.org/d/Test-Harness>
1089
1090							=item * RT: CPAN's request tracker
1091
1092							L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Harness>
1093
1094							=item * Search CPAN
1095
1096							L<http://search.cpan.org/dist/Test-Harness>
1097
1098							=back
1099
1100							=head1 SOURCE CODE
1101
1102							The source code repository for Test::Harness is at
1103							L<http://svn.perl.org/modules/Test-Harness>.
1104
1105							=head1 AUTHORS
1106
1107							Either Tim Bunce or Andreas Koenig, we don't know. What we know for
1108							sure is, that it was inspired by Larry Wall's F<TEST> script that came
1109							with perl distributions for ages. Numerous anonymous contributors
1110							exist. Andreas Koenig held the torch for many years, and then
1111							Michael G Schwern.
1112
1113							Current maintainer is Andy Lester C<< <andy at petdance.com> >>.
1114
1115							=head1 COPYRIGHT
1116
1117							Copyright 2002-2006
1118							by Michael G Schwern C<< <schwern at pobox.com> >>,
1119							Andy Lester C<< <andy at petdance.com> >>.
1120
1121							This program is free software; you can redistribute it and/or
1122							modify it under the same terms as Perl itself.
1123
1124							See L<http://www.perl.com/perl/misc/Artistic.html>.
1125
1126							=cut
1127