4 if ( $ENV{PERL_CORE} ) {
6 @INC = ( '../lib', 'lib' );
20 my $HARNESS = 'TAP::Harness';
22 my $source_tests = $ENV{PERL_CORE} ? 'lib/source_tests' : 't/source_tests';
23 my $sample_tests = $ENV{PERL_CORE} ? 'lib/sample-tests' : 't/sample-tests';
27 # note that this test will always pass when run through 'prove'
28 ok $ENV{HARNESS_ACTIVE}, 'HARNESS_ACTIVE env variable should be set';
29 ok $ENV{HARNESS_VERSION}, 'HARNESS_VERSION env variable should be set';
31 #### For color tests ####
35 sub new { bless {}, shift }
39 my ( $self, $output, $color ) = @_;
40 $output->("[[$color]]");
47 $harness->formatter->_colorizer( Colorizer->new );
50 can_ok $HARNESS, 'new';
52 eval { $HARNESS->new( { no_such_key => 1 } ) };
53 like $@, qr/\QUnknown arguments to TAP::Harness::new (no_such_key)/,
54 '... and calling it with bad keys should fail';
56 eval { $HARNESS->new( { lib => 'aint_no_such_lib' } ) };
57 is $@, '', '... and calling it with a non-existent lib is fine';
59 eval { $HARNESS->new( { lib => [qw/bad_lib_1 bad_lib_2/] } ) };
60 is $@, '', '... and calling it with non-existent libs is fine';
62 ok my $harness = $HARNESS->new,
63 'Calling new() without arguments should succeed';
65 foreach my $test_args ( get_arg_sets() ) {
66 my %args = %$test_args;
67 foreach my $key ( sort keys %args ) {
68 $args{$key} = $args{$key}{in};
70 ok my $harness = $HARNESS->new( {%args} ),
71 'Calling new() with valid arguments should succeed';
72 isa_ok $harness, $HARNESS, '... and the object it returns';
74 while ( my ( $property, $test ) = each %$test_args ) {
75 my $value = $test->{out};
76 can_ok $harness, $property;
77 is_deeply scalar $harness->$property(), $value, $test->{test_name};
84 local *TAP::Formatter::Console::_should_show_count = sub {0};
85 local *TAP::Formatter::Console::_output = sub {
87 push @output => grep { $_ ne '' }
94 my $harness = TAP::Harness->new( { verbosity => 1 } );
95 my $harness_whisper = TAP::Harness->new( { verbosity => -1 } );
96 my $harness_mute = TAP::Harness->new( { verbosity => -2 } );
97 my $harness_directives = TAP::Harness->new( { directives => 1 } );
98 my $harness_failures = TAP::Harness->new( { failures => 1 } );
102 can_ok $harness, 'runtests';
104 # normal tests in verbose mode
106 ok my $aggregate = _runtests( $harness, "$source_tests/harness" ),
107 '... runtests returns the aggregate';
109 isa_ok $aggregate, 'TAP::Parser::Aggregator';
114 "$source_tests/harness....",
117 'ok 1 - this is a test',
120 'All tests successful.',
122 my $status = pop @output;
123 my $expected_status = qr{^Result: PASS$};
124 my $summary = pop @output;
125 my $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs};
127 is_deeply \@output, \@expected, '... and the output should be correct';
128 like $status, $expected_status,
129 '... and the status line should be correct';
130 like $summary, $expected_summary,
131 '... and the report summary should look correct';
133 # use an alias for test name
137 = _runtests( $harness, [ "$source_tests/harness", 'My Nice Test' ] ),
138 '... runtests returns the aggregate';
140 isa_ok $aggregate, 'TAP::Parser::Aggregator';
148 'ok 1 - this is a test',
151 'All tests successful.',
153 $status = pop @output;
154 $expected_status = qr{^Result: PASS$};
155 $summary = pop @output;
156 $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs};
158 is_deeply \@output, \@expected, '... and the output should be correct';
159 like $status, $expected_status,
160 '... and the status line should be correct';
161 like $summary, $expected_summary,
162 '... and the report summary should look correct';
164 # run same test twice
167 ok $aggregate = _runtests(
168 $harness, [ "$source_tests/harness", 'My Nice Test' ],
169 [ "$source_tests/harness", 'My Nice Test Again' ]
171 '... runtests returns the aggregate';
173 isa_ok $aggregate, 'TAP::Parser::Aggregator';
178 'My Nice Test..........',
181 'ok 1 - this is a test',
184 'My Nice Test Again....',
187 'ok 1 - this is a test',
190 'All tests successful.',
192 $status = pop @output;
193 $expected_status = qr{^Result: PASS$};
194 $summary = pop @output;
195 $expected_summary = qr{^Files=2, Tests=2, \d+ wallclock secs};
197 is_deeply \@output, \@expected, '... and the output should be correct';
198 like $status, $expected_status,
199 '... and the status line should be correct';
200 like $summary, $expected_summary,
201 '... and the report summary should look correct';
203 # normal tests in quiet mode
206 _runtests( $harness_whisper, "$source_tests/harness" );
210 "$source_tests/harness....",
212 'All tests successful.',
215 $status = pop @output;
216 $expected_status = qr{^Result: PASS$};
217 $summary = pop @output;
218 $expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/;
220 is_deeply \@output, \@expected, '... and the output should be correct';
221 like $status, $expected_status,
222 '... and the status line should be correct';
223 like $summary, $expected_summary,
224 '... and the report summary should look correct';
226 # normal tests in really_quiet mode
229 _runtests( $harness_mute, "$source_tests/harness" );
233 'All tests successful.',
236 $status = pop @output;
237 $expected_status = qr{^Result: PASS$};
238 $summary = pop @output;
239 $expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/;
241 is_deeply \@output, \@expected, '... and the output should be correct';
242 like $status, $expected_status,
243 '... and the status line should be correct';
244 like $summary, $expected_summary,
245 '... and the report summary should look correct';
247 # normal tests with failures
250 _runtests( $harness, "$source_tests/harness_failure" );
252 $status = pop @output;
253 $summary = pop @output;
255 like $status, qr{^Result: FAIL$},
256 '... and the status line should be correct';
258 my @summary = @output[ 10 .. $#output ];
259 @output = @output[ 0 .. 9 ];
262 "$source_tests/harness_failure....",
265 'ok 1 - this is a test',
268 'not ok 2 - this is another test',
271 'Failed 1/2 subtests',
274 is_deeply \@output, \@expected,
275 '... and failing test output should be correct';
277 my @expected_summary = (
279 'Test Summary Report',
280 '-------------------',
282 "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)",
292 is_deeply \@summary, \@expected_summary,
293 '... and the failure summary should also be correct';
295 # quiet tests with failures
298 _runtests( $harness_whisper, "$source_tests/harness_failure" );
300 $status = pop @output;
301 $summary = pop @output;
303 "$source_tests/harness_failure....",
304 'Failed 1/2 subtests',
305 'Test Summary Report',
306 '-------------------',
307 "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)",
312 like $status, qr{^Result: FAIL$},
313 '... and the status line should be correct';
315 is_deeply \@output, \@expected,
316 '... and failing test output should be correct';
318 # really quiet tests with failures
321 _runtests( $harness_mute, "$source_tests/harness_failure" );
323 $status = pop @output;
324 $summary = pop @output;
326 'Test Summary Report',
327 '-------------------',
328 "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)",
333 like $status, qr{^Result: FAIL$},
334 '... and the status line should be correct';
336 is_deeply \@output, \@expected,
337 '... and failing test output should be correct';
339 # only show directives
344 "$source_tests/harness_directives"
350 "$source_tests/harness_directives....",
351 'not ok 2 - we have a something # TODO some output',
352 "ok 3 houston, we don't have liftoff # SKIP no funding",
354 'All tests successful.',
356 # ~TODO {{{ this should be an option
357 #'Test Summary Report',
358 #'-------------------',
359 #"$source_tests/harness_directives (Wstat: 0 Tests: 3 Failed: 0)",
365 $status = pop @output;
366 $summary = pop @output;
367 $expected_summary = qr/^Files=1, Tests=3, \d+ wallclock secs/;
369 is_deeply \@output, \@expected, '... and the output should be correct';
370 like $summary, $expected_summary,
371 '... and the report summary should look correct';
373 like $status, qr{^Result: PASS$},
374 '... and the status line should be correct';
376 # normal tests with bad tap
378 # install callback handler
380 my $callback_count = 0;
382 my @callback_log = ();
384 for my $evt (qw(parser_args made_parser before_runtests after_runtests)) {
387 push @callback_log, $evt;
400 _runtests( $harness, "$source_tests/harness_badtap" );
403 @output = map { trim($_) } @output;
404 $status = pop @output;
405 @summary = @output[ 12 .. ( $#output - 1 ) ];
406 @output = @output[ 0 .. 11 ];
408 "$source_tests/harness_badtap....",
411 'ok 1 - this is a test',
414 'not ok 2 - this is another test',
419 'Failed 1/2 subtests',
421 is_deeply \@output, \@expected,
422 '... and failing test output should be correct';
423 like $status, qr{^Result: FAIL$},
424 '... and the status line should be correct';
425 @expected_summary = (
427 'Test Summary Report',
428 '-------------------',
430 "$source_tests/harness_badtap (Wstat: 0 Tests: 2 Failed: 1)",
439 'Parse errors: More than one plan found in TAP output',
442 is_deeply \@summary, \@expected_summary,
443 '... and the badtap summary should also be correct';
445 cmp_ok( $callback_count, '==', 1, 'callback called once' );
448 [ 'before_runtests', 'parser_args', 'made_parser', 'after_runtests' ],
449 'callback log matches'
451 isa_ok $parser, 'TAP::Parser';
453 # coverage testing for _should_show_failures
457 _runtests( $harness_failures, "$source_tests/harness_failure" );
462 "$source_tests/harness_failure....",
463 'not ok 2 - this is another test',
464 'Failed 1/2 subtests',
465 'Test Summary Report',
466 '-------------------',
467 "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)",
472 $status = pop @output;
473 $summary = pop @output;
475 like $status, qr{^Result: FAIL$},
476 '... and the status line should be correct';
477 $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/;
478 is_deeply \@output, \@expected, '... and the output should be correct';
480 # check the status output for no tests
483 _runtests( $harness_failures, "$sample_tests/no_output" );
488 "$sample_tests/no_output....",
490 'Test Summary Report',
491 '-------------------',
492 "$sample_tests/no_output (Wstat: 0 Tests: 0 Failed: 0)",
493 'Parse errors: No plan found in TAP output',
496 $status = pop @output;
497 $summary = pop @output;
499 like $status, qr{^Result: FAIL$},
500 '... and the status line should be correct';
501 $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/;
502 is_deeply \@output, \@expected, '... and the output should be correct';
507 # make sure we can exec something ... anything!
510 my $cat = '/bin/cat';
515 my $capture = IO::c55Capture->new_handle;
516 my $harness = TAP::Harness->new(
526 $ENV{PERL_CORE} ? 'lib/data/catme.1' : 't/data/catme.1'
530 my @output = tied($$capture)->dump;
531 my $status = pop @output;
532 like $status, qr{^Result: PASS$},
533 '... and the status line should be correct';
534 pop @output; # get rid of summary line
535 my $answer = pop @output;
536 is( $answer, "All tests successful.\n", 'cat meows' );
539 # make sure that we can exec with a code ref.
541 my $capture = IO::c55Capture->new_handle;
542 my $harness = TAP::Harness->new(
549 _runtests( $harness, "$source_tests/harness" );
551 my @output = tied($$capture)->dump;
552 my $status = pop @output;
553 like $status, qr{^Result: PASS$},
554 '... and the status line should be correct';
555 pop @output; # get rid of summary line
556 my $answer = pop @output;
557 is( $answer, "All tests successful.\n", 'cat meows' );
560 # catches "exec accumulates arguments" issue (r77)
562 my $capture = IO::c55Capture->new_handle;
563 my $harness = TAP::Harness->new(
572 "$source_tests/harness_complain"
573 , # will get mad if run with args
574 "$source_tests/harness",
577 my @output = tied($$capture)->dump;
578 my $status = pop @output;
579 like $status, qr{^Result: PASS$},
580 '... and the status line should be correct';
581 pop @output; # get rid of summary line
582 is( $output[-1], "All tests successful.\n",
583 'No exec accumulation'
588 $_[0] =~ s/^\s+|\s+$//g;
593 return [ map {"-I$_"} @_ ];
598 # keys are keys to new()
602 out => liblist('lib'),
603 test_name => '... a single lib switch should be correct'
608 test_name => '... and we should be able to set verbosity to 1'
614 # test_name => '... and we should be able to set verbose to true'
618 in => [ 'lib', 't' ],
619 out => liblist( 'lib', 't' ),
620 test_name => '... multiple lib dirs should be correct'
625 test_name => '... and we should be able to set verbosity to 0'
631 # test_name => '... and we should be able to set verbose to false'
635 in => [ '-T', '-w', '-T' ],
636 out => [ '-T', '-w', '-T' ],
637 test_name => '... duplicate switches should remain',
643 '... and we should be able to set failures to true',
648 test_name => '... and we should be able to set verbosity to -1'
654 # test_name => '... and we should be able to set quiet to false'
661 test_name => '... and we should be able to set verbosity to -2'
668 # '... and we should be able to set really_quiet to true',
674 '... and we should be able to set the executable',
681 '... leading dashes (-) on switches are not optional',
687 test_name => '... we should be able to set switches',
692 test_name => '... and we should be able to set failures to true'
698 my ( $harness, @tests ) = @_;
699 local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0;
700 my $aggregate = $harness->runtests(@tests);
706 # coverage tests for ctor
708 my $harness = TAP::Harness->new(
717 is $harness->timer(), 0, 'timer getter';
718 is $harness->timer(10), 10, 'timer setter';
719 is $harness->errors(), 1, 'errors getter';
720 is $harness->errors(10), 10, 'errors setter';
721 is $harness->merge(), 2, 'merge getter';
722 is $harness->merge(10), 10, 'merge setter';
725 is $harness->jobs(), 1, 'jobs';
730 # coverage tests for the stdout key of VALIDATON_FOR, used by _initialize() in the ctor
732 # the coverage tests are
733 # 1. ref $ref => false
734 # 2. ref => ! GLOB and ref->can(print)
735 # 3. ref $ref => GLOB
742 local $SIG{__DIE__} = sub { push @die, @_ };
744 my $harness = TAP::Harness->new(
745 { stdout => bless {}, '0', # how evil is THAT !!!
750 is @die, 1, 'bad filehandle to stdout';
751 like pop @die, qr/option 'stdout' needs a filehandle/,
752 '... and we died as expected';
760 sub new { return bless {}, shift }
766 my $harness = TAP::Harness->new(
767 { stdout => Printable->new(),
771 isa_ok $harness, 'TAP::Harness';
777 $harness = TAP::Harness->new(
778 { stdout => bless {}, 'GLOB', # again with the evil
782 isa_ok $harness, 'TAP::Harness';
787 # coverage testing of lib/switches accessor
788 my $harness = TAP::Harness->new;
793 local $SIG{__DIE__} = sub { push @die, @_ };
795 $harness->switches(qw( too many arguments));
798 is @die, 1, 'too many arguments to accessor';
800 like pop @die, qr/Too many arguments to method 'switches'/,
801 '...and we died as expected';
803 $harness->switches('simple scalar');
805 my $arrref = $harness->switches;
806 is_deeply $arrref, ['simple scalar'], 'scalar wrapped in arr ref';
811 # coverage tests for the basically untested T::H::_open_spool
813 my @spool = ( $ENV{PERL_CORE} ? ('spool') : ( 't', 'spool' ) );
814 $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(@spool);
816 # now given that we're going to be writing stuff to the file system, make sure we have
822 # remove the tree if we made it this far
823 rmtree( $ENV{PERL_TEST_HARNESS_DUMP_TAP} )
824 if $ENV{PERL_TEST_HARNESS_DUMP_TAP};
827 my $harness = TAP::Harness->new( { verbosity => -2 } );
829 can_ok $harness, 'runtests';
831 # normal tests in verbose mode
834 = $harness->runtests( File::Spec->catfile( $source_tests, 'harness' ) );
836 isa_ok $parser, 'TAP::Parser::Aggregator',
837 '... runtests returns the aggregate';
839 ok -e File::Spec->catfile(
840 $ENV{PERL_TEST_HARNESS_DUMP_TAP},
841 $source_tests, 'harness'
849 { name => 'all the same',
850 input => [ 'foo.t', 'bar.t', 'fletz.t' ],
852 [ 'foo.t', 'foo' ], [ 'bar.t', 'bar' ], [ 'fletz.t', 'fletz' ]
855 { name => 'all the same, already cooked',
856 input => [ 'foo.t', [ 'bar.t', 'brip' ], 'fletz.t' ],
858 [ 'foo.t', 'foo' ], [ 'bar.t', 'brip' ],
859 [ 'fletz.t', 'fletz' ]
862 { name => 'different exts',
863 input => [ 'foo.t', 'bar.u', 'fletz.v' ],
865 [ 'foo.t', 'foo.t' ], [ 'bar.u', 'bar.u' ],
866 [ 'fletz.v', 'fletz.v' ]
869 { name => 'different exts, one already cooked',
870 input => [ 'foo.t', [ 'bar.u', 'bam' ], 'fletz.v' ],
872 [ 'foo.t', 'foo.t' ], [ 'bar.u', 'bam' ],
873 [ 'fletz.v', 'fletz.v' ]
876 { name => 'different exts, two already cooked',
877 input => [ 'foo.t', [ 'bar.u', 'bam.q' ], [ 'fletz.v', 'boo' ] ],
879 [ 'foo.t', 'foo.t' ], [ 'bar.u', 'bam.q' ],
885 for my $case (@cases) {
886 is_deeply [ TAP::Harness->_add_descriptions( @{ $case->{input} } ) ],
887 $case->{output}, '_add_descriptions: ' . $case->{name};