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