4 if( $ENV{PERL_CORE} ) {
6 @INC = ('../lib', 'lib');
14 if ($ENV{PERL_CORE}) {
16 print "1..0 # Skip pending resolution of a clean way to record the change in location of the sample tests\n";
28 my $HARNESS = 'TAP::Harness';
32 # note that this test will always pass when run through 'prove'
33 ok $ENV{HARNESS_ACTIVE}, 'HARNESS_ACTIVE env variable should be set';
34 ok $ENV{HARNESS_VERSION}, 'HARNESS_VERSION env variable should be set';
36 #### For color tests ####
40 sub new { bless {}, shift }
44 my ( $self, $output, $color ) = @_;
45 $output->("[[$color]]");
52 $harness->formatter->_colorizer( Colorizer->new );
55 can_ok $HARNESS, 'new';
57 eval { $HARNESS->new( { no_such_key => 1 } ) };
58 like $@, qr/\QUnknown arguments to TAP::Harness::new (no_such_key)/,
59 '... and calling it with bad keys should fail';
61 eval { $HARNESS->new( { lib => 'aint_no_such_lib' } ) };
62 is $@, '', '... and calling it with a non-existent lib is fine';
64 eval { $HARNESS->new( { lib => [qw/bad_lib_1 bad_lib_2/] } ) };
65 is $@, '', '... and calling it with non-existent libs is fine';
67 ok my $harness = $HARNESS->new,
68 'Calling new() without arguments should succeed';
70 foreach my $test_args ( get_arg_sets() ) {
71 my %args = %$test_args;
72 foreach my $key ( sort keys %args ) {
73 $args{$key} = $args{$key}{in};
75 ok my $harness = $HARNESS->new( {%args} ),
76 'Calling new() with valid arguments should succeed';
77 isa_ok $harness, $HARNESS, '... and the object it returns';
79 while ( my ( $property, $test ) = each %$test_args ) {
80 my $value = $test->{out};
81 can_ok $harness, $property;
82 is_deeply scalar $harness->$property(), $value, $test->{test_name};
89 local *TAP::Formatter::Console::_should_show_count = sub {0};
90 local *TAP::Formatter::Console::_output = sub {
92 push @output => grep { $_ ne '' }
99 my $harness = TAP::Harness->new( { verbosity => 1 } );
100 my $harness_whisper = TAP::Harness->new( { verbosity => -1 } );
101 my $harness_mute = TAP::Harness->new( { verbosity => -2 } );
102 my $harness_directives = TAP::Harness->new( { directives => 1 } );
103 my $harness_failures = TAP::Harness->new( { failures => 1 } );
107 can_ok $harness, 'runtests';
109 # normal tests in verbose mode
111 ok my $aggregate = _runtests( $harness, 't/source_tests/harness' ),
112 '... runtests returns the aggregate';
114 isa_ok $aggregate, 'TAP::Parser::Aggregator';
119 't/source_tests/harness....',
122 'ok 1 - this is a test',
125 'All tests successful.',
127 my $status = pop @output;
128 my $expected_status = qr{^Result: PASS$};
129 my $summary = pop @output;
130 my $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs};
132 is_deeply \@output, \@expected, '... and the output should be correct';
133 like $status, $expected_status,
134 '... and the status line should be correct';
135 like $summary, $expected_summary,
136 '... and the report summary should look correct';
138 # use an alias for test name
142 = _runtests( $harness, [ 't/source_tests/harness', 'My Nice Test' ] ),
143 '... runtests returns the aggregate';
145 isa_ok $aggregate, 'TAP::Parser::Aggregator';
153 'ok 1 - this is a test',
156 'All tests successful.',
158 $status = pop @output;
159 $expected_status = qr{^Result: PASS$};
160 $summary = pop @output;
161 $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs};
163 is_deeply \@output, \@expected, '... and the output should be correct';
164 like $status, $expected_status,
165 '... and the status line should be correct';
166 like $summary, $expected_summary,
167 '... and the report summary should look correct';
169 # run same test twice
173 = _runtests( $harness, [ 't/source_tests/harness', 'My Nice Test' ],
174 [ 't/source_tests/harness', 'My Nice Test Again' ] ),
175 '... runtests returns the aggregate';
177 isa_ok $aggregate, 'TAP::Parser::Aggregator';
182 'My Nice Test..........',
185 'ok 1 - this is a test',
188 'My Nice Test Again....',
191 'ok 1 - this is a test',
194 'All tests successful.',
196 $status = pop @output;
197 $expected_status = qr{^Result: PASS$};
198 $summary = pop @output;
199 $expected_summary = qr{^Files=2, Tests=2, \d+ wallclock secs};
201 is_deeply \@output, \@expected, '... and the output should be correct';
202 like $status, $expected_status,
203 '... and the status line should be correct';
204 like $summary, $expected_summary,
205 '... and the report summary should look correct';
207 # normal tests in quiet mode
210 _runtests( $harness_whisper, 't/source_tests/harness' );
214 't/source_tests/harness....',
216 'All tests successful.',
219 $status = pop @output;
220 $expected_status = qr{^Result: PASS$};
221 $summary = pop @output;
222 $expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/;
224 is_deeply \@output, \@expected, '... and the output should be correct';
225 like $status, $expected_status,
226 '... and the status line should be correct';
227 like $summary, $expected_summary,
228 '... and the report summary should look correct';
230 # normal tests in really_quiet mode
233 _runtests( $harness_mute, 't/source_tests/harness' );
237 'All tests successful.',
240 $status = pop @output;
241 $expected_status = qr{^Result: PASS$};
242 $summary = pop @output;
243 $expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/;
245 is_deeply \@output, \@expected, '... and the output should be correct';
246 like $status, $expected_status,
247 '... and the status line should be correct';
248 like $summary, $expected_summary,
249 '... and the report summary should look correct';
251 # normal tests with failures
254 _runtests( $harness, 't/source_tests/harness_failure' );
256 $status = pop @output;
257 $summary = pop @output;
259 like $status, qr{^Result: FAIL$},
260 '... and the status line should be correct';
262 my @summary = @output[ 10 .. $#output ];
263 @output = @output[ 0 .. 9 ];
266 't/source_tests/harness_failure....',
269 'ok 1 - this is a test',
272 'not ok 2 - this is another test',
275 'Failed 1/2 subtests',
278 is_deeply \@output, \@expected,
279 '... and failing test output should be correct';
281 my @expected_summary = (
283 'Test Summary Report',
284 '-------------------',
286 't/source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)',
296 is_deeply \@summary, \@expected_summary,
297 '... and the failure summary should also be correct';
299 # quiet tests with failures
302 _runtests( $harness_whisper, 't/source_tests/harness_failure' );
304 $status = pop @output;
305 $summary = pop @output;
307 't/source_tests/harness_failure....',
308 'Failed 1/2 subtests',
309 'Test Summary Report',
310 '-------------------',
311 't/source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)',
316 like $status, qr{^Result: FAIL$},
317 '... and the status line should be correct';
319 is_deeply \@output, \@expected,
320 '... and failing test output should be correct';
322 # really quiet tests with failures
325 _runtests( $harness_mute, 't/source_tests/harness_failure' );
327 $status = pop @output;
328 $summary = pop @output;
330 'Test Summary Report',
331 '-------------------',
332 't/source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)',
337 like $status, qr{^Result: FAIL$},
338 '... and the status line should be correct';
340 is_deeply \@output, \@expected,
341 '... and failing test output should be correct';
343 # only show directives
348 't/source_tests/harness_directives'
354 't/source_tests/harness_directives....',
355 'not ok 2 - we have a something # TODO some output',
356 "ok 3 houston, we don't have liftoff # SKIP no funding",
358 'All tests successful.',
360 # ~TODO {{{ this should be an option
361 #'Test Summary Report',
362 #'-------------------',
363 #'t/source_tests/harness_directives (Wstat: 0 Tests: 3 Failed: 0)',
369 $status = pop @output;
370 $summary = pop @output;
371 $expected_summary = qr/^Files=1, Tests=3, \d+ wallclock secs/;
373 is_deeply \@output, \@expected, '... and the output should be correct';
374 like $summary, $expected_summary,
375 '... and the report summary should look correct';
377 like $status, qr{^Result: PASS$},
378 '... and the status line should be correct';
380 # normal tests with bad tap
382 # install callback handler
384 my $callback_count = 0;
386 my @callback_log = ();
388 for my $evt (qw(parser_args made_parser before_runtests after_runtests)) {
391 push @callback_log, $evt;
404 _runtests( $harness, 't/source_tests/harness_badtap' );
407 @output = map { trim($_) } @output;
408 $status = pop @output;
409 @summary = @output[ 12 .. ( $#output - 1 ) ];
410 @output = @output[ 0 .. 11 ];
412 't/source_tests/harness_badtap....',
415 'ok 1 - this is a test',
418 'not ok 2 - this is another test',
423 'Failed 1/2 subtests',
425 is_deeply \@output, \@expected,
426 '... and failing test output should be correct';
427 like $status, qr{^Result: FAIL$},
428 '... and the status line should be correct';
429 @expected_summary = (
431 'Test Summary Report',
432 '-------------------',
434 't/source_tests/harness_badtap (Wstat: 0 Tests: 2 Failed: 1)',
443 'Parse errors: More than one plan found in TAP output',
446 is_deeply \@summary, \@expected_summary,
447 '... and the badtap summary should also be correct';
449 cmp_ok( $callback_count, '==', 1, 'callback called once' );
452 [ 'before_runtests', 'parser_args', 'made_parser', 'after_runtests' ],
453 'callback log matches'
455 isa_ok $parser, 'TAP::Parser';
457 # coverage testing for _should_show_failures
461 _runtests( $harness_failures, 't/source_tests/harness_failure' );
466 't/source_tests/harness_failure....',
467 'not ok 2 - this is another test',
468 'Failed 1/2 subtests',
469 'Test Summary Report',
470 '-------------------',
471 't/source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)',
476 $status = pop @output;
477 $summary = pop @output;
479 like $status, qr{^Result: FAIL$},
480 '... and the status line should be correct';
481 $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/;
482 is_deeply \@output, \@expected, '... and the output should be correct';
484 # check the status output for no tests
487 _runtests( $harness_failures, 't/sample-tests/no_output' );
492 't/sample-tests/no_output....',
494 'Test Summary Report',
495 '-------------------',
496 't/sample-tests/no_output (Wstat: 0 Tests: 0 Failed: 0)',
497 'Parse errors: No plan found in TAP output',
500 $status = pop @output;
501 $summary = pop @output;
503 like $status, qr{^Result: FAIL$},
504 '... and the status line should be correct';
505 $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/;
506 is_deeply \@output, \@expected, '... and the output should be correct';
511 # make sure we can exec something ... anything!
514 my $cat = '/bin/cat';
519 my $capture = IO::c55Capture->new_handle;
520 my $harness = TAP::Harness->new(
527 eval { _runtests( $harness, 't/data/catme.1' ) };
529 my @output = tied($$capture)->dump;
530 my $status = pop @output;
531 like $status, qr{^Result: PASS$},
532 '... and the status line should be correct';
533 pop @output; # get rid of summary line
534 my $answer = pop @output;
535 is( $answer, "All tests successful.\n", 'cat meows' );
538 # catches "exec accumulates arguments" issue (r77)
540 my $capture = IO::c55Capture->new_handle;
541 my $harness = TAP::Harness->new(
550 't/source_tests/harness_complain'
551 , # will get mad if run with args
552 't/source_tests/harness',
555 my @output = tied($$capture)->dump;
556 my $status = pop @output;
557 like $status, qr{^Result: PASS$},
558 '... and the status line should be correct';
559 pop @output; # get rid of summary line
560 is( $output[-1], "All tests successful.\n",
561 'No exec accumulation'
566 $_[0] =~ s/^\s+|\s+$//g;
571 return [ map {"-I$_"} @_ ];
576 # keys are keys to new()
580 out => liblist('lib'),
581 test_name => '... a single lib switch should be correct'
586 test_name => '... and we should be able to set verbosity to 1'
592 # test_name => '... and we should be able to set verbose to true'
596 in => [ 'lib', 't' ],
597 out => liblist( 'lib', 't' ),
598 test_name => '... multiple lib dirs should be correct'
603 test_name => '... and we should be able to set verbosity to 0'
609 # test_name => '... and we should be able to set verbose to false'
613 in => [ '-T', '-w', '-T' ],
614 out => [ '-T', '-w', '-T' ],
615 test_name => '... duplicate switches should remain',
621 '... and we should be able to set failures to true',
626 test_name => '... and we should be able to set verbosity to -1'
632 # test_name => '... and we should be able to set quiet to false'
639 test_name => '... and we should be able to set verbosity to -2'
646 # '... and we should be able to set really_quiet to true',
652 '... and we should be able to set the executable',
659 '... leading dashes (-) on switches are not optional',
665 test_name => '... we should be able to set switches',
670 test_name => '... and we should be able to set failures to true'
676 my ( $harness, @tests ) = @_;
677 local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0;
678 my $aggregate = $harness->runtests(@tests);
684 # coverage tests for ctor
686 my $harness = TAP::Harness->new(
695 is $harness->timer(), 0, 'timer getter';
696 is $harness->timer(10), 10, 'timer setter';
697 is $harness->errors(), 1, 'errors getter';
698 is $harness->errors(10), 10, 'errors setter';
699 is $harness->merge(), 2, 'merge getter';
700 is $harness->merge(10), 10, 'merge setter';
703 is $harness->jobs(), 1, 'jobs';
708 # coverage tests for the stdout key of VALIDATON_FOR, used by _initialize() in the ctor
710 # the coverage tests are
711 # 1. ref $ref => false
712 # 2. ref => ! GLOB and ref->can(print)
713 # 3. ref $ref => GLOB
720 local $SIG{__DIE__} = sub { push @die, @_ };
722 my $harness = TAP::Harness->new(
723 { stdout => bless {}, '0', # how evil is THAT !!!
728 is @die, 1, 'bad filehandle to stdout';
729 like pop @die, qr/option 'stdout' needs a filehandle/,
730 '... and we died as expected';
738 sub new { return bless {}, shift }
744 my $harness = TAP::Harness->new(
745 { stdout => Printable->new(),
749 isa_ok $harness, 'TAP::Harness';
755 $harness = TAP::Harness->new(
756 { stdout => bless {}, 'GLOB', # again with the evil
760 isa_ok $harness, 'TAP::Harness';
765 # coverage testing of lib/switches accessor
766 my $harness = TAP::Harness->new;
771 local $SIG{__DIE__} = sub { push @die, @_ };
773 $harness->switches(qw( too many arguments));
776 is @die, 1, 'too many arguments to accessor';
778 like pop @die, qr/Too many arguments to method 'switches'/,
779 '...and we died as expected';
781 $harness->switches('simple scalar');
783 my $arrref = $harness->switches;
784 is_deeply $arrref, ['simple scalar'], 'scalar wrapped in arr ref';
789 # coverage tests for the basically untested T::H::_open_spool
791 $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(qw(t spool));
793 # now given that we're going to be writing stuff to the file system, make sure we have
799 # remove the tree if we made it this far
800 rmtree( $ENV{PERL_TEST_HARNESS_DUMP_TAP} )
801 if $ENV{PERL_TEST_HARNESS_DUMP_TAP};
804 my $harness = TAP::Harness->new( { verbosity => -2 } );
806 can_ok $harness, 'runtests';
808 # normal tests in verbose mode
810 my $parser = $harness->runtests(
811 File::Spec->catfile(qw (t source_tests harness )) );
813 isa_ok $parser, 'TAP::Parser::Aggregator',
814 '... runtests returns the aggregate';
816 ok -e File::Spec->catfile(
817 $ENV{PERL_TEST_HARNESS_DUMP_TAP},
818 qw( t source_tests harness )