Commit | Line | Data |
b965d173 |
1 | #!/usr/bin/perl -w |
3c87ea76 |
2 | |
3 | BEGIN { |
b965d173 |
4 | if( $ENV{PERL_CORE} ) { |
3c87ea76 |
5 | chdir 't'; |
6 | @INC = ('../lib', 'lib'); |
7 | } |
8 | else { |
b965d173 |
9 | use lib 't/lib'; |
10 | } |
11 | } |
12 | |
13 | BEGIN { |
14 | if ($ENV{PERL_CORE}) { |
15 | # FIXME |
16 | print "1..0 # Skip pending resolution of a clean way to record the change in location of the sample tests\n"; |
17 | exit 0; |
3c87ea76 |
18 | } |
19 | } |
20 | |
21 | use strict; |
22 | |
b965d173 |
23 | use Test::More; |
24 | use IO::c55Capture; |
3c87ea76 |
25 | |
b965d173 |
26 | use TAP::Harness; |
27 | |
28 | my $HARNESS = 'TAP::Harness'; |
29 | |
30 | plan tests => 106; |
31 | |
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'; |
35 | |
36 | #### For color tests #### |
37 | |
38 | package Colorizer; |
39 | |
40 | sub new { bless {}, shift } |
41 | sub can_color {1} |
42 | |
43 | sub set_color { |
44 | my ( $self, $output, $color ) = @_; |
45 | $output->("[[$color]]"); |
46 | } |
47 | |
48 | package main; |
49 | |
50 | sub colorize { |
51 | my $harness = shift; |
52 | $harness->formatter->_colorizer( Colorizer->new ); |
53 | } |
54 | |
55 | can_ok $HARNESS, 'new'; |
56 | |
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'; |
60 | |
61 | eval { $HARNESS->new( { lib => 'aint_no_such_lib' } ) }; |
62 | is $@, '', '... and calling it with a non-existent lib is fine'; |
63 | |
64 | eval { $HARNESS->new( { lib => [qw/bad_lib_1 bad_lib_2/] } ) }; |
65 | is $@, '', '... and calling it with non-existent libs is fine'; |
66 | |
67 | ok my $harness = $HARNESS->new, |
68 | 'Calling new() without arguments should succeed'; |
69 | |
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}; |
74 | } |
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'; |
78 | |
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}; |
83 | } |
84 | } |
85 | |
86 | { |
87 | my @output; |
88 | local $^W; |
89 | local *TAP::Formatter::Console::_should_show_count = sub {0}; |
90 | local *TAP::Formatter::Console::_output = sub { |
91 | my $self = shift; |
92 | push @output => grep { $_ ne '' } |
93 | map { |
94 | local $_ = $_; |
95 | chomp; |
96 | trim($_) |
97 | } @_; |
98 | }; |
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 } ); |
104 | |
105 | colorize($harness); |
106 | |
107 | can_ok $harness, 'runtests'; |
108 | |
109 | # normal tests in verbose mode |
110 | |
111 | ok my $aggregate = _runtests( $harness, 't/source_tests/harness' ), |
112 | '... runtests returns the aggregate'; |
113 | |
114 | isa_ok $aggregate, 'TAP::Parser::Aggregator'; |
115 | |
116 | chomp(@output); |
117 | |
118 | my @expected = ( |
119 | 't/source_tests/harness....', |
120 | '1..1', |
121 | '[[reset]]', |
122 | 'ok 1 - this is a test', |
123 | '[[reset]]', |
124 | 'ok', |
125 | 'All tests successful.', |
126 | ); |
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}; |
131 | |
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'; |
137 | |
138 | # use an alias for test name |
139 | |
140 | @output = (); |
141 | ok $aggregate |
142 | = _runtests( $harness, [ 't/source_tests/harness', 'My Nice Test' ] ), |
143 | '... runtests returns the aggregate'; |
144 | |
145 | isa_ok $aggregate, 'TAP::Parser::Aggregator'; |
146 | |
147 | chomp(@output); |
148 | |
149 | @expected = ( |
150 | 'My Nice Test....', |
151 | '1..1', |
152 | '[[reset]]', |
153 | 'ok 1 - this is a test', |
154 | '[[reset]]', |
155 | 'ok', |
156 | 'All tests successful.', |
157 | ); |
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}; |
162 | |
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'; |
168 | |
169 | # run same test twice |
170 | |
171 | @output = (); |
172 | ok $aggregate |
173 | = _runtests( $harness, [ 't/source_tests/harness', 'My Nice Test' ], |
174 | [ 't/source_tests/harness', 'My Nice Test Again' ] ), |
175 | '... runtests returns the aggregate'; |
176 | |
177 | isa_ok $aggregate, 'TAP::Parser::Aggregator'; |
178 | |
179 | chomp(@output); |
180 | |
181 | @expected = ( |
182 | 'My Nice Test..........', |
183 | '1..1', |
184 | '[[reset]]', |
185 | 'ok 1 - this is a test', |
186 | '[[reset]]', |
187 | 'ok', |
188 | 'My Nice Test Again....', |
189 | '1..1', |
190 | '[[reset]]', |
191 | 'ok 1 - this is a test', |
192 | '[[reset]]', |
193 | 'ok', |
194 | 'All tests successful.', |
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 = (); |
210 | _runtests( $harness_whisper, 't/source_tests/harness' ); |
211 | |
212 | chomp(@output); |
213 | @expected = ( |
214 | 't/source_tests/harness....', |
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 = (); |
233 | _runtests( $harness_mute, 't/source_tests/harness' ); |
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 = (); |
254 | _runtests( $harness, 't/source_tests/harness_failure' ); |
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 | |
262 | my @summary = @output[ 10 .. $#output ]; |
263 | @output = @output[ 0 .. 9 ]; |
264 | |
265 | @expected = ( |
266 | 't/source_tests/harness_failure....', |
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]]', |
274 | '[[red]]', |
275 | 'Failed 1/2 subtests', |
276 | ); |
277 | |
278 | is_deeply \@output, \@expected, |
279 | '... and failing test output should be correct'; |
280 | |
281 | my @expected_summary = ( |
282 | '[[reset]]', |
283 | 'Test Summary Report', |
284 | '-------------------', |
285 | '[[red]]', |
286 | 't/source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)', |
287 | '[[reset]]', |
288 | '[[red]]', |
289 | 'Failed test number(s):', |
290 | '[[reset]]', |
291 | '[[red]]', |
292 | '2', |
293 | '[[reset]]', |
294 | ); |
295 | |
296 | is_deeply \@summary, \@expected_summary, |
297 | '... and the failure summary should also be correct'; |
298 | |
299 | # quiet tests with failures |
300 | |
301 | @output = (); |
302 | _runtests( $harness_whisper, 't/source_tests/harness_failure' ); |
303 | |
304 | $status = pop @output; |
305 | $summary = pop @output; |
306 | @expected = ( |
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)', |
312 | 'Failed test number(s):', |
313 | '2', |
314 | ); |
315 | |
316 | like $status, qr{^Result: FAIL$}, |
317 | '... and the status line should be correct'; |
318 | |
319 | is_deeply \@output, \@expected, |
320 | '... and failing test output should be correct'; |
321 | |
322 | # really quiet tests with failures |
323 | |
324 | @output = (); |
325 | _runtests( $harness_mute, 't/source_tests/harness_failure' ); |
326 | |
327 | $status = pop @output; |
328 | $summary = pop @output; |
329 | @expected = ( |
330 | 'Test Summary Report', |
331 | '-------------------', |
332 | 't/source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)', |
333 | 'Failed test number(s):', |
334 | '2', |
335 | ); |
336 | |
337 | like $status, qr{^Result: FAIL$}, |
338 | '... and the status line should be correct'; |
339 | |
340 | is_deeply \@output, \@expected, |
341 | '... and failing test output should be correct'; |
342 | |
343 | # only show directives |
344 | |
345 | @output = (); |
346 | _runtests( |
347 | $harness_directives, |
348 | 't/source_tests/harness_directives' |
349 | ); |
350 | |
351 | chomp(@output); |
352 | |
353 | @expected = ( |
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", |
357 | 'ok', |
358 | 'All tests successful.', |
359 | |
360 | # ~TODO {{{ this should be an option |
361 | #'Test Summary Report', |
362 | #'-------------------', |
363 | #'t/source_tests/harness_directives (Wstat: 0 Tests: 3 Failed: 0)', |
364 | #'Tests skipped:', |
365 | #'3', |
366 | # }}} |
367 | ); |
368 | |
369 | $status = pop @output; |
370 | $summary = pop @output; |
371 | $expected_summary = qr/^Files=1, Tests=3, \d+ wallclock secs/; |
372 | |
373 | is_deeply \@output, \@expected, '... and the output should be correct'; |
374 | like $summary, $expected_summary, |
375 | '... and the report summary should look correct'; |
376 | |
377 | like $status, qr{^Result: PASS$}, |
378 | '... and the status line should be correct'; |
379 | |
380 | # normal tests with bad tap |
381 | |
382 | # install callback handler |
383 | my $parser; |
384 | my $callback_count = 0; |
385 | |
386 | my @callback_log = (); |
387 | |
388 | for my $evt (qw(parser_args made_parser before_runtests after_runtests)) { |
389 | $harness->callback( |
390 | $evt => sub { |
391 | push @callback_log, $evt; |
392 | } |
393 | ); |
394 | } |
395 | |
396 | $harness->callback( |
397 | made_parser => sub { |
398 | $parser = shift; |
399 | $callback_count++; |
400 | } |
401 | ); |
402 | |
403 | @output = (); |
404 | _runtests( $harness, 't/source_tests/harness_badtap' ); |
405 | chomp(@output); |
406 | |
407 | @output = map { trim($_) } @output; |
408 | $status = pop @output; |
409 | @summary = @output[ 12 .. ( $#output - 1 ) ]; |
410 | @output = @output[ 0 .. 11 ]; |
411 | @expected = ( |
412 | 't/source_tests/harness_badtap....', |
413 | '1..2', |
414 | '[[reset]]', |
415 | 'ok 1 - this is a test', |
416 | '[[reset]]', |
417 | '[[red]]', |
418 | 'not ok 2 - this is another test', |
419 | '[[reset]]', |
420 | '1..2', |
421 | '[[reset]]', |
422 | '[[red]]', |
423 | 'Failed 1/2 subtests', |
424 | ); |
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 = ( |
430 | '[[reset]]', |
431 | 'Test Summary Report', |
432 | '-------------------', |
433 | '[[red]]', |
434 | 't/source_tests/harness_badtap (Wstat: 0 Tests: 2 Failed: 1)', |
435 | '[[reset]]', |
436 | '[[red]]', |
437 | 'Failed test number(s):', |
438 | '[[reset]]', |
439 | '[[red]]', |
440 | '2', |
441 | '[[reset]]', |
442 | '[[red]]', |
443 | 'Parse errors: More than one plan found in TAP output', |
444 | '[[reset]]', |
445 | ); |
446 | is_deeply \@summary, \@expected_summary, |
447 | '... and the badtap summary should also be correct'; |
448 | |
449 | cmp_ok( $callback_count, '==', 1, 'callback called once' ); |
450 | is_deeply( |
451 | \@callback_log, |
452 | [ 'before_runtests', 'parser_args', 'made_parser', 'after_runtests' ], |
453 | 'callback log matches' |
454 | ); |
455 | isa_ok $parser, 'TAP::Parser'; |
456 | |
457 | # coverage testing for _should_show_failures |
458 | # only show failures |
459 | |
460 | @output = (); |
461 | _runtests( $harness_failures, 't/source_tests/harness_failure' ); |
462 | |
463 | chomp(@output); |
464 | |
465 | @expected = ( |
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)', |
472 | 'Failed test number(s):', |
473 | '2', |
474 | ); |
475 | |
476 | $status = pop @output; |
477 | $summary = pop @output; |
478 | |
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'; |
483 | |
484 | # check the status output for no tests |
485 | |
486 | @output = (); |
487 | _runtests( $harness_failures, 't/sample-tests/no_output' ); |
488 | |
489 | chomp(@output); |
490 | |
491 | @expected = ( |
492 | 't/sample-tests/no_output....', |
493 | 'No subtests run', |
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', |
498 | ); |
499 | |
500 | $status = pop @output; |
501 | $summary = pop @output; |
502 | |
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'; |
507 | |
508 | #XXXX |
509 | } |
510 | |
511 | # make sure we can exec something ... anything! |
512 | SKIP: { |
513 | |
514 | my $cat = '/bin/cat'; |
515 | unless ( -e $cat ) { |
516 | skip "no '$cat'", 2; |
517 | } |
518 | |
519 | my $capture = IO::c55Capture->new_handle; |
520 | my $harness = TAP::Harness->new( |
521 | { verbosity => -2, |
522 | stdout => $capture, |
523 | exec => [$cat], |
524 | } |
525 | ); |
526 | |
527 | eval { _runtests( $harness, 't/data/catme.1' ) }; |
528 | |
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' ); |
536 | } |
537 | |
538 | # catches "exec accumulates arguments" issue (r77) |
539 | { |
540 | my $capture = IO::c55Capture->new_handle; |
541 | my $harness = TAP::Harness->new( |
542 | { verbosity => -2, |
543 | stdout => $capture, |
544 | exec => [$^X] |
545 | } |
546 | ); |
547 | |
548 | _runtests( |
549 | $harness, |
550 | 't/source_tests/harness_complain' |
551 | , # will get mad if run with args |
552 | 't/source_tests/harness', |
553 | ); |
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 | is( $output[-1], "All tests successful.\n", |
561 | 'No exec accumulation' |
562 | ); |
563 | } |
564 | |
565 | sub trim { |
566 | $_[0] =~ s/^\s+|\s+$//g; |
567 | return $_[0]; |
568 | } |
569 | |
570 | sub liblist { |
571 | return [ map {"-I$_"} @_ ]; |
3c87ea76 |
572 | } |
573 | |
b965d173 |
574 | sub get_arg_sets { |
575 | |
576 | # keys are keys to new() |
577 | return { |
578 | lib => { |
579 | in => 'lib', |
580 | out => liblist('lib'), |
581 | test_name => '... a single lib switch should be correct' |
582 | }, |
583 | verbosity => { |
584 | in => 1, |
585 | out => 1, |
586 | test_name => '... and we should be able to set verbosity to 1' |
587 | }, |
588 | |
589 | # verbose => { |
590 | # in => 1, |
591 | # out => 1, |
592 | # test_name => '... and we should be able to set verbose to true' |
593 | # }, |
594 | }, |
595 | { lib => { |
596 | in => [ 'lib', 't' ], |
597 | out => liblist( 'lib', 't' ), |
598 | test_name => '... multiple lib dirs should be correct' |
599 | }, |
600 | verbosity => { |
601 | in => 0, |
602 | out => 0, |
603 | test_name => '... and we should be able to set verbosity to 0' |
604 | }, |
605 | |
606 | # verbose => { |
607 | # in => 0, |
608 | # out => 0, |
609 | # test_name => '... and we should be able to set verbose to false' |
610 | # }, |
611 | }, |
612 | { switches => { |
613 | in => [ '-T', '-w', '-T' ], |
614 | out => [ '-T', '-w', '-T' ], |
615 | test_name => '... duplicate switches should remain', |
616 | }, |
617 | failures => { |
618 | in => 1, |
619 | out => 1, |
620 | test_name => |
621 | '... and we should be able to set failures to true', |
622 | }, |
623 | verbosity => { |
624 | in => -1, |
625 | out => -1, |
626 | test_name => '... and we should be able to set verbosity to -1' |
627 | }, |
628 | |
629 | # quiet => { |
630 | # in => 1, |
631 | # out => 1, |
632 | # test_name => '... and we should be able to set quiet to false' |
633 | # }, |
634 | }, |
635 | |
636 | { verbosity => { |
637 | in => -2, |
638 | out => -2, |
639 | test_name => '... and we should be able to set verbosity to -2' |
640 | }, |
641 | |
642 | # really_quiet => { |
643 | # in => 1, |
644 | # out => 1, |
645 | # test_name => |
646 | # '... and we should be able to set really_quiet to true', |
647 | # }, |
648 | exec => { |
649 | in => $^X, |
650 | out => $^X, |
651 | test_name => |
652 | '... and we should be able to set the executable', |
653 | }, |
654 | }, |
655 | { switches => { |
656 | in => 'T', |
657 | out => ['T'], |
658 | test_name => |
659 | '... leading dashes (-) on switches are not optional', |
660 | }, |
661 | }, |
662 | { switches => { |
663 | in => '-T', |
664 | out => ['-T'], |
665 | test_name => '... we should be able to set switches', |
666 | }, |
667 | failures => { |
668 | in => 1, |
669 | out => 1, |
670 | test_name => '... and we should be able to set failures to true' |
671 | }, |
672 | }; |
673 | } |
674 | |
675 | sub _runtests { |
676 | my ( $harness, @tests ) = @_; |
677 | local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0; |
678 | my $aggregate = $harness->runtests(@tests); |
679 | return $aggregate; |
680 | } |
681 | |
682 | { |
683 | |
684 | # coverage tests for ctor |
685 | |
686 | my $harness = TAP::Harness->new( |
687 | { timer => 0, |
688 | errors => 1, |
689 | merge => 2, |
690 | |
691 | # formatter => 3, |
692 | } |
693 | ); |
694 | |
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'; |
701 | |
702 | # jobs accessor |
703 | is $harness->jobs(), 1, 'jobs'; |
704 | } |
705 | |
706 | { |
707 | |
708 | # coverage tests for the stdout key of VALIDATON_FOR, used by _initialize() in the ctor |
709 | |
710 | # the coverage tests are |
711 | # 1. ref $ref => false |
712 | # 2. ref => ! GLOB and ref->can(print) |
713 | # 3. ref $ref => GLOB |
714 | |
715 | # case 1 |
716 | |
717 | my @die; |
718 | |
719 | eval { |
720 | local $SIG{__DIE__} = sub { push @die, @_ }; |
721 | |
722 | my $harness = TAP::Harness->new( |
723 | { stdout => bless {}, '0', # how evil is THAT !!! |
724 | } |
725 | ); |
726 | }; |
727 | |
728 | is @die, 1, 'bad filehandle to stdout'; |
729 | like pop @die, qr/option 'stdout' needs a filehandle/, |
730 | '... and we died as expected'; |
731 | |
732 | # case 2 |
733 | |
734 | @die = (); |
735 | |
736 | package Printable; |
737 | |
738 | sub new { return bless {}, shift } |
739 | |
740 | sub print {return} |
741 | |
742 | package main; |
743 | |
744 | my $harness = TAP::Harness->new( |
745 | { stdout => Printable->new(), |
746 | } |
747 | ); |
748 | |
749 | isa_ok $harness, 'TAP::Harness'; |
750 | |
751 | # case 3 |
752 | |
753 | @die = (); |
754 | |
755 | $harness = TAP::Harness->new( |
756 | { stdout => bless {}, 'GLOB', # again with the evil |
757 | } |
758 | ); |
759 | |
760 | isa_ok $harness, 'TAP::Harness'; |
761 | } |
762 | |
763 | { |
764 | |
765 | # coverage testing of lib/switches accessor |
766 | my $harness = TAP::Harness->new; |
767 | |
768 | my @die; |
769 | |
770 | eval { |
771 | local $SIG{__DIE__} = sub { push @die, @_ }; |
772 | |
773 | $harness->switches(qw( too many arguments)); |
774 | }; |
775 | |
776 | is @die, 1, 'too many arguments to accessor'; |
777 | |
778 | like pop @die, qr/Too many arguments to method 'switches'/, |
779 | '...and we died as expected'; |
780 | |
781 | $harness->switches('simple scalar'); |
782 | |
783 | my $arrref = $harness->switches; |
784 | is_deeply $arrref, ['simple scalar'], 'scalar wrapped in arr ref'; |
785 | } |
786 | |
787 | { |
788 | |
789 | # coverage tests for the basically untested T::H::_open_spool |
790 | |
791 | $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(qw(t spool)); |
792 | |
793 | # now given that we're going to be writing stuff to the file system, make sure we have |
794 | # a cleanup hook |
795 | |
796 | END { |
797 | use File::Path; |
798 | |
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}; |
802 | } |
803 | |
804 | my $harness = TAP::Harness->new( { verbosity => -2 } ); |
805 | |
806 | can_ok $harness, 'runtests'; |
807 | |
808 | # normal tests in verbose mode |
809 | |
810 | my $parser = $harness->runtests( |
811 | File::Spec->catfile(qw (t source_tests harness )) ); |
812 | |
813 | isa_ok $parser, 'TAP::Parser::Aggregator', |
814 | '... runtests returns the aggregate'; |
815 | |
816 | ok -e File::Spec->catfile( |
817 | $ENV{PERL_TEST_HARNESS_DUMP_TAP}, |
818 | qw( t source_tests harness ) |
819 | ); |
820 | } |