Commit | Line | Data |
b965d173 |
1 | #!/usr/bin/perl -w |
3c87ea76 |
2 | |
3 | BEGIN { |
5e2a19fc |
4 | if ( $ENV{PERL_CORE} ) { |
3c87ea76 |
5 | chdir 't'; |
f715bbfb |
6 | @INC = ( '../lib', '../ext/Test-Harness/t/lib' ); |
3c87ea76 |
7 | } |
8 | else { |
5e2a19fc |
9 | unshift @INC, 't/lib'; |
3c87ea76 |
10 | } |
11 | } |
12 | |
13 | use strict; |
14 | |
b965d173 |
15 | use Test::More; |
16 | use IO::c55Capture; |
3c87ea76 |
17 | |
b965d173 |
18 | use TAP::Harness; |
19 | |
20 | my $HARNESS = 'TAP::Harness'; |
21 | |
27fc0087 |
22 | my $source_tests |
f715bbfb |
23 | = $ENV{PERL_CORE} ? '../ext/Test-Harness/t/source_tests' : 't/source_tests'; |
27fc0087 |
24 | my $sample_tests |
f715bbfb |
25 | = $ENV{PERL_CORE} ? '../ext/Test-Harness/t/sample-tests' : 't/sample-tests'; |
5e2a19fc |
26 | |
a39e16d8 |
27 | plan tests => 119; |
b965d173 |
28 | |
29 | # note that this test will always pass when run through 'prove' |
30 | ok $ENV{HARNESS_ACTIVE}, 'HARNESS_ACTIVE env variable should be set'; |
31 | ok $ENV{HARNESS_VERSION}, 'HARNESS_VERSION env variable should be set'; |
32 | |
33 | #### For color tests #### |
34 | |
35 | package Colorizer; |
36 | |
37 | sub new { bless {}, shift } |
38 | sub can_color {1} |
39 | |
40 | sub set_color { |
41 | my ( $self, $output, $color ) = @_; |
42 | $output->("[[$color]]"); |
43 | } |
44 | |
45 | package main; |
46 | |
47 | sub colorize { |
48 | my $harness = shift; |
49 | $harness->formatter->_colorizer( Colorizer->new ); |
50 | } |
51 | |
52 | can_ok $HARNESS, 'new'; |
53 | |
54 | eval { $HARNESS->new( { no_such_key => 1 } ) }; |
55 | like $@, qr/\QUnknown arguments to TAP::Harness::new (no_such_key)/, |
56 | '... and calling it with bad keys should fail'; |
57 | |
58 | eval { $HARNESS->new( { lib => 'aint_no_such_lib' } ) }; |
59 | is $@, '', '... and calling it with a non-existent lib is fine'; |
60 | |
61 | eval { $HARNESS->new( { lib => [qw/bad_lib_1 bad_lib_2/] } ) }; |
62 | is $@, '', '... and calling it with non-existent libs is fine'; |
63 | |
64 | ok my $harness = $HARNESS->new, |
65 | 'Calling new() without arguments should succeed'; |
66 | |
67 | foreach my $test_args ( get_arg_sets() ) { |
68 | my %args = %$test_args; |
69 | foreach my $key ( sort keys %args ) { |
70 | $args{$key} = $args{$key}{in}; |
71 | } |
72 | ok my $harness = $HARNESS->new( {%args} ), |
73 | 'Calling new() with valid arguments should succeed'; |
74 | isa_ok $harness, $HARNESS, '... and the object it returns'; |
75 | |
76 | while ( my ( $property, $test ) = each %$test_args ) { |
77 | my $value = $test->{out}; |
78 | can_ok $harness, $property; |
79 | is_deeply scalar $harness->$property(), $value, $test->{test_name}; |
80 | } |
81 | } |
82 | |
83 | { |
84 | my @output; |
85 | local $^W; |
bdaf8c65 |
86 | local *TAP::Formatter::Base::_output = sub { |
b965d173 |
87 | my $self = shift; |
88 | push @output => grep { $_ ne '' } |
89 | map { |
90 | local $_ = $_; |
91 | chomp; |
92 | trim($_) |
93 | } @_; |
94 | }; |
bdaf8c65 |
95 | my $harness = TAP::Harness->new( |
96 | { verbosity => 1, formatter_class => "TAP::Formatter::Console" } ); |
97 | my $harness_whisper = TAP::Harness->new( |
98 | { verbosity => -1, formatter_class => "TAP::Formatter::Console" } ); |
99 | my $harness_mute = TAP::Harness->new( |
100 | { verbosity => -2, formatter_class => "TAP::Formatter::Console" } ); |
101 | my $harness_directives = TAP::Harness->new( |
102 | { directives => 1, formatter_class => "TAP::Formatter::Console" } ); |
103 | my $harness_failures = TAP::Harness->new( |
104 | { failures => 1, formatter_class => "TAP::Formatter::Console" } ); |
b965d173 |
105 | |
106 | colorize($harness); |
107 | |
108 | can_ok $harness, 'runtests'; |
109 | |
110 | # normal tests in verbose mode |
111 | |
5e2a19fc |
112 | ok my $aggregate = _runtests( $harness, "$source_tests/harness" ), |
b965d173 |
113 | '... runtests returns the aggregate'; |
114 | |
115 | isa_ok $aggregate, 'TAP::Parser::Aggregator'; |
116 | |
117 | chomp(@output); |
118 | |
119 | my @expected = ( |
bdaf8c65 |
120 | "$source_tests/harness ..", |
b965d173 |
121 | '1..1', |
122 | '[[reset]]', |
123 | 'ok 1 - this is a test', |
124 | '[[reset]]', |
125 | 'ok', |
a39e16d8 |
126 | '[[green]]', |
b965d173 |
127 | 'All tests successful.', |
a39e16d8 |
128 | '[[reset]]', |
b965d173 |
129 | ); |
130 | my $status = pop @output; |
131 | my $expected_status = qr{^Result: PASS$}; |
132 | my $summary = pop @output; |
133 | my $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs}; |
134 | |
135 | is_deeply \@output, \@expected, '... and the output should be correct'; |
136 | like $status, $expected_status, |
137 | '... and the status line should be correct'; |
138 | like $summary, $expected_summary, |
139 | '... and the report summary should look correct'; |
140 | |
141 | # use an alias for test name |
142 | |
143 | @output = (); |
144 | ok $aggregate |
5e2a19fc |
145 | = _runtests( $harness, [ "$source_tests/harness", 'My Nice Test' ] ), |
b965d173 |
146 | '... runtests returns the aggregate'; |
147 | |
148 | isa_ok $aggregate, 'TAP::Parser::Aggregator'; |
149 | |
150 | chomp(@output); |
151 | |
152 | @expected = ( |
bdaf8c65 |
153 | 'My Nice Test ..', |
b965d173 |
154 | '1..1', |
155 | '[[reset]]', |
156 | 'ok 1 - this is a test', |
157 | '[[reset]]', |
158 | 'ok', |
a39e16d8 |
159 | '[[green]]', |
b965d173 |
160 | 'All tests successful.', |
a39e16d8 |
161 | '[[reset]]', |
b965d173 |
162 | ); |
163 | $status = pop @output; |
164 | $expected_status = qr{^Result: PASS$}; |
165 | $summary = pop @output; |
166 | $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs}; |
167 | |
168 | is_deeply \@output, \@expected, '... and the output should be correct'; |
169 | like $status, $expected_status, |
170 | '... and the status line should be correct'; |
171 | like $summary, $expected_summary, |
172 | '... and the report summary should look correct'; |
173 | |
174 | # run same test twice |
175 | |
176 | @output = (); |
5e2a19fc |
177 | ok $aggregate = _runtests( |
178 | $harness, [ "$source_tests/harness", 'My Nice Test' ], |
179 | [ "$source_tests/harness", 'My Nice Test Again' ] |
180 | ), |
b965d173 |
181 | '... runtests returns the aggregate'; |
182 | |
183 | isa_ok $aggregate, 'TAP::Parser::Aggregator'; |
184 | |
185 | chomp(@output); |
186 | |
187 | @expected = ( |
bdaf8c65 |
188 | 'My Nice Test ........', |
b965d173 |
189 | '1..1', |
190 | '[[reset]]', |
191 | 'ok 1 - this is a test', |
192 | '[[reset]]', |
193 | 'ok', |
bdaf8c65 |
194 | 'My Nice Test Again ..', |
b965d173 |
195 | '1..1', |
196 | '[[reset]]', |
197 | 'ok 1 - this is a test', |
198 | '[[reset]]', |
199 | 'ok', |
a39e16d8 |
200 | '[[green]]', |
b965d173 |
201 | 'All tests successful.', |
a39e16d8 |
202 | '[[reset]]', |
b965d173 |
203 | ); |
204 | $status = pop @output; |
205 | $expected_status = qr{^Result: PASS$}; |
206 | $summary = pop @output; |
207 | $expected_summary = qr{^Files=2, Tests=2, \d+ wallclock secs}; |
208 | |
209 | is_deeply \@output, \@expected, '... and the output should be correct'; |
210 | like $status, $expected_status, |
211 | '... and the status line should be correct'; |
212 | like $summary, $expected_summary, |
213 | '... and the report summary should look correct'; |
214 | |
215 | # normal tests in quiet mode |
216 | |
217 | @output = (); |
5e2a19fc |
218 | _runtests( $harness_whisper, "$source_tests/harness" ); |
b965d173 |
219 | |
220 | chomp(@output); |
221 | @expected = ( |
bdaf8c65 |
222 | "$source_tests/harness ..", |
b965d173 |
223 | 'ok', |
224 | 'All tests successful.', |
225 | ); |
226 | |
227 | $status = pop @output; |
228 | $expected_status = qr{^Result: PASS$}; |
229 | $summary = pop @output; |
230 | $expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/; |
231 | |
232 | is_deeply \@output, \@expected, '... and the output should be correct'; |
233 | like $status, $expected_status, |
234 | '... and the status line should be correct'; |
235 | like $summary, $expected_summary, |
236 | '... and the report summary should look correct'; |
237 | |
238 | # normal tests in really_quiet mode |
239 | |
240 | @output = (); |
5e2a19fc |
241 | _runtests( $harness_mute, "$source_tests/harness" ); |
b965d173 |
242 | |
243 | chomp(@output); |
244 | @expected = ( |
245 | 'All tests successful.', |
246 | ); |
247 | |
248 | $status = pop @output; |
249 | $expected_status = qr{^Result: PASS$}; |
250 | $summary = pop @output; |
251 | $expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/; |
252 | |
253 | is_deeply \@output, \@expected, '... and the output should be correct'; |
254 | like $status, $expected_status, |
255 | '... and the status line should be correct'; |
256 | like $summary, $expected_summary, |
257 | '... and the report summary should look correct'; |
258 | |
259 | # normal tests with failures |
260 | |
261 | @output = (); |
5e2a19fc |
262 | _runtests( $harness, "$source_tests/harness_failure" ); |
b965d173 |
263 | |
264 | $status = pop @output; |
265 | $summary = pop @output; |
266 | |
267 | like $status, qr{^Result: FAIL$}, |
268 | '... and the status line should be correct'; |
269 | |
a39e16d8 |
270 | my @summary = @output[ 18 .. $#output ]; |
271 | @output = @output[ 0 .. 17 ]; |
b965d173 |
272 | |
273 | @expected = ( |
bdaf8c65 |
274 | "$source_tests/harness_failure ..", |
b965d173 |
275 | '1..2', |
276 | '[[reset]]', |
277 | 'ok 1 - this is a test', |
278 | '[[reset]]', |
279 | '[[red]]', |
280 | 'not ok 2 - this is another test', |
281 | '[[reset]]', |
a39e16d8 |
282 | q{# Failed test 'this is another test'}, |
283 | '[[reset]]', |
284 | '# in harness_failure.t at line 5.', |
285 | '[[reset]]', |
286 | q{# got: 'waffle'}, |
287 | '[[reset]]', |
288 | q{# expected: 'yarblokos'}, |
289 | '[[reset]]', |
b965d173 |
290 | '[[red]]', |
291 | 'Failed 1/2 subtests', |
292 | ); |
293 | |
294 | is_deeply \@output, \@expected, |
295 | '... and failing test output should be correct'; |
296 | |
297 | my @expected_summary = ( |
298 | '[[reset]]', |
299 | 'Test Summary Report', |
300 | '-------------------', |
301 | '[[red]]', |
5e2a19fc |
302 | "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", |
b965d173 |
303 | '[[reset]]', |
304 | '[[red]]', |
69f36734 |
305 | 'Failed test:', |
b965d173 |
306 | '[[reset]]', |
307 | '[[red]]', |
308 | '2', |
309 | '[[reset]]', |
310 | ); |
311 | |
312 | is_deeply \@summary, \@expected_summary, |
313 | '... and the failure summary should also be correct'; |
314 | |
315 | # quiet tests with failures |
316 | |
317 | @output = (); |
5e2a19fc |
318 | _runtests( $harness_whisper, "$source_tests/harness_failure" ); |
b965d173 |
319 | |
320 | $status = pop @output; |
321 | $summary = pop @output; |
322 | @expected = ( |
bdaf8c65 |
323 | "$source_tests/harness_failure ..", |
b965d173 |
324 | 'Failed 1/2 subtests', |
325 | 'Test Summary Report', |
326 | '-------------------', |
5e2a19fc |
327 | "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", |
69f36734 |
328 | 'Failed test:', |
b965d173 |
329 | '2', |
330 | ); |
331 | |
332 | like $status, qr{^Result: FAIL$}, |
333 | '... and the status line should be correct'; |
334 | |
335 | is_deeply \@output, \@expected, |
336 | '... and failing test output should be correct'; |
337 | |
338 | # really quiet tests with failures |
339 | |
340 | @output = (); |
5e2a19fc |
341 | _runtests( $harness_mute, "$source_tests/harness_failure" ); |
b965d173 |
342 | |
343 | $status = pop @output; |
344 | $summary = pop @output; |
345 | @expected = ( |
346 | 'Test Summary Report', |
347 | '-------------------', |
5e2a19fc |
348 | "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", |
69f36734 |
349 | 'Failed test:', |
b965d173 |
350 | '2', |
351 | ); |
352 | |
353 | like $status, qr{^Result: FAIL$}, |
354 | '... and the status line should be correct'; |
355 | |
356 | is_deeply \@output, \@expected, |
357 | '... and failing test output should be correct'; |
358 | |
359 | # only show directives |
360 | |
361 | @output = (); |
362 | _runtests( |
363 | $harness_directives, |
5e2a19fc |
364 | "$source_tests/harness_directives" |
b965d173 |
365 | ); |
366 | |
367 | chomp(@output); |
368 | |
369 | @expected = ( |
bdaf8c65 |
370 | "$source_tests/harness_directives ..", |
b965d173 |
371 | 'not ok 2 - we have a something # TODO some output', |
372 | "ok 3 houston, we don't have liftoff # SKIP no funding", |
373 | 'ok', |
374 | 'All tests successful.', |
375 | |
376 | # ~TODO {{{ this should be an option |
377 | #'Test Summary Report', |
378 | #'-------------------', |
5e2a19fc |
379 | #"$source_tests/harness_directives (Wstat: 0 Tests: 3 Failed: 0)", |
b965d173 |
380 | #'Tests skipped:', |
381 | #'3', |
382 | # }}} |
383 | ); |
384 | |
385 | $status = pop @output; |
386 | $summary = pop @output; |
387 | $expected_summary = qr/^Files=1, Tests=3, \d+ wallclock secs/; |
388 | |
389 | is_deeply \@output, \@expected, '... and the output should be correct'; |
390 | like $summary, $expected_summary, |
391 | '... and the report summary should look correct'; |
392 | |
393 | like $status, qr{^Result: PASS$}, |
394 | '... and the status line should be correct'; |
395 | |
396 | # normal tests with bad tap |
397 | |
398 | # install callback handler |
399 | my $parser; |
400 | my $callback_count = 0; |
401 | |
402 | my @callback_log = (); |
403 | |
404 | for my $evt (qw(parser_args made_parser before_runtests after_runtests)) { |
405 | $harness->callback( |
406 | $evt => sub { |
407 | push @callback_log, $evt; |
408 | } |
409 | ); |
410 | } |
411 | |
412 | $harness->callback( |
413 | made_parser => sub { |
414 | $parser = shift; |
415 | $callback_count++; |
416 | } |
417 | ); |
418 | |
419 | @output = (); |
5e2a19fc |
420 | _runtests( $harness, "$source_tests/harness_badtap" ); |
b965d173 |
421 | chomp(@output); |
422 | |
423 | @output = map { trim($_) } @output; |
424 | $status = pop @output; |
425 | @summary = @output[ 12 .. ( $#output - 1 ) ]; |
426 | @output = @output[ 0 .. 11 ]; |
427 | @expected = ( |
bdaf8c65 |
428 | "$source_tests/harness_badtap ..", |
b965d173 |
429 | '1..2', |
430 | '[[reset]]', |
431 | 'ok 1 - this is a test', |
432 | '[[reset]]', |
433 | '[[red]]', |
434 | 'not ok 2 - this is another test', |
435 | '[[reset]]', |
436 | '1..2', |
437 | '[[reset]]', |
438 | '[[red]]', |
439 | 'Failed 1/2 subtests', |
440 | ); |
441 | is_deeply \@output, \@expected, |
442 | '... and failing test output should be correct'; |
443 | like $status, qr{^Result: FAIL$}, |
444 | '... and the status line should be correct'; |
445 | @expected_summary = ( |
446 | '[[reset]]', |
447 | 'Test Summary Report', |
448 | '-------------------', |
449 | '[[red]]', |
5e2a19fc |
450 | "$source_tests/harness_badtap (Wstat: 0 Tests: 2 Failed: 1)", |
b965d173 |
451 | '[[reset]]', |
452 | '[[red]]', |
69f36734 |
453 | 'Failed test:', |
b965d173 |
454 | '[[reset]]', |
455 | '[[red]]', |
456 | '2', |
457 | '[[reset]]', |
458 | '[[red]]', |
459 | 'Parse errors: More than one plan found in TAP output', |
460 | '[[reset]]', |
461 | ); |
462 | is_deeply \@summary, \@expected_summary, |
463 | '... and the badtap summary should also be correct'; |
464 | |
465 | cmp_ok( $callback_count, '==', 1, 'callback called once' ); |
466 | is_deeply( |
467 | \@callback_log, |
468 | [ 'before_runtests', 'parser_args', 'made_parser', 'after_runtests' ], |
469 | 'callback log matches' |
470 | ); |
471 | isa_ok $parser, 'TAP::Parser'; |
472 | |
473 | # coverage testing for _should_show_failures |
474 | # only show failures |
475 | |
476 | @output = (); |
5e2a19fc |
477 | _runtests( $harness_failures, "$source_tests/harness_failure" ); |
b965d173 |
478 | |
479 | chomp(@output); |
480 | |
481 | @expected = ( |
bdaf8c65 |
482 | "$source_tests/harness_failure ..", |
b965d173 |
483 | 'not ok 2 - this is another test', |
484 | 'Failed 1/2 subtests', |
485 | 'Test Summary Report', |
486 | '-------------------', |
5e2a19fc |
487 | "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", |
69f36734 |
488 | 'Failed test:', |
b965d173 |
489 | '2', |
490 | ); |
491 | |
492 | $status = pop @output; |
493 | $summary = pop @output; |
494 | |
495 | like $status, qr{^Result: FAIL$}, |
496 | '... and the status line should be correct'; |
497 | $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/; |
498 | is_deeply \@output, \@expected, '... and the output should be correct'; |
499 | |
500 | # check the status output for no tests |
501 | |
502 | @output = (); |
5e2a19fc |
503 | _runtests( $harness_failures, "$sample_tests/no_output" ); |
b965d173 |
504 | |
505 | chomp(@output); |
506 | |
507 | @expected = ( |
bdaf8c65 |
508 | "$sample_tests/no_output ..", |
b965d173 |
509 | 'No subtests run', |
510 | 'Test Summary Report', |
511 | '-------------------', |
5e2a19fc |
512 | "$sample_tests/no_output (Wstat: 0 Tests: 0 Failed: 0)", |
b965d173 |
513 | 'Parse errors: No plan found in TAP output', |
514 | ); |
515 | |
516 | $status = pop @output; |
517 | $summary = pop @output; |
518 | |
519 | like $status, qr{^Result: FAIL$}, |
520 | '... and the status line should be correct'; |
521 | $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/; |
522 | is_deeply \@output, \@expected, '... and the output should be correct'; |
523 | |
524 | #XXXX |
525 | } |
526 | |
527 | # make sure we can exec something ... anything! |
528 | SKIP: { |
529 | |
530 | my $cat = '/bin/cat'; |
531 | unless ( -e $cat ) { |
532 | skip "no '$cat'", 2; |
533 | } |
534 | |
535 | my $capture = IO::c55Capture->new_handle; |
536 | my $harness = TAP::Harness->new( |
537 | { verbosity => -2, |
538 | stdout => $capture, |
539 | exec => [$cat], |
540 | } |
541 | ); |
542 | |
5e2a19fc |
543 | eval { |
544 | _runtests( |
545 | $harness, |
27fc0087 |
546 | $ENV{PERL_CORE} |
f715bbfb |
547 | ? '../ext/Test-Harness/t/data/catme.1' |
27fc0087 |
548 | : 't/data/catme.1' |
5e2a19fc |
549 | ); |
550 | }; |
b965d173 |
551 | |
552 | my @output = tied($$capture)->dump; |
553 | my $status = pop @output; |
554 | like $status, qr{^Result: PASS$}, |
555 | '... and the status line should be correct'; |
556 | pop @output; # get rid of summary line |
557 | my $answer = pop @output; |
558 | is( $answer, "All tests successful.\n", 'cat meows' ); |
559 | } |
560 | |
f7c69158 |
561 | # make sure that we can exec with a code ref. |
562 | { |
563 | my $capture = IO::c55Capture->new_handle; |
564 | my $harness = TAP::Harness->new( |
565 | { verbosity => -2, |
566 | stdout => $capture, |
567 | exec => sub {undef}, |
568 | } |
569 | ); |
570 | |
571 | _runtests( $harness, "$source_tests/harness" ); |
572 | |
573 | my @output = tied($$capture)->dump; |
574 | my $status = pop @output; |
575 | like $status, qr{^Result: PASS$}, |
576 | '... and the status line should be correct'; |
577 | pop @output; # get rid of summary line |
578 | my $answer = pop @output; |
579 | is( $answer, "All tests successful.\n", 'cat meows' ); |
580 | } |
581 | |
a39e16d8 |
582 | # Exec with a coderef that returns an arrayref |
583 | SKIP: { |
584 | my $cat = '/bin/cat'; |
585 | unless ( -e $cat ) { |
586 | skip "no '$cat'", 2; |
587 | } |
588 | |
589 | my $capture = IO::c55Capture->new_handle; |
590 | my $harness = TAP::Harness->new( |
591 | { verbosity => -2, |
592 | stdout => $capture, |
593 | exec => sub { |
594 | return [ |
595 | $cat, |
596 | $ENV{PERL_CORE} |
597 | ? '../ext/Test-Harness/t/data/catme.1' |
598 | : 't/data/catme.1' |
599 | ]; |
600 | }, |
601 | } |
602 | ); |
603 | |
604 | _runtests( $harness, "$source_tests/harness" ); |
605 | |
606 | my @output = tied($$capture)->dump; |
607 | my $status = pop @output; |
608 | like $status, qr{^Result: PASS$}, |
609 | '... and the status line should be correct'; |
610 | pop @output; # get rid of summary line |
611 | my $answer = pop @output; |
612 | is( $answer, "All tests successful.\n", 'cat meows' ); |
613 | } |
614 | |
615 | # Exec with a coderef that returns raw TAP |
616 | { |
617 | my $capture = IO::c55Capture->new_handle; |
618 | my $harness = TAP::Harness->new( |
619 | { verbosity => -2, |
620 | stdout => $capture, |
621 | exec => sub { |
622 | return "1..1\nok 1 - raw TAP\n"; |
623 | }, |
624 | } |
625 | ); |
626 | |
627 | _runtests( $harness, "$source_tests/harness" ); |
628 | |
629 | my @output = tied($$capture)->dump; |
630 | my $status = pop @output; |
631 | like $status, qr{^Result: PASS$}, |
632 | '... and the status line should be correct'; |
633 | pop @output; # get rid of summary line |
634 | my $answer = pop @output; |
635 | is( $answer, "All tests successful.\n", 'cat meows' ); |
636 | } |
637 | |
638 | # Exec with a coderef that returns a filehandle |
639 | { |
640 | my $capture = IO::c55Capture->new_handle; |
641 | my $harness = TAP::Harness->new( |
642 | { verbosity => -2, |
643 | stdout => $capture, |
644 | exec => sub { |
645 | open my $fh, |
646 | $ENV{PERL_CORE} |
647 | ? '../ext/Test-Harness/t/data/catme.1' |
648 | : 't/data/catme.1'; |
649 | return $fh; |
650 | }, |
651 | } |
652 | ); |
653 | |
654 | _runtests( $harness, "$source_tests/harness" ); |
655 | |
656 | my @output = tied($$capture)->dump; |
657 | my $status = pop @output; |
658 | like $status, qr{^Result: PASS$}, |
659 | '... and the status line should be correct'; |
660 | pop @output; # get rid of summary line |
661 | my $answer = pop @output; |
662 | is( $answer, "All tests successful.\n", 'cat meows' ); |
663 | } |
664 | |
b965d173 |
665 | # catches "exec accumulates arguments" issue (r77) |
666 | { |
667 | my $capture = IO::c55Capture->new_handle; |
668 | my $harness = TAP::Harness->new( |
669 | { verbosity => -2, |
670 | stdout => $capture, |
671 | exec => [$^X] |
672 | } |
673 | ); |
674 | |
675 | _runtests( |
676 | $harness, |
5e2a19fc |
677 | "$source_tests/harness_complain" |
b965d173 |
678 | , # will get mad if run with args |
5e2a19fc |
679 | "$source_tests/harness", |
b965d173 |
680 | ); |
681 | |
682 | my @output = tied($$capture)->dump; |
683 | my $status = pop @output; |
684 | like $status, qr{^Result: PASS$}, |
685 | '... and the status line should be correct'; |
686 | pop @output; # get rid of summary line |
687 | is( $output[-1], "All tests successful.\n", |
688 | 'No exec accumulation' |
689 | ); |
690 | } |
691 | |
692 | sub trim { |
693 | $_[0] =~ s/^\s+|\s+$//g; |
694 | return $_[0]; |
695 | } |
696 | |
697 | sub liblist { |
698 | return [ map {"-I$_"} @_ ]; |
3c87ea76 |
699 | } |
700 | |
b965d173 |
701 | sub get_arg_sets { |
702 | |
703 | # keys are keys to new() |
704 | return { |
705 | lib => { |
706 | in => 'lib', |
707 | out => liblist('lib'), |
708 | test_name => '... a single lib switch should be correct' |
709 | }, |
710 | verbosity => { |
711 | in => 1, |
712 | out => 1, |
713 | test_name => '... and we should be able to set verbosity to 1' |
714 | }, |
715 | |
716 | # verbose => { |
717 | # in => 1, |
718 | # out => 1, |
719 | # test_name => '... and we should be able to set verbose to true' |
720 | # }, |
721 | }, |
722 | { lib => { |
723 | in => [ 'lib', 't' ], |
724 | out => liblist( 'lib', 't' ), |
725 | test_name => '... multiple lib dirs should be correct' |
726 | }, |
727 | verbosity => { |
728 | in => 0, |
729 | out => 0, |
730 | test_name => '... and we should be able to set verbosity to 0' |
731 | }, |
732 | |
733 | # verbose => { |
734 | # in => 0, |
735 | # out => 0, |
736 | # test_name => '... and we should be able to set verbose to false' |
737 | # }, |
738 | }, |
739 | { switches => { |
740 | in => [ '-T', '-w', '-T' ], |
741 | out => [ '-T', '-w', '-T' ], |
742 | test_name => '... duplicate switches should remain', |
743 | }, |
744 | failures => { |
745 | in => 1, |
746 | out => 1, |
747 | test_name => |
748 | '... and we should be able to set failures to true', |
749 | }, |
750 | verbosity => { |
751 | in => -1, |
752 | out => -1, |
753 | test_name => '... and we should be able to set verbosity to -1' |
754 | }, |
755 | |
756 | # quiet => { |
757 | # in => 1, |
758 | # out => 1, |
759 | # test_name => '... and we should be able to set quiet to false' |
760 | # }, |
761 | }, |
762 | |
763 | { verbosity => { |
764 | in => -2, |
765 | out => -2, |
766 | test_name => '... and we should be able to set verbosity to -2' |
767 | }, |
768 | |
769 | # really_quiet => { |
770 | # in => 1, |
771 | # out => 1, |
772 | # test_name => |
773 | # '... and we should be able to set really_quiet to true', |
774 | # }, |
775 | exec => { |
776 | in => $^X, |
777 | out => $^X, |
778 | test_name => |
779 | '... and we should be able to set the executable', |
780 | }, |
781 | }, |
782 | { switches => { |
783 | in => 'T', |
784 | out => ['T'], |
785 | test_name => |
786 | '... leading dashes (-) on switches are not optional', |
787 | }, |
788 | }, |
789 | { switches => { |
790 | in => '-T', |
791 | out => ['-T'], |
792 | test_name => '... we should be able to set switches', |
793 | }, |
794 | failures => { |
795 | in => 1, |
796 | out => 1, |
797 | test_name => '... and we should be able to set failures to true' |
798 | }, |
799 | }; |
800 | } |
801 | |
802 | sub _runtests { |
803 | my ( $harness, @tests ) = @_; |
804 | local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0; |
805 | my $aggregate = $harness->runtests(@tests); |
806 | return $aggregate; |
807 | } |
808 | |
809 | { |
810 | |
811 | # coverage tests for ctor |
812 | |
813 | my $harness = TAP::Harness->new( |
814 | { timer => 0, |
815 | errors => 1, |
816 | merge => 2, |
817 | |
818 | # formatter => 3, |
819 | } |
820 | ); |
821 | |
822 | is $harness->timer(), 0, 'timer getter'; |
823 | is $harness->timer(10), 10, 'timer setter'; |
824 | is $harness->errors(), 1, 'errors getter'; |
825 | is $harness->errors(10), 10, 'errors setter'; |
826 | is $harness->merge(), 2, 'merge getter'; |
827 | is $harness->merge(10), 10, 'merge setter'; |
828 | |
829 | # jobs accessor |
830 | is $harness->jobs(), 1, 'jobs'; |
831 | } |
832 | |
833 | { |
834 | |
835 | # coverage tests for the stdout key of VALIDATON_FOR, used by _initialize() in the ctor |
836 | |
837 | # the coverage tests are |
838 | # 1. ref $ref => false |
839 | # 2. ref => ! GLOB and ref->can(print) |
840 | # 3. ref $ref => GLOB |
841 | |
842 | # case 1 |
843 | |
844 | my @die; |
845 | |
846 | eval { |
847 | local $SIG{__DIE__} = sub { push @die, @_ }; |
848 | |
849 | my $harness = TAP::Harness->new( |
850 | { stdout => bless {}, '0', # how evil is THAT !!! |
851 | } |
852 | ); |
853 | }; |
854 | |
855 | is @die, 1, 'bad filehandle to stdout'; |
856 | like pop @die, qr/option 'stdout' needs a filehandle/, |
857 | '... and we died as expected'; |
858 | |
859 | # case 2 |
860 | |
861 | @die = (); |
862 | |
863 | package Printable; |
864 | |
865 | sub new { return bless {}, shift } |
866 | |
867 | sub print {return} |
868 | |
869 | package main; |
870 | |
871 | my $harness = TAP::Harness->new( |
872 | { stdout => Printable->new(), |
873 | } |
874 | ); |
875 | |
876 | isa_ok $harness, 'TAP::Harness'; |
877 | |
878 | # case 3 |
879 | |
880 | @die = (); |
881 | |
882 | $harness = TAP::Harness->new( |
883 | { stdout => bless {}, 'GLOB', # again with the evil |
884 | } |
885 | ); |
886 | |
887 | isa_ok $harness, 'TAP::Harness'; |
888 | } |
889 | |
890 | { |
891 | |
892 | # coverage testing of lib/switches accessor |
893 | my $harness = TAP::Harness->new; |
894 | |
895 | my @die; |
896 | |
897 | eval { |
898 | local $SIG{__DIE__} = sub { push @die, @_ }; |
899 | |
900 | $harness->switches(qw( too many arguments)); |
901 | }; |
902 | |
903 | is @die, 1, 'too many arguments to accessor'; |
904 | |
905 | like pop @die, qr/Too many arguments to method 'switches'/, |
906 | '...and we died as expected'; |
907 | |
908 | $harness->switches('simple scalar'); |
909 | |
910 | my $arrref = $harness->switches; |
911 | is_deeply $arrref, ['simple scalar'], 'scalar wrapped in arr ref'; |
912 | } |
913 | |
914 | { |
915 | |
916 | # coverage tests for the basically untested T::H::_open_spool |
917 | |
27fc0087 |
918 | my @spool = ( |
919 | ( $ENV{PERL_CORE} |
f715bbfb |
920 | ? ( File::Spec->updir(), 'ext', 'Test-Harness' ) |
27fc0087 |
921 | : () |
922 | ), |
923 | ( 't', 'spool' ) |
924 | ); |
5e2a19fc |
925 | $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(@spool); |
b965d173 |
926 | |
927 | # now given that we're going to be writing stuff to the file system, make sure we have |
928 | # a cleanup hook |
929 | |
930 | END { |
931 | use File::Path; |
932 | |
933 | # remove the tree if we made it this far |
934 | rmtree( $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) |
935 | if $ENV{PERL_TEST_HARNESS_DUMP_TAP}; |
936 | } |
937 | |
938 | my $harness = TAP::Harness->new( { verbosity => -2 } ); |
939 | |
940 | can_ok $harness, 'runtests'; |
941 | |
942 | # normal tests in verbose mode |
943 | |
5e2a19fc |
944 | my $parser |
945 | = $harness->runtests( File::Spec->catfile( $source_tests, 'harness' ) ); |
b965d173 |
946 | |
947 | isa_ok $parser, 'TAP::Parser::Aggregator', |
948 | '... runtests returns the aggregate'; |
949 | |
950 | ok -e File::Spec->catfile( |
951 | $ENV{PERL_TEST_HARNESS_DUMP_TAP}, |
5e2a19fc |
952 | $source_tests, 'harness' |
b965d173 |
953 | ); |
954 | } |
f7c69158 |
955 | |
956 | { |
957 | |
958 | # test name munging |
959 | my @cases = ( |
960 | { name => 'all the same', |
961 | input => [ 'foo.t', 'bar.t', 'fletz.t' ], |
962 | output => [ |
bdaf8c65 |
963 | [ 'foo.t', 'foo.t' ], [ 'bar.t', 'bar.t' ], |
964 | [ 'fletz.t', 'fletz.t' ] |
f7c69158 |
965 | ], |
966 | }, |
967 | { name => 'all the same, already cooked', |
968 | input => [ 'foo.t', [ 'bar.t', 'brip' ], 'fletz.t' ], |
969 | output => [ |
bdaf8c65 |
970 | [ 'foo.t', 'foo.t' ], [ 'bar.t', 'brip' ], |
971 | [ 'fletz.t', 'fletz.t' ] |
f7c69158 |
972 | ], |
973 | }, |
974 | { name => 'different exts', |
975 | input => [ 'foo.t', 'bar.u', 'fletz.v' ], |
976 | output => [ |
977 | [ 'foo.t', 'foo.t' ], [ 'bar.u', 'bar.u' ], |
978 | [ 'fletz.v', 'fletz.v' ] |
979 | ], |
980 | }, |
981 | { name => 'different exts, one already cooked', |
982 | input => [ 'foo.t', [ 'bar.u', 'bam' ], 'fletz.v' ], |
983 | output => [ |
984 | [ 'foo.t', 'foo.t' ], [ 'bar.u', 'bam' ], |
985 | [ 'fletz.v', 'fletz.v' ] |
986 | ], |
987 | }, |
988 | { name => 'different exts, two already cooked', |
989 | input => [ 'foo.t', [ 'bar.u', 'bam.q' ], [ 'fletz.v', 'boo' ] ], |
990 | output => [ |
991 | [ 'foo.t', 'foo.t' ], [ 'bar.u', 'bam.q' ], |
992 | [ 'fletz.v', 'boo' ] |
993 | ], |
994 | }, |
995 | ); |
996 | |
997 | for my $case (@cases) { |
998 | is_deeply [ TAP::Harness->_add_descriptions( @{ $case->{input} } ) ], |
999 | $case->{output}, '_add_descriptions: ' . $case->{name}; |
1000 | } |
1001 | } |