projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Upgrade to Test-Harness-3.17
[p5sagit/p5-mst-13.2.git] / ext / Test-Harness / t / parse.t
CommitLineData
b965d173 1#!/usr/bin/perl -w
2
3use strict;
4
5BEGIN {
2a7f4b9b 6 if ( $ENV{PERL_CORE} ) {
b965d173 7 chdir 't';
f715bbfb 8 @INC = ( '../lib', '../ext/Test-Harness/t/lib' );
b965d173 9 }
10 else {
2a7f4b9b 11 use lib 't/lib';
b965d173 12 }
13}
14
a39e16d8 15use Test::More tests => 294;
b965d173 16use IO::c55Capture;
17
18use File::Spec;
19
20use TAP::Parser;
f7c69158 21use TAP::Parser::IteratorFactory;
b965d173 22
23sub _get_results {
24 my $parser = shift;
25 my @results;
26 while ( defined( my $result = $parser->next ) ) {
27 push @results => $result;
28 }
29 return @results;
30}
31
2a7f4b9b 32my ( $PARSER, $PLAN, $PRAGMA, $TEST, $COMMENT, $BAILOUT, $UNKNOWN, $YAML, $VERSION ) = qw(
b965d173 33 TAP::Parser
34 TAP::Parser::Result::Plan
2a7f4b9b 35 TAP::Parser::Result::Pragma
b965d173 36 TAP::Parser::Result::Test
37 TAP::Parser::Result::Comment
38 TAP::Parser::Result::Bailout
39 TAP::Parser::Result::Unknown
40 TAP::Parser::Result::YAML
41 TAP::Parser::Result::Version
42);
43
f7c69158 44my $factory = TAP::Parser::IteratorFactory->new;
45
b965d173 46my $tap = <<'END_TAP';
47TAP version 13
481..7
49ok 1 - input file opened
50... this is junk
51not ok first line of the input valid # todo some data
52# this is a comment
53ok 3 - read the rest of the file
54not ok 4 - this is a real failure
55 --- YAML!
56 ...
57ok 5 # skip we have no description
58ok 6 - you shall not pass! # TODO should have failed
59not ok 7 - Gandalf wins. Game over. # TODO 'bout time!
60END_TAP
61
62can_ok $PARSER, 'new';
63my $parser = $PARSER->new( { tap => $tap } );
64isa_ok $parser, $PARSER, '... and the object it returns';
65
66ok $ENV{TAP_VERSION}, 'TAP_VERSION env variable should be set';
67
68# results() is sane?
69
70my @results = _get_results($parser);
71is scalar @results, 12, '... and there should be one for each line';
72
73my $version = shift @results;
74isa_ok $version, $VERSION;
75is $version->version, '13', '... and the version should be 13';
76
77# check the test plan
78
79my $result = shift @results;
80isa_ok $result, $PLAN;
81can_ok $result, 'type';
82is $result->type, 'plan', '... and it should report the correct type';
83ok $result->is_plan, '... and it should identify itself as a plan';
84is $result->plan, '1..7', '... and identify the plan';
85ok !$result->directive, '... and this plan should not have a directive';
86ok !$result->explanation, '... or a directive explanation';
87is $result->as_string, '1..7',
88 '... and have the correct string representation';
89is $result->raw, '1..7', '... and raw() should return the original line';
90
91# a normal, passing test
92
93my $test = shift @results;
94isa_ok $test, $TEST;
95is $test->type, 'test', '... and it should report the correct type';
96ok $test->is_test, '... and it should identify itself as a test';
97is $test->ok, 'ok', '... and it should have the correct ok()';
98ok $test->is_ok, '... and the correct boolean version of is_ok()';
99ok $test->is_actual_ok,
100 '... and the correct boolean version of is_actual_ok()';
101is $test->number, 1, '... and have the correct test number';
102is $test->description, '- input file opened',
103 '... and the correct description';
104ok !$test->directive, '... and not have a directive';
105ok !$test->explanation, '... or a directive explanation';
106ok !$test->has_skip, '... and it is not a SKIPped test';
107ok !$test->has_todo, '... nor a TODO test';
108is $test->as_string, 'ok 1 - input file opened',
109 '... and its string representation should be correct';
110is $test->raw, 'ok 1 - input file opened',
111 '... and raw() should return the original line';
112
113# junk lines should be preserved
114
115my $unknown = shift @results;
116isa_ok $unknown, $UNKNOWN;
117is $unknown->type, 'unknown', '... and it should report the correct type';
118ok $unknown->is_unknown, '... and it should identify itself as unknown';
119is $unknown->as_string, '... this is junk',
120 '... and its string representation should be returned verbatim';
121is $unknown->raw, '... this is junk',
122 '... and raw() should return the original line';
123
124# a failing test, which also happens to have a directive
125
126my $failed = shift @results;
127isa_ok $failed, $TEST;
128is $failed->type, 'test', '... and it should report the correct type';
129ok $failed->is_test, '... and it should identify itself as a test';
130is $failed->ok, 'not ok', '... and it should have the correct ok()';
131ok $failed->is_ok, '... and TODO tests should always pass';
132ok !$failed->is_actual_ok,
133 '... and the correct boolean version of is_actual_ok ()';
134is $failed->number, 2, '... and have the correct failed number';
135is $failed->description, 'first line of the input valid',
136 '... and the correct description';
137is $failed->directive, 'TODO', '... and should have the correct directive';
138is $failed->explanation, 'some data',
139 '... and the correct directive explanation';
140ok !$failed->has_skip, '... and it is not a SKIPped failed';
141ok $failed->has_todo, '... but it is a TODO succeeded';
142is $failed->as_string,
143 'not ok 2 first line of the input valid # TODO some data',
144 '... and its string representation should be correct';
145is $failed->raw, 'not ok first line of the input valid # todo some data',
146 '... and raw() should return the original line';
147
148# comments
149
150my $comment = shift @results;
151isa_ok $comment, $COMMENT;
152is $comment->type, 'comment', '... and it should report the correct type';
153ok $comment->is_comment, '... and it should identify itself as a comment';
154is $comment->comment, 'this is a comment',
155 '... and you should be able to fetch the comment';
156is $comment->as_string, '# this is a comment',
157 '... and have the correct string representation';
158is $comment->raw, '# this is a comment',
159 '... and raw() should return the original line';
160
161# another normal, passing test
162
163$test = shift @results;
164isa_ok $test, $TEST;
165is $test->type, 'test', '... and it should report the correct type';
166ok $test->is_test, '... and it should identify itself as a test';
167is $test->ok, 'ok', '... and it should have the correct ok()';
168ok $test->is_ok, '... and the correct boolean version of is_ok()';
169ok $test->is_actual_ok,
170 '... and the correct boolean version of is_actual_ok()';
171is $test->number, 3, '... and have the correct test number';
172is $test->description, '- read the rest of the file',
173 '... and the correct description';
174ok !$test->directive, '... and not have a directive';
175ok !$test->explanation, '... or a directive explanation';
176ok !$test->has_skip, '... and it is not a SKIPped test';
177ok !$test->has_todo, '... nor a TODO test';
178is $test->as_string, 'ok 3 - read the rest of the file',
179 '... and its string representation should be correct';
180is $test->raw, 'ok 3 - read the rest of the file',
181 '... and raw() should return the original line';
182
183# a failing test
184
185$failed = shift @results;
186isa_ok $failed, $TEST;
187is $failed->type, 'test', '... and it should report the correct type';
188ok $failed->is_test, '... and it should identify itself as a test';
189is $failed->ok, 'not ok', '... and it should have the correct ok()';
190ok !$failed->is_ok, '... and the tests should not have passed';
191ok !$failed->is_actual_ok,
192 '... and the correct boolean version of is_actual_ok ()';
193is $failed->number, 4, '... and have the correct failed number';
194is $failed->description, '- this is a real failure',
195 '... and the correct description';
196ok !$failed->directive, '... and should have no directive';
197ok !$failed->explanation, '... and no directive explanation';
198ok !$failed->has_skip, '... and it is not a SKIPped failed';
199ok !$failed->has_todo, '... and not a TODO test';
200is $failed->as_string, 'not ok 4 - this is a real failure',
201 '... and its string representation should be correct';
202is $failed->raw, 'not ok 4 - this is a real failure',
203 '... and raw() should return the original line';
204
205# Some YAML
206my $yaml = shift @results;
207isa_ok $yaml, $YAML;
208is $yaml->type, 'yaml', '... and it should report the correct type';
209ok $yaml->is_yaml, '... and it should identify itself as yaml';
210is_deeply $yaml->data, 'YAML!', '... and data should be correct';
211
212# ok 5 # skip we have no description
213# skipped test
214
215$test = shift @results;
216isa_ok $test, $TEST;
217is $test->type, 'test', '... and it should report the correct type';
218ok $test->is_test, '... and it should identify itself as a test';
219is $test->ok, 'ok', '... and it should have the correct ok()';
220ok $test->is_ok, '... and the correct boolean version of is_ok()';
221ok $test->is_actual_ok,
222 '... and the correct boolean version of is_actual_ok()';
223is $test->number, 5, '... and have the correct test number';
224ok !$test->description, '... and skipped tests have no description';
f7c69158 225is $test->directive, 'SKIP', '... and the correct directive';
b965d173 226is $test->explanation, 'we have no description',
227 '... but we should have an explanation';
228ok $test->has_skip, '... and it is a SKIPped test';
229ok !$test->has_todo, '... but not a TODO test';
230is $test->as_string, 'ok 5 # SKIP we have no description',
231 '... and its string representation should be correct';
232is $test->raw, 'ok 5 # skip we have no description',
233 '... and raw() should return the original line';
234
235# a failing test, which also happens to have a directive
236# ok 6 - you shall not pass! # TODO should have failed
237
238my $bonus = shift @results;
239isa_ok $bonus, $TEST;
240can_ok $bonus, 'todo_passed';
241is $bonus->type, 'test', 'TODO tests should parse correctly';
242ok $bonus->is_test, '... and it should identify itself as a test';
243is $bonus->ok, 'ok', '... and it should have the correct ok()';
244ok $bonus->is_ok, '... and TODO tests should not always pass';
245ok $bonus->is_actual_ok,
246 '... and the correct boolean version of is_actual_ok ()';
247is $bonus->number, 6, '... and have the correct failed number';
248is $bonus->description, '- you shall not pass!',
249 '... and the correct description';
250is $bonus->directive, 'TODO', '... and should have the correct directive';
251is $bonus->explanation, 'should have failed',
252 '... and the correct directive explanation';
253ok !$bonus->has_skip, '... and it is not a SKIPped failed';
254ok $bonus->has_todo, '... but it is a TODO succeeded';
255is $bonus->as_string, 'ok 6 - you shall not pass! # TODO should have failed',
256 '... and its string representation should be correct';
257is $bonus->raw, 'ok 6 - you shall not pass! # TODO should have failed',
258 '... and raw() should return the original line';
259ok $bonus->todo_passed,
260 '... todo_bonus() should pass for TODO tests which unexpectedly succeed';
261
262# not ok 7 - Gandalf wins. Game over. # TODO 'bout time!
263
264my $passed = shift @results;
265isa_ok $passed, $TEST;
266can_ok $passed, 'todo_passed';
267is $passed->type, 'test', 'TODO tests should parse correctly';
268ok $passed->is_test, '... and it should identify itself as a test';
269is $passed->ok, 'not ok', '... and it should have the correct ok()';
270ok $passed->is_ok, '... and TODO tests should always pass';
271ok !$passed->is_actual_ok,
272 '... and the correct boolean version of is_actual_ok ()';
273is $passed->number, 7, '... and have the correct passed number';
274is $passed->description, '- Gandalf wins. Game over.',
275 '... and the correct description';
276is $passed->directive, 'TODO', '... and should have the correct directive';
277is $passed->explanation, "'bout time!",
278 '... and the correct directive explanation';
279ok !$passed->has_skip, '... and it is not a SKIPped passed';
280ok $passed->has_todo, '... but it is a TODO succeeded';
281is $passed->as_string,
282 "not ok 7 - Gandalf wins. Game over. # TODO 'bout time!",
283 '... and its string representation should be correct';
284is $passed->raw, "not ok 7 - Gandalf wins. Game over. # TODO 'bout time!",
285 '... and raw() should return the original line';
286ok !$passed->todo_passed,
287 '... todo_passed() should not pass for TODO tests which failed';
288
289# test parse results
290
291can_ok $parser, 'passed';
292is $parser->passed, 6,
293 '... and we should have the correct number of passed tests';
294is_deeply [ $parser->passed ], [ 1, 2, 3, 5, 6, 7 ],
295 '... and get a list of the passed tests';
296
297can_ok $parser, 'failed';
298is $parser->failed, 1, '... and the correct number of failed tests';
299is_deeply [ $parser->failed ], [4], '... and get a list of the failed tests';
300
301can_ok $parser, 'actual_passed';
302is $parser->actual_passed, 4,
303 '... and we should have the correct number of actually passed tests';
304is_deeply [ $parser->actual_passed ], [ 1, 3, 5, 6 ],
305 '... and get a list of the actually passed tests';
306
307can_ok $parser, 'actual_failed';
308is $parser->actual_failed, 3,
309 '... and the correct number of actually failed tests';
310is_deeply [ $parser->actual_failed ], [ 2, 4, 7 ],
311 '... or get a list of the actually failed tests';
312
313can_ok $parser, 'todo';
314is $parser->todo, 3,
315 '... and we should have the correct number of TODO tests';
316is_deeply [ $parser->todo ], [ 2, 6, 7 ],
317 '... and get a list of the TODO tests';
318
319can_ok $parser, 'skipped';
320is $parser->skipped, 1,
321 '... and we should have the correct number of skipped tests';
322is_deeply [ $parser->skipped ], [5],
323 '... and get a list of the skipped tests';
324
325# check the plan
326
327can_ok $parser, 'plan';
328is $parser->plan, '1..7', '... and we should have the correct plan';
329is $parser->tests_planned, 7, '... and the correct number of tests';
330
331# "Unexpectedly succeeded"
332can_ok $parser, 'todo_passed';
333is scalar $parser->todo_passed, 1,
334 '... and it should report the number of tests which unexpectedly succeeded';
335is_deeply [ $parser->todo_passed ], [6],
336 '... or *which* tests unexpectedly succeeded';
337
338#
339# Bug report from Torsten Schoenfeld
340# Makes sure parser can handle blank lines
341#
342
343$tap = <<'END_TAP';
3441..2
345ok 1 - input file opened
346
347
348ok 2 - read the rest of the file
349END_TAP
350
351my $aref = [ split /\n/ => $tap ];
352
353can_ok $PARSER, 'new';
f7c69158 354$parser = $PARSER->new( { stream => $factory->make_iterator($aref) } );
b965d173 355isa_ok $parser, $PARSER, '... and calling it should succeed';
356
357# results() is sane?
358
359ok @results = _get_results($parser), 'The parser should return results';
360is scalar @results, 5, '... and there should be one for each line';
361
362# check the test plan
363
364$result = shift @results;
365isa_ok $result, $PLAN;
366can_ok $result, 'type';
367is $result->type, 'plan', '... and it should report the correct type';
368ok $result->is_plan, '... and it should identify itself as a plan';
369is $result->plan, '1..2', '... and identify the plan';
370is $result->as_string, '1..2',
371 '... and have the correct string representation';
372is $result->raw, '1..2', '... and raw() should return the original line';
373
374# a normal, passing test
375
376$test = shift @results;
377isa_ok $test, $TEST;
378is $test->type, 'test', '... and it should report the correct type';
379ok $test->is_test, '... and it should identify itself as a test';
380is $test->ok, 'ok', '... and it should have the correct ok()';
381ok $test->is_ok, '... and the correct boolean version of is_ok()';
382ok $test->is_actual_ok,
383 '... and the correct boolean version of is_actual_ok()';
384is $test->number, 1, '... and have the correct test number';
385is $test->description, '- input file opened',
386 '... and the correct description';
387ok !$test->directive, '... and not have a directive';
388ok !$test->explanation, '... or a directive explanation';
389ok !$test->has_skip, '... and it is not a SKIPped test';
390ok !$test->has_todo, '... nor a TODO test';
391is $test->as_string, 'ok 1 - input file opened',
392 '... and its string representation should be correct';
393is $test->raw, 'ok 1 - input file opened',
394 '... and raw() should return the original line';
395
396# junk lines should be preserved
397
398$unknown = shift @results;
399isa_ok $unknown, $UNKNOWN;
400is $unknown->type, 'unknown', '... and it should report the correct type';
401ok $unknown->is_unknown, '... and it should identify itself as unknown';
402is $unknown->as_string, '',
403 '... and its string representation should be returned verbatim';
404is $unknown->raw, '', '... and raw() should return the original line';
405
406# ... and the second empty line
407
408$unknown = shift @results;
409isa_ok $unknown, $UNKNOWN;
410is $unknown->type, 'unknown', '... and it should report the correct type';
411ok $unknown->is_unknown, '... and it should identify itself as unknown';
412is $unknown->as_string, '',
413 '... and its string representation should be returned verbatim';
414is $unknown->raw, '', '... and raw() should return the original line';
415
416# a passing test
417
418$test = shift @results;
419isa_ok $test, $TEST;
420is $test->type, 'test', '... and it should report the correct type';
421ok $test->is_test, '... and it should identify itself as a test';
422is $test->ok, 'ok', '... and it should have the correct ok()';
423ok $test->is_ok, '... and the correct boolean version of is_ok()';
424ok $test->is_actual_ok,
425 '... and the correct boolean version of is_actual_ok()';
426is $test->number, 2, '... and have the correct test number';
427is $test->description, '- read the rest of the file',
428 '... and the correct description';
429ok !$test->directive, '... and not have a directive';
430ok !$test->explanation, '... or a directive explanation';
431ok !$test->has_skip, '... and it is not a SKIPped test';
432ok !$test->has_todo, '... nor a TODO test';
433is $test->as_string, 'ok 2 - read the rest of the file',
434 '... and its string representation should be correct';
435is $test->raw, 'ok 2 - read the rest of the file',
436 '... and raw() should return the original line';
437
438is scalar $parser->passed, 2,
439 'Empty junk lines should not affect the correct number of tests passed';
440
a39e16d8 441# Check source => "tap content"
442can_ok $PARSER, 'new';
443$parser = $PARSER->new( { source => "1..1\nok 1\n" } );
444isa_ok $parser, $PARSER, '... and calling it should succeed';
445ok @results = _get_results($parser), 'The parser should return results';
446is( scalar @results, 2, "Got two lines of TAP" );
447
448# Check source => [array]
449can_ok $PARSER, 'new';
450$parser = $PARSER->new( { source => [ "1..1", "ok 1" ] } );
451isa_ok $parser, $PARSER, '... and calling it should succeed';
452ok @results = _get_results($parser), 'The parser should return results';
453is( scalar @results, 2, "Got two lines of TAP" );
454
455# Check source => $filehandle
456can_ok $PARSER, 'new';
457open my $fh, $ENV{PERL_CORE}
458 ? '../ext/Test-Harness/t/data/catme.1'
459 : 't/data/catme.1';
460$parser = $PARSER->new( { source => $fh } );
461isa_ok $parser, $PARSER, '... and calling it should succeed';
462ok @results = _get_results($parser), 'The parser should return results';
463is( scalar @results, 2, "Got two lines of TAP" );
464
b965d173 465{
466
467 # set a spool to write to
468 tie local *SPOOL, 'IO::c55Capture';
469
470 my $tap = <<'END_TAP';
471TAP version 13
4721..7
473ok 1 - input file opened
474... this is junk
475not ok first line of the input valid # todo some data
476# this is a comment
477ok 3 - read the rest of the file
478not ok 4 - this is a real failure
479 --- YAML!
480 ...
481ok 5 # skip we have no description
482ok 6 - you shall not pass! # TODO should have failed
483not ok 7 - Gandalf wins. Game over. # TODO 'bout time!
484END_TAP
485
486 {
487 my $parser = $PARSER->new(
488 { tap => $tap,
489 spool => \*SPOOL,
490 }
491 );
492
493 _get_results($parser);
494
495 my @spooled = tied(*SPOOL)->dump();
496
497 is @spooled, 24, 'coverage testing for spool attribute of parser';
498 is join( '', @spooled ), $tap, "spooled tap matches";
499 }
500
501 {
502 my $parser = $PARSER->new(
503 { tap => $tap,
504 spool => \*SPOOL,
505 }
506 );
507
508 $parser->callback( 'ALL', sub { } );
509
510 _get_results($parser);
511
512 my @spooled = tied(*SPOOL)->dump();
513
514 is @spooled, 24, 'coverage testing for spool attribute of parser';
515 is join( '', @spooled ), $tap, "spooled tap matches";
516 }
517}
518
519{
520
521 # _initialize coverage
522
523 my $x = bless [], 'kjsfhkjsdhf';
524
525 my @die;
526
527 eval {
528 local $SIG{__DIE__} = sub { push @die, @_ };
529
530 $PARSER->new();
531 };
532
533 is @die, 1, 'coverage testing for _initialize';
534
535 like pop @die, qr/PANIC:\s+could not determine stream at/,
536 '...and it failed as expected';
537
538 @die = ();
539
540 eval {
541 local $SIG{__DIE__} = sub { push @die, @_ };
542
543 $PARSER->new(
544 { stream => 'stream',
545 tap => 'tap',
546 source => 'source', # only one of these is allowed
547 }
548 );
549 };
550
551 is @die, 1, 'coverage testing for _initialize';
552
553 like pop @die,
554 qr/You may only choose one of 'exec', 'stream', 'tap' or 'source'/,
555 '...and it failed as expected';
556}
557
558{
559
560 # coverage of todo_failed
561
562 my $tap = <<'END_TAP';
563TAP version 13
5641..7
565ok 1 - input file opened
566... this is junk
567not ok first line of the input valid # todo some data
568# this is a comment
569ok 3 - read the rest of the file
570not ok 4 - this is a real failure
571 --- YAML!
572 ...
573ok 5 # skip we have no description
574ok 6 - you shall not pass! # TODO should have failed
575not ok 7 - Gandalf wins. Game over. # TODO 'bout time!
576END_TAP
577
578 my $parser = $PARSER->new( { tap => $tap } );
579
580 _get_results($parser);
581
582 my @warn;
583
584 eval {
585 local $SIG{__WARN__} = sub { push @warn, @_ };
586
587 $parser->todo_failed;
588 };
589
590 is @warn, 1, 'coverage testing of todo_failed';
591
592 like pop @warn,
593 qr/"todo_failed" is deprecated. Please use "todo_passed". See the docs[.]/,
594 '..and failed as expected'
595}
596
597{
598
599 # coverage testing for T::P::_initialize
600
601 # coverage of the source argument paths
602
603 # ref argument to source
604
605 my $parser = TAP::Parser->new( { source => [ split /$/, $tap ] } );
606
607 isa_ok $parser, 'TAP::Parser';
608
609 isa_ok $parser->_stream, 'TAP::Parser::Iterator::Array';
610
611 # uncategorisable argument to source
612 my @die;
613
614 eval {
615 local $SIG{__DIE__} = sub { push @die, @_ };
616
617 $parser = TAP::Parser->new( { source => 'nosuchfile' } );
618 };
619
620 is @die, 1, 'uncategorisable source';
621
622 like pop @die, qr/Cannot determine source for nosuchfile/,
623 '... and we died as expected';
624}
625
626{
627
628 # coverage test of perl source with switches
629
630 my $parser = TAP::Parser->new(
2a7f4b9b 631 { source => File::Spec->catfile(
27fc0087 632 ( $ENV{PERL_CORE}
f715bbfb 633 ? ( File::Spec->updir(), 'ext', 'Test-Harness' )
27fc0087 634 : ()
635 ),
636 't',
637 'sample-tests',
638 'simple'
2a7f4b9b 639 ),
b965d173 640 }
641 );
642
643 isa_ok $parser, 'TAP::Parser';
644
645 isa_ok $parser->_stream, 'TAP::Parser::Iterator::Process';
646
647 # Workaround for Mac OS X problem wrt closing the iterator without
648 # reading from it.
649 $parser->next;
650}
651
652{
653
654 # coverage testing for TAP::Parser::has_problems
655
656 # we're going to need to test lots of fragments of tap
657 # to cover all the different boolean tests
658
659 # currently covered are no problems and failed, so let's next test
660 # todo_passed
661
662 my $tap = <<'END_TAP';
663TAP version 13
6641..2
665ok 1 - input file opened
666ok 2 - Gandalf wins. Game over. # TODO 'bout time!
667END_TAP
668
669 my $parser = TAP::Parser->new( { tap => $tap } );
670
671 _get_results($parser);
672
f7c69158 673 ok !$parser->failed, 'parser didnt fail';
674 ok $parser->todo_passed, '... and todo_passed is true';
b965d173 675
f7c69158 676 ok !$parser->has_problems, '... and has_problems is false';
b965d173 677
678 # now parse_errors
679
680 $tap = <<'END_TAP';
681TAP version 13
6821..2
683SMACK
684END_TAP
685
686 $parser = TAP::Parser->new( { tap => $tap } );
687
688 _get_results($parser);
689
f7c69158 690 ok !$parser->failed, 'parser didnt fail';
691 ok !$parser->todo_passed, '... and todo_passed is false';
692 ok $parser->parse_errors, '... and parse_errors is true';
b965d173 693
f7c69158 694 ok $parser->has_problems, '... and has_problems';
b965d173 695
696 # Now wait and exit are hard to do in an OS platform-independent way, so
697 # we won't even bother
698
699 $tap = <<'END_TAP';
700TAP version 13
7011..2
702ok 1 - input file opened
703ok 2 - Gandalf wins
704END_TAP
705
706 $parser = TAP::Parser->new( { tap => $tap } );
707
708 _get_results($parser);
709
710 $parser->wait(1);
711
f7c69158 712 ok !$parser->failed, 'parser didnt fail';
713 ok !$parser->todo_passed, '... and todo_passed is false';
714 ok !$parser->parse_errors, '... and parse_errors is false';
b965d173 715
f7c69158 716 ok $parser->wait, '... and wait is set';
b965d173 717
f7c69158 718 ok $parser->has_problems, '... and has_problems';
b965d173 719
720 # and use the same for exit
721
722 $parser->wait(0);
723 $parser->exit(1);
724
f7c69158 725 ok !$parser->failed, 'parser didnt fail';
726 ok !$parser->todo_passed, '... and todo_passed is false';
727 ok !$parser->parse_errors, '... and parse_errors is false';
728 ok !$parser->wait, '... and wait is not set';
b965d173 729
f7c69158 730 ok $parser->exit, '... and exit is set';
b965d173 731
f7c69158 732 ok $parser->has_problems, '... and has_problems';
b965d173 733}
734
735{
736
737 # coverage testing of the version states
738
739 my $tap = <<'END_TAP';
740TAP version 12
7411..2
742ok 1 - input file opened
743ok 2 - Gandalf wins
744END_TAP
745
746 my $parser = TAP::Parser->new( { tap => $tap } );
747
748 _get_results($parser);
749
750 my @errors = $parser->parse_errors;
751
752 is @errors, 1, 'test too low version number';
753
754 like pop @errors,
755 qr/Explicit TAP version must be at least 13. Got version 12/,
756 '... and trapped expected version error';
757
758 # now too high a version
759 $tap = <<'END_TAP';
760TAP version 14
7611..2
762ok 1 - input file opened
763ok 2 - Gandalf wins
764END_TAP
765
766 $parser = TAP::Parser->new( { tap => $tap } );
767
768 _get_results($parser);
769
770 @errors = $parser->parse_errors;
771
772 is @errors, 1, 'test too high version number';
773
774 like pop @errors,
775 qr/TAP specified version 14 but we don't know about versions later than 13/,
776 '... and trapped expected version error';
777}
778
779{
780
781 # coverage testing of TAP version in the wrong place
782
783 my $tap = <<'END_TAP';
7841..2
785ok 1 - input file opened
786TAP version 12
787ok 2 - Gandalf wins
788END_TAP
789
790 my $parser = TAP::Parser->new( { tap => $tap } );
791
792 _get_results($parser);
793
794 my @errors = $parser->parse_errors;
795
796 is @errors, 1, 'test TAP version number in wrong place';
797
798 like pop @errors,
799 qr/If TAP version is present it must be the first line of output/,
800 '... and trapped expected version error';
801
802}
803
804{
805
806 # we're going to bash the internals a bit (but using the API as
807 # much as possible) to force grammar->tokenise() to fail
808
809 # firstly we'll create a stream that dies when its next_raw method is called
810
811 package TAP::Parser::Iterator::Dies;
812
813 use strict;
814 use vars qw(@ISA);
815
816 @ISA = qw(TAP::Parser::Iterator);
817
b965d173 818 sub next_raw {
819 die 'this is the dying iterator';
820 }
821
822 # required as part of the TPI interface
823 sub exit { }
824 sub wait { }
825
826 package main;
827
828 # now build a standard parser
829
830 my $tap = <<'END_TAP';
8311..2
832ok 1 - input file opened
833ok 2 - Gandalf wins
834END_TAP
835
836 {
837 my $parser = TAP::Parser->new( { tap => $tap } );
838
839 # build a dying stream
840 my $stream = TAP::Parser::Iterator::Dies->new;
841
842 # now replace the stream - we're forced to us an T::P intenal
843 # method for this
844 $parser->_stream($stream);
845
846 # build a new grammar
f7c69158 847 my $grammar = TAP::Parser::Grammar->new(
848 { stream => $stream,
849 parser => $parser
850 }
851 );
b965d173 852
853 # replace our grammar with this new one
854 $parser->_grammar($grammar);
855
856 # now call next on the parser, and the grammar should die
857 my $result = $parser->next; # will die in iterator
858
859 is $result, undef, 'iterator dies';
860
861 my @errors = $parser->parse_errors;
862 is @errors, 2, '...and caught expected errrors';
863
864 like shift @errors, qr/this is the dying iterator/,
865 '...and it was what we expected';
866 }
867
868 # Do it all again with callbacks to exercise the other code path in
869 # the unrolled iterator
870 {
871 my $parser = TAP::Parser->new( { tap => $tap } );
872
873 $parser->callback( 'ALL', sub { } );
874
875 # build a dying stream
876 my $stream = TAP::Parser::Iterator::Dies->new;
877
878 # now replace the stream - we're forced to us an T::P intenal
879 # method for this
880 $parser->_stream($stream);
881
882 # build a new grammar
f7c69158 883 my $grammar = TAP::Parser::Grammar->new(
884 { stream => $stream,
885 parser => $parser
886 }
887 );
b965d173 888
889 # replace our grammar with this new one
890 $parser->_grammar($grammar);
891
892 # now call next on the parser, and the grammar should die
893 my $result = $parser->next; # will die in iterator
894
895 is $result, undef, 'iterator dies';
896
897 my @errors = $parser->parse_errors;
898 is @errors, 2, '...and caught expected errrors';
899
900 like shift @errors, qr/this is the dying iterator/,
901 '...and it was what we expected';
902 }
903}
904
905{
906
907 # coverage testing of TAP::Parser::_next_state
908
909 package TAP::Parser::WithBrokenState;
910 use vars qw(@ISA);
911
912 @ISA = qw( TAP::Parser );
913
914 sub _make_state_table {
915 return { INIT => { plan => { goto => 'FOO' } } };
916 }
917
918 package main;
919
920 my $tap = <<'END_TAP';
9211..2
922ok 1 - input file opened
923ok 2 - Gandalf wins
924END_TAP
925
926 my $parser = TAP::Parser::WithBrokenState->new( { tap => $tap } );
927
928 my @die;
929
930 eval {
931 local $SIG{__DIE__} = sub { push @die, @_ };
932
933 $parser->next;
934 $parser->next;
935 };
936
937 is @die, 1, 'detect broken state machine';
938
939 like pop @die, qr/Illegal state: FOO/,
940 '...and the message is as we expect';
941}
942
943{
944
945 # coverage testing of TAP::Parser::_iter
946
947 package TAP::Parser::WithBrokenIter;
948 use vars qw(@ISA);
949
950 @ISA = qw( TAP::Parser );
951
952 sub _iter {return}
953
954 package main;
955
956 my $tap = <<'END_TAP';
9571..2
958ok 1 - input file opened
959ok 2 - Gandalf wins
960END_TAP
961
962 my $parser = TAP::Parser::WithBrokenIter->new( { tap => $tap } );
963
964 my @die;
965
966 eval {
967 local $SIG{__WARN__} = sub { };
968 local $SIG{__DIE__} = sub { push @die, @_ };
969
970 $parser->next;
971 };
972
973 is @die, 1, 'detect broken iter';
974
975 like pop @die, qr/Can't use/, '...and the message is as we expect';
976}
977
bdaf8c65 978SKIP: {
979
980 # http://markmail.org/message/rkxbo6ft7yorgnzb
981 skip "Crashes on older Perls", 2 if $] <= 5.008004 || $] == 5.009;
b965d173 982
983 # coverage testing of TAP::Parser::_finish
984
985 my $tap = <<'END_TAP';
9861..2
987ok 1 - input file opened
988ok 2 - Gandalf wins
989END_TAP
990
991 my $parser = TAP::Parser->new( { tap => $tap } );
992
993 $parser->tests_run(999);
994
995 my @die;
996
997 eval {
998 local $SIG{__DIE__} = sub { push @die, @_ };
999
1000 _get_results $parser;
1001 };
1002
1003 is @die, 1, 'detect broken test counts';
1004
1005 like pop @die,
1006 qr/Panic: planned test count [(]1001[)] did not equal sum of passed [(]0[)] and failed [(]2[)] tests!/,
1007 '...and the message is as we expect';
1008}
2a7f4b9b 1009
1010{
1011
1012 # Sanity check on state table
1013
1014 my $parser = TAP::Parser->new( { tap => "1..1\nok 1\n" } );
1015 my $state_table = $parser->_make_state_table;
1016 my @states = sort keys %$state_table;
1017 my @expect = sort qw(
1018 bailout comment plan pragma test unknown version yaml
1019 );
1020
1021 my %reachable = ( INIT => 1 );
1022
1023 for my $name (@states) {
1024 my $state = $state_table->{$name};
1025 my @can_handle = sort keys %$state;
1026 is_deeply \@can_handle, \@expect, "token types handled in $name";
1027 for my $type (@can_handle) {
1028 $reachable{$_}++
1029 for grep {defined}
1030 map { $state->{$type}->{$_} } qw(goto continue);
1031 }
1032 }
1033
1034 is_deeply [ sort keys %reachable ], [@states], "all states reachable";
1035}
f7c69158 1036
1037{
1038
1039 # exit, wait, ignore_exit interactions
1040
1041 my @truth = (
1042 [ 0, 0, 0, 0 ],
1043 [ 0, 0, 1, 0 ],
1044 [ 1, 0, 0, 1 ],
1045 [ 1, 0, 1, 0 ],
1046 [ 1, 1, 0, 1 ],
1047 [ 1, 1, 1, 0 ],
1048 [ 0, 1, 0, 1 ],
1049 [ 0, 1, 1, 0 ],
1050 );
1051
1052 for my $t (@truth) {
1053 my ( $wait, $exit, $ignore_exit, $has_problems ) = @$t;
1054 my $test_parser = sub {
1055 my $parser = shift;
1056 $parser->wait($wait);
1057 $parser->exit($exit);
1058 ok $has_problems ? $parser->has_problems : !$parser->has_problems,
1059 "exit=$exit, wait=$wait, ignore=$ignore_exit";
1060 };
1061
1062 my $parser = TAP::Parser->new( { tap => "1..1\nok 1\n" } );
1063 $parser->ignore_exit($ignore_exit);
1064 $test_parser->($parser);
1065
1066 $test_parser->(
1067 TAP::Parser->new(
1068 { tap => "1..1\nok 1\n", ignore_exit => $ignore_exit }
1069 )
1070 );
1071 }
1072}
Unnamed repository; edit this file to name it for gitweb.