File Coverage

blib/lib/TAP/DOM.pm
Criterion Covered Total %
statement 268 270 99.2
branch 152 178 85.3
condition 86 105 81.9
subroutine 26 26 100.0
pod 7 7 100.0
total 539 586 91.9


line stmt bran cond sub pod time code
1             package TAP::DOM;
2             # git description: v1.000-7-g37bf7ee
3              
4             our $AUTHORITY = 'cpan:SCHWIGON';
5             # ABSTRACT: TAP as Document Object Model.
6             $TAP::DOM::VERSION = '1.001';
7 25     25   3167956 use 5.006;
  25         99  
8 25     25   169 use strict;
  25         47  
  25         940  
9 25     25   123 use warnings;
  25         45  
  25         1549  
10              
11 25     25   11809 use TAP::DOM::Entry;
  25         72  
  25         1152  
12 25     25   11754 use TAP::DOM::Summary;
  25         81  
  25         1021  
13 25     25   14042 use TAP::DOM::DocumentData;
  25         71  
  25         884  
14 25     25   11747 use TAP::DOM::Config;
  25         69  
  25         1006  
15 25     25   16061 use TAP::Parser;
  25         1615378  
  25         1201  
16 25     25   13198 use TAP::Parser::Aggregator;
  25         192282  
  25         921  
17 25     25   13416 use YAML::Syck;
  25         54947  
  25         2347  
18 25     25   15370 use Data::Dumper;
  25         227686  
  25         5566  
19              
20             our $IS_PLAN = 1;
21             our $IS_OK = 2;
22             our $IS_TEST = 4;
23             our $IS_COMMENT = 8;
24             our $IS_UNKNOWN = 16;
25             our $IS_ACTUAL_OK = 32;
26             our $IS_VERSION = 64;
27             our $IS_PRAGMA = 128;
28             our $IS_UNPLANNED = 256;
29             our $IS_BAILOUT = 512;
30             our $IS_YAML = 1024;
31             our $HAS_SKIP = 2048;
32             our $HAS_TODO = 4096;
33              
34             our @tap_dom_args = (qw(ignore
35             ignorelines
36             dontignorelines
37             ignoreunknown
38             usebitsets
39             sparse
40             disable_global_kv_data
41             put_dangling_kv_data_under_lazy_plan
42             document_data_prefix
43             document_data_ignore
44             preprocess_ignorelines
45             preprocess_tap
46             noempty_tap
47             utf8
48             lowercase_fieldnames
49             lowercase_fieldvalues
50             trim_fieldvalues
51             normalize
52             ));
53              
54 25     25   10154 use parent 'Exporter';
  25         7072  
  25         184  
