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