55             our @EXPORT_OK = qw( $IS_PLAN
56             $IS_OK
57             $IS_TEST
58             $IS_COMMENT
59             $IS_UNKNOWN
60             $IS_ACTUAL_OK
61             $IS_VERSION
62             $IS_PRAGMA
63             $IS_UNPLANNED
64             $IS_BAILOUT
65             $IS_YAML
66             $HAS_SKIP
67             $HAS_TODO
68             );
69             our %EXPORT_TAGS = (constants => [ qw( $IS_PLAN
70             $IS_OK
71             $IS_TEST
72             $IS_COMMENT
73             $IS_UNKNOWN
74             $IS_ACTUAL_OK
75             $IS_VERSION
76             $IS_PRAGMA
77             $IS_UNPLANNED
78             $IS_BAILOUT
79             $IS_YAML
80             $HAS_SKIP
81             $HAS_TODO
82             ) ] );
83              
84             our %mnemonic = (
85             severity => {
86             1 => 'ok',
87             2 => 'ok_todo',
88             3 => 'ok_skip',
89             4 => 'notok_todo',
90             5 => 'notok',
91             6 => 'notok_skip', # forbidden TAP semantic, should never happen
92             },
93             );
94              
95             # TAP severity level definition:
96             #
97             # |--------+---------------+----------+--------------+----------+------------+----------|
98             # | *type* | is_ok | has_todo | is_actual_ok | has_skip | *mnemonic* | *tapcon* |
99             # |--------+---------------+----------+--------------+----------+------------+----------|
100             # | plan | undef | undef | undef | 1 | ok_skip | 3 |
101             # |--------+---------------+----------+--------------+----------+------------+----------|
102             # | test | 1 | 0 | 0 | 0 | ok | 1 |
103             # | test | 1 | 1 | 1 | 0 | ok_todo | 2 |
104             # | test | 1 | 0 | 0 | 1 | ok_skip | 3 |
105             # | test | 1 | 1 | 0 | 0 | notok_todo | 4 |
106             # | test | 0 | 0 | 0 | 0 | notok | 5 |
107             # | test | 0 | 0 | 0 | 1 | notok_skip | 6 |
108             # |--------+---------------+----------+--------------+----------+------------+----------|
109             # | | | | | | missing | 0 |
110             # |--------+---------------+----------+--------------+----------+------------+----------|
111             # | *type* | *value* | | | | | |
112             # |--------+---------------+----------+--------------+----------+------------+----------|
113             # | pragma | +tapdom_error | | | | notok | 5 |
114             # |--------+---------------+----------+--------------+----------+------------+----------|
115              
116             our $severity = {};
117             #
118             # {type} {is_ok} {has_todo} {is_actual_ok} {has_skip} = $severity;
119             #
120             $severity->{plan} {0} {0} {0} {1} = 3; # ok_skip
121             $severity->{test} {1} {0} {0} {0} = 1; # ok
122             $severity->{test} {1} {1} {1} {0} = 2; # ok_todo
123             $severity->{test} {1} {0} {0} {1} = 3; # ok_skip
124             $severity->{test} {1} {1} {0} {0} = 4; # notok_todo
125             $severity->{test} {0} {0} {0} {0} = 5; # notok
126             $severity->{test} {0} {0} {0} {1} = 6; # notok_skip
127              
128             our $obvious_tap_line = qr/(1\.\.|ok\s|not\s+ok\s|#|\s|tap\s+version|pragma|Bail out!)/i;
129              
130             our $noempty_tap = "pragma +tapdom_error\n# document was empty";
131              
132             use Class::XSAccessor
133 25         321 chained => 1,
134             accessors => [qw( plan
135             lines
136             pragmas
137             tests_planned
138             tests_run
139             version
140             is_good_plan
141             skip_all
142             start_time
143             end_time
144             has_problems
145             exit
146             parse_errors
147             parse_errors_msgs
148             summary
149             tapdom_config
150             document_data
151 25     25   12295 )];
  25         49  
152              
153             sub _capture_group {
154 146     146   551 my ($s, $n) = @_; substr($s, $-[$n], $+[$n] - $-[$n]);
  146         889  
155             }
156              
157             sub normalize_tap_line {
158 267     267 1 49418 my ($line) = @_;
159              
160 267 100       1847 return $line unless $line =~ m/^(not\s+)?(ok)\s+/;
161              
162 257   50     2092 $line =~ s{^(not\s)?\s*(ok)\s+(\d+\s)?\s*(-\s+)?\s*}{($1//'').$2.' '}e;
  257         1705  
163 257         717 $line =~ s/['"]//g;
164 257         550 $line =~ s/\\(?!#\s*(todo|skip)\b)//gi;
165 257         969 $line =~ s/\s*(?
  76         260  
166 257         592 $line =~ s/^\s+//g;
167 257         941 $line =~ s/\s+$//g;
168              
169 257         948 return $line;
170             }
171              
172             # Optimize the TAP text before parsing it.
173             sub preprocess_ignorelines {
174 4     4 1 20 my %args = @_;
175              
176 4 50       32 if ($args{tap}) {
177              
178 4 50       22 if (my $ignorelines = $args{ignorelines}) {
179 4         12 my $dontignorelines = $args{dontignorelines};
180 4         10 my $tap = $args{tap};
181 4 100       16 if ($dontignorelines) {
182             # HIGHLY EXPERIMENTAL!
183             #
184             # We convert the 'dontignorelines' regex into a negative-lookahead
185             # condition and prepend it before the 'ignorelines'.
186             #
187             # Why? Because we want to utilize the cleanup in one single
188             # operation as fast as the regex engine can do it.
189 2 50       15 my $re_dontignorelines = $dontignorelines ? "(?!$dontignorelines)" : '';
190 2         91 my $re_filter = qr/^$re_dontignorelines$ignorelines.*[\r\n]*/m; # the /m scope needs to be here!
191 2         136 $tap =~ s/$re_filter//g;
192             } else {
193 2         66 $tap =~ s/^$ignorelines.*[\r\n]*//mg;
194             }
195 4         17 $args{tap} = $tap;
196 4         13 delete $args{ignorelines}; # don't try it again during parsing later
197             }
198             }
199              
200 4         24 return %args
201             }
202              
203             # Filter away obvious non-TAP lines before parsing it.
204             sub preprocess_tap {
205 4     4 1 18 my %args = @_;
206              
207 4 50       23 if ($args{tap}) {
208 4         13 my $tap = $args{tap};
209 4         404 $tap =~ s/^(?!$obvious_tap_line).*[\r\n]*//mg;
210 4         27 $args{tap} = $tap;
211             }
212              
213 4         29 return %args
214             }
215              
216             # Mark empty TAP with replacement lines
217             sub noempty_tap {
218 21     21 1 67 my %args = @_;
219              
220 21 100 100     291 if (defined($args{tap}) and $args{tap} eq '') {
    100 100        
221 3         9 $args{tap} = $noempty_tap;
222             }
223             elsif (defined($args{source}) and -z $args{source}) {
224 1         2 $args{tap} = $noempty_tap;
225 1         3 delete $args{source};
226             }
227              
228 21         101 return %args
229             }
230              
231             # Assume TAP is UTF-8 and filter out forbidden characters.
232             #
233             # Convert illegal chars into Unicode 'REPLACEMENT CHARACTER'
234             # (\N{U+FFFD} ... i.e. diamond with question mark in it).
235             #
236             # For more info see:
237             #
238             # - https://stackoverflow.com/a/2656433/1342345
239             # - https://metacpan.org/pod/Encode#FB_DEFAULT
240             # - https://en.wikipedia.org/wiki/Specials_(Unicode_block)#Replacement_character
241             #
242             # Additionall convert \0 as it's not covered by Encode::decode()
243             # but is still illegal for some tools.
244             sub utf8_tap {
245 2     2 1 8 my %args = @_;
246              
247 2 50       16 if ($args{source}) {
248 2         12 local $/;
249 2         3 my $F;
250 2 100       10 if (ref($args{source}) eq 'GLOB') {
251 1         4 $F = $args{source};
252             } else {
253 1         99 open $F, '<', $args{source};
254             }
255 2         77 $args{tap} = <$F>;
256 2         24 close $F;
257 2         17 delete $args{source};
258             }
259              
260 2 50       9 if ($args{tap}) {
261 2         21 require Encode;
262 2         25 $args{tap} = Encode::decode('UTF-8', $args{tap});
263 2         298 $args{tap} =~ s/\0/\N{U+FFFD}/g;
264 2         7 delete $args{utf8}; # don't try it again during parsing later
265             }
266 2         11 return %args
267             }
268              
269             sub new {
270             # hash or hash ref
271 77     77 1 8810107 my $class = shift;
272 77 50       623 my %args = @_ == 1 ? %{$_[0]} : @_;
  0         0  
273              
274 77         594 my @lines;
275             my $plan;
276 77         0 my $version;
277 77         0 my @pragmas;
278 77         0 my $bailout;
279 77         0 my %document_data;
280 77         0 my %dangling_kv_data;
281              
282 77 100       438 %args = preprocess_ignorelines(%args) if $args{preprocess_ignorelines};
283 77 100       349 %args = preprocess_tap(%args) if $args{preprocess_tap};
284 77 100       324 %args = noempty_tap(%args) if $args{noempty_tap};
285 77 100       325 %args = utf8_tap(%args) if $args{utf8};
286              
287 77         164 my %IGNORE = map { $_ => 1 } @{$args{ignore}};
  3         12  
  77         326  
288 77         203 my $IGNORELINES = $args{ignorelines};
289 77         159 my $DONTIGNORELINES = $args{dontignorelines};
290 77         166 my $IGNOREUNKNOWN = $args{ignoreunknown};
291 77         212 my $USEBITSETS = $args{usebitsets};
292 77         325 my $SPARSE = $args{sparse};
293 77         152 my $DISABLE_GLOBAL_KV_DATA = $args{disable_global_kv_data};
294 77         166 my $PUT_DANGLING_KV_DATA_UNDER_LAZY_PLAN = $args{put_dangling_kv_data_under_lazy_plan};
295 77   50     432 my $DOC_DATA_PREFIX = $args{document_data_prefix} || 'Test-';
296 77         169 my $DOC_DATA_IGNORE = $args{document_data_ignore};
297 77         195 my $LOWERCASE_FIELDNAMES = $args{lowercase_fieldnames};
298 77         168 my $LOWERCASE_FIELDVALUES = $args{lowercase_fieldvalues};
299 77         150 my $TRIM_FIELDVALUES = $args{trim_fieldvalues};
300 77         151 my $NOEMPTY_TAP = $args{noempty_tap};
301 77         164 my $NORMALIZE = $args{normalize};
302 77         180 delete $args{ignore};
303 77         146 delete $args{ignorelines};
304 77         147 delete $args{dontignorelines};
305 77         146 delete $args{ignoreunknown};
306 77         131 delete $args{usebitsets};
307 77         292 delete $args{sparse};
308 77         233 delete $args{disable_global_kv_data};
309 77         183 delete $args{put_dangling_kv_data_under_lazy_plan};
310 77         155 delete $args{document_data_prefix};
311 77         158 delete $args{document_data_ignore};
312 77         157 delete $args{preprocess_ignorelines};
313 77         220 delete $args{preprocess_tap};
314 77         136 delete $args{noempty_tap};
315 77         151 delete $args{utf8};
316 77         134 delete $args{lowercase_fieldnames};
317 77         134 delete $args{lowercase_fieldvalues};
318 77         126 delete $args{trim_fieldvalues};
319 77         138 delete $args{normalize};
320              
321 77         2556 my $document_data_regex = qr/^#\s*$DOC_DATA_PREFIX([^:]+)\s*:\s*(.*)$/;
322 77 100       466 my $document_data_ignore = defined($DOC_DATA_IGNORE) ? qr/$DOC_DATA_IGNORE/ : undef;
323              
324 77         1132 my $parser = TAP::Parser->new( { %args } );
325              
326 77         59664 my $aggregate = TAP::Parser::Aggregator->new;
327 77         6069 $aggregate->start;
328              
329 77         3815 my $count_tap_lines = 0;
330 77         156 my $found_pragma_tapdom_error = 0;
331 77         1782 while ( my $result = $parser->next ) {
332 25     25   67701 no strict 'refs';
  25         47  
  25         22308  
333              
334 810 100 100     239382 next if $IGNORELINES && $result->raw =~ m/$IGNORELINES/ && !($DONTIGNORELINES && $result->raw =~ m/$DONTIGNORELINES/);
      100        
      100        
335 784 100 100     2092 next if $IGNOREUNKNOWN and $result->is_unknown;
336              
337 782         3082 my $entry = TAP::DOM::Entry->new;
338 782 100       1797 $entry->{is_has} = 0 if $USEBITSETS;
339              
340             # test info
341 782         1662 foreach (qw(type raw as_string )) {
342 2346 100       11842 $entry->{$_} = $result->$_ unless $IGNORE{$_};
343             }
344 782 100       8941 $entry->{normalized} = $result->is_test ? normalize_tap_line($result->raw) : $result->raw;
345              
346 782 100       5458 if ($result->is_test) {
347 257         1821 foreach (qw(directive explanation number description )) {
348 1028 100       6779 $entry->{$_} = $result->$_ unless $IGNORE{$_};
349             }
350 257         1268 foreach (qw(is_ok is_unplanned )) {
351 514 100       5223 if ($USEBITSETS) {
    100          
352 8 100       31 $entry->{is_has} |= $result->$_ ? ${uc $_} : 0 unless $IGNORE{$_};
  4 50       81  
353             } elsif ($SPARSE) {
354             # don't set 'false' fields at all in sparse mode
355 8 100 66     19 $entry->{$_} = 1 if $result->$_ and not $IGNORE{$_};
356             } else {
357 498 100       1518 $entry->{$_} = $result->$_ ? 1 : 0 unless $IGNORE{$_};
    50          
358             }
359             }
360             }
361              
362             # plan
363 782 100       5317 if ($result->is_plan) {
364 68         486 $plan = $result->as_string;
365 68         329 foreach (qw(directive explanation)) {
366 136 100       760 $entry->{$_} = $result->$_ unless $IGNORE{$_};
367             }
368              
369             # save Dangling kv_data to plan entry. The situation
370             # that we already collected kv_data but haven't got
371             # a plan yet should only happen in documents with
372             # lazy plans (plan at the end).
373 68 0 33     699 if ($PUT_DANGLING_KV_DATA_UNDER_LAZY_PLAN and keys %dangling_kv_data) {
374 0         0 $entry->{kv_data}{$_} = $dangling_kv_data{$_} foreach keys %dangling_kv_data;
375             }
376             }
377              
378             # meta info
379 782         4105 foreach ((qw(has_skip has_todo))) {
380 1564 100       6035 if ($USEBITSETS) {
    100          
381 14 100       51 $entry->{is_has} |= $result->$_ ? ${uc $_} : 0 unless $IGNORE{$_};
  2 50       12  
382             } elsif ($SPARSE) {
383             # don't set 'false' fields at all in sparse mode
384 14 100 66     39 $entry->{$_} = 1 if $result->$_ and not $IGNORE{$_};
385             } else {
386 1536 100       4586 $entry->{$_} = $result->$_ ? 1 : 0 unless $IGNORE{$_};
    50          
387             }
388             }
389             # Idea:
390             # use constants
391             # map to constants
392             # then loop
393 782         4080 foreach (qw( is_pragma is_comment is_bailout is_plan
394             is_version is_yaml is_unknown is_test))
395             {
396 6256 100       35162 if ($USEBITSETS) {
    100          
397 56 100       174 $entry->{is_has} |= $result->$_ ? ${uc $_} : 0 unless $IGNORE{$_};
  7 50       55  
398             } elsif ($SPARSE) {
399             # don't set 'false' fields at all in sparse mode
400 56 100 66     139 $entry->{$_} = 1 if $result->$_ and not $IGNORE{$_};
401             } else {
402 6144 100       17029 $entry->{$_} = $result->$_ ? 1 : 0 unless $IGNORE{$_};
    50          
403             }
404             }
405 782 50       5169 if (! $IGNORE{is_actual_ok}) {
406             # XXX:
407             # I think it's confusing when the value of
408             # "is_actual_ok" only has a meaning when
409             # "has_todo" is true.
410             # This makes it difficult to evaluate later.
411             # But it's aligned with TAP::Parser
412             # which also sets this only on "has_todo".
413             #
414             # Maybe the problem is a general philosophical one
415             # in TAP::DOM to always have each hashkey existing.
416             # Hmmm...
417 782 100 100     1681 my $is_actual_ok = ($result->has_todo && $result->is_actual_ok) ? 1 : 0;
418 782 100       4595 if ($USEBITSETS) {
    100          
419 7 100       68 $entry->{is_has} |= $is_actual_ok ? $IS_ACTUAL_OK : 0;
420             } elsif ($SPARSE) {
421             # don't set 'false' fields at all in sparse mode
422 7 100       21 $entry->{is_actual_ok} = 1 if $is_actual_ok;
423             } else {
424 768         1777 $entry->{is_actual_ok} = $is_actual_ok;
425             }
426             }
427 782 100 66     1542 $entry->{data} = $result->data if $result->is_yaml && !$IGNORE{data};
428              
429 782 100 100     5006 if ($result->is_comment and $result->as_string =~ $document_data_regex)
430             {{ # extra block for 'last'
431             # we can't use $1, $2 because the regex could contain configured other groups
432 73         1264 my ($key, $value) = (_capture_group($result->as_string, -2), _capture_group($result->as_string, -1));
  73         196  
433 73         314 $key =~ s/^\s+//; # strip leading whitespace
434 73         159 $key =~ s/\s+$//; # strip trailing whitespace
435              
436             # optional lowercase
437 73 100       169 $key = lc $key if $LOWERCASE_FIELDNAMES;
438 73 100       148 $value = lc $value if $LOWERCASE_FIELDVALUES;
439              
440             # optional value trimming
441 73 100       139 $value =~ s/\s+$// if $TRIM_FIELDVALUES; # there can be no leading whitespace
442              
443             # skip this field according to regex
444 73 100 66     384 last if $DOC_DATA_IGNORE and $document_data_ignore and $key =~ $document_data_ignore;
      100        
445              
446             # Store "# Test-key: value" entries also as
447             # 'kv_data' under their parent line.
448             # That line should be a test or a plan line, so that its
449             # place (or "data path") is structurally always the same.
450 66 100 100     206 if ($lines[-1]->is_test or $lines[-1]->is_plan or $lines[-1]->is_pragma) {
      100        
451 56         191 $lines[-1]->{kv_data}{$key} = $value;
452             } else {
453 10 50       25 if (!$plan) {
454             # We haven't got a plan yet, so that
455             # kv_data entry would get lost. As we
456             # might still get a lazy plan at end
457             # of document, so we save it up for
458             # that potential plan entry.
459 10         29 $dangling_kv_data{$key} = $value;
460             }
461             }
462 66 50 66     149 $document_data{$key} = $value unless $lines[-1]->is_test && $DISABLE_GLOBAL_KV_DATA;
463             }}
464              
465             # calculate severity
466 782 100 100     8539 if ($entry->{is_test} or $entry->{is_plan}) {
467 25     25   201 no warnings 'uninitialized';
  25         59  
  25         3058  
468 320         535 $count_tap_lines++;
469             $entry->{severity} = $severity
470             ->{$entry->{type}}
471             ->{$entry->{is_ok}||0}
472             ->{$entry->{has_todo}||0}
473             ->{$entry->{is_actual_ok}||0}
474 320   100     4661 ->{$entry->{has_skip}||0};
      100        
      100        
      100        
475             }
476              
477 782 100 100     2940 if ($entry->{is_pragma} or $entry->{is_unknown}) {
478 25     25   247 no warnings 'uninitialized';
  25         68  
  25         41030  
479 33 100       166 if ($entry->{raw} =~ /^pragma\s+\+tapdom_error\s*$/) {
480 6         12 $found_pragma_tapdom_error=1;
481 6         38 $entry->{severity} = 5;
482 6         15 $entry->{is_pragma} = 1;
483 6         25 $entry->{type} = 'pragma';
484 6         16 delete $entry->{is_unknown};
485             } else {
486 27         58 $entry->{severity} = 0;
487             }
488             }
489 782 100       2079 $entry->{severity} = 0 if not defined $entry->{severity};
490              
491             # yaml and comments are taken as children of the line before
492 782 100 100     1705 if ($result->is_yaml or $result->is_comment and @lines)
      100        
493             {
494 384         4113 push @{ $lines[-1]->{_children} }, $entry;
  384         2915  
495             }
496             else
497             {
498 398         6998 push @lines, $entry;
499             }
500             }
501 77         26909 @pragmas = $parser->pragmas;
502              
503 77 100 100     1005 if (!$count_tap_lines and !$found_pragma_tapdom_error and $NOEMPTY_TAP) {
      100        
504             # pragma +tapdom_error
505 2 50       35 my $error_entry = TAP::DOM::Entry->new(
506             ($SPARSE ? () : (
507             'is_version' => 0,
508             'is_plan' => 0,
509             'is_test' => 0,
510             'is_comment' => 0,
511             'is_yaml' => 0,
512             'is_unknown' => 0,
513             'is_bailout' => 0,
514             'is_actual_ok' => 0,
515             'has_todo' => 0,
516             'has_skip' => 0,
517             )),
518             'is_pragma' => 1,
519             'type' => 'pragma',
520             'raw' => 'pragma +tapdom_error',
521             'as_string' => 'pragma +tapdom_error',
522             'severity' => 5,
523             );
524 2 50       6 $error_entry->{is_has} = $IS_PRAGMA if $USEBITSETS;
525 2 50       8 foreach (qw(raw type as_string explanation)) { delete $error_entry->{$_} if $IGNORE{$_} }
  8         17  
526             # pragma +tapdom_error
527 2 50       25 my $error_comment = TAP::DOM::Entry->new(
528             ($SPARSE ? () : (
529             'is_version' => 0,
530             'is_plan' => 0,
531             'is_test' => 0,
532             'is_yaml' => 0,
533             'is_unknown' => 0,
534             'is_bailout' => 0,
535             'is_actual_ok' => 0,
536             'is_pragma' => 0,
537             'has_todo' => 0,
538             'has_skip' => 0,
539             )),
540             'is_comment' => 1,
541             'type' => 'comment',
542             'raw' => '# no tap lines',
543             'as_string' => '# no tap lines',
544             'severity' => 0,
545             );
546 2 50       7 $error_comment->{is_has} = $IS_COMMENT if $USEBITSETS;
547 2 50       8 foreach (qw(raw type as_string explanation)) { delete $error_comment->{$_} if $IGNORE{$_} }
  8         17  
548 2   50     14 $error_entry->{_children} //= [];
549 2         4 push @{$error_entry->{_children}}, $error_comment;
  2         6  
550 2         4 push @lines, $error_entry;
551 2         7 push @pragmas, 'tapdom_error';
552             }
553              
554 77         472 $aggregate->add( main => $parser );
555 77         11312 $aggregate->stop;
556              
557 77 100       2221 my $summary = TAP::DOM::Summary->new
    100          
    100          
558             (
559             failed => scalar $aggregate->failed,
560             parse_errors => scalar $aggregate->parse_errors,
561             planned => scalar $aggregate->planned,
562             passed => scalar $aggregate->passed,
563             skipped => scalar $aggregate->skipped,
564             todo => scalar $aggregate->todo,
565             todo_passed => scalar $aggregate->todo_passed,
566             wait => scalar $aggregate->wait,
567             exit => scalar $aggregate->exit,
568             elapsed => $aggregate->elapsed,
569             elapsed_timestr => $aggregate->elapsed_timestr,
570             all_passed => $aggregate->all_passed ? 1 : 0,
571             status => $aggregate->get_status,
572             total => $aggregate->total,
573             has_problems => $aggregate->has_problems ? 1 : 0,
574             has_errors => $aggregate->has_errors ? 1 : 0,
575             );
576              
577 77         24627 my $tapdom_config = TAP::DOM::Config->new
578             (
579             ignore => \%IGNORE,
580             ignorelines => $IGNORELINES,
581             dontignorelines => $DONTIGNORELINES,
582             usebitsets => $USEBITSETS,
583             sparse => $SPARSE,
584             disable_global_kv_data => $DISABLE_GLOBAL_KV_DATA,
585             put_dangling_kv_data_under_lazy_plan => $PUT_DANGLING_KV_DATA_UNDER_LAZY_PLAN,
586             document_data_prefix => $DOC_DATA_PREFIX,
587             document_data_ignore => $DOC_DATA_IGNORE,
588             lowercase_fieldnames => $LOWERCASE_FIELDNAMES,
589             lowercase_fieldvalues => $LOWERCASE_FIELDVALUES,
590             trim_fieldvalues => $TRIM_FIELDVALUES,
591             noempty_tap => $NOEMPTY_TAP,
592             );
593              
594 77         549 my $document_data = TAP::DOM::DocumentData->new(%document_data);
595              
596 77         395 my $tapdata = {
597             plan => $plan,
598             lines => \@lines,
599             pragmas => \@pragmas,
600             tests_planned => $parser->tests_planned,
601             tests_run => $parser->tests_run,
602             version => $parser->version,
603             is_good_plan => $parser->is_good_plan,
604             skip_all => $parser->skip_all,
605             start_time => $parser->start_time,
606             end_time => $parser->end_time,
607             has_problems => $parser->has_problems,
608             exit => $parser->exit,
609             parse_errors => scalar $parser->parse_errors,
610             parse_errors_msgs => [ $parser->parse_errors ],
611             summary => $summary,
612             tapdom_config => $tapdom_config,
613             document_data => $document_data,
614             };
615 77         9705 return bless $tapdata, $class;
616             }
617              
618             sub _entry_to_tapline
619             {
620 40     40   68 my ($self, $entry) = @_;
621              
622 40         66 my %IGNORE = %{$self->{tapdom_config}{ignore}};
  40         87  
623              
624 40         64 my $tapline = "";
625              
626             # ok/notok test lines
627 40 100 100     270 if ($entry->{is_test})
    100 66        
      33        
628             {
629             $tapline = join(" ",
630             # the original "NOT" is more difficult to reconstruct than it should...
631             ($entry->{has_todo}
632             ? $entry->{is_actual_ok} ? () : "not"
633             : $entry->{is_ok} ? () : "not"),
634             "ok",
635             ($entry->{number} || ()),
636             ($entry->{description} || ()),
637             ($entry->{has_skip} ? "# SKIP ".($entry->{explanation} || "")
638 16 100 33     238 : $entry->{has_todo }? "# TODO ".($entry->{explanation} || "")
    50 66        
    100 50        
    100 50        
    100          
639             : ()),
640             );
641             }
642             # pragmas and meta lines, but no version nor plan
643             elsif ($entry->{is_pragma} ||
644             $entry->{is_comment} ||
645             $entry->{is_bailout} ||
646             $entry->{is_yaml})
647             {
648 20 50       56 $tapline = $IGNORE{raw} ? $entry->{as_string} : $entry->{raw}; # if "raw" was 'ignored' try "as_string"
649             }
650 40         85 return $tapline;
651             }
652              
653             sub _lines_to_tap
654             {
655 8     8   17 my ($self, $lines) = @_;
656              
657 8         16 my @taplines;
658 8         23 foreach my $entry (@$lines)
659             {
660 40         84 my $tapline = $self->_entry_to_tapline($entry);
661 40 100       101 push @taplines, $tapline if $tapline;
662 40 100       117 push @taplines, $self->_lines_to_tap($entry->{_children}) if $entry->{_children};
663             }
664 8         40 return @taplines;
665             }
666              
667             sub to_tap
668             {
669 2     2 1 2491 my ($self) = @_;
670              
671 2         15 my @taplines = $self->_lines_to_tap($self->{lines});
672 2         10 unshift @taplines, $self->{plan};
673 2         9 unshift @taplines, "TAP version ".$self->{version};
674              
675             return wantarray
676             ? @taplines
677 2 100       25 : join("\n", @taplines)."\n";
678             }
679              
680             1; # End of TAP::DOM
681              
682             __END__