File Coverage

blib/lib/TAP/DOM.pm
Criterion Covered Total %
statement 204 206 99.0
branch 117 134 87.3
condition 57 72 79.1
subroutine 24 24 100.0
pod 5 5 100.0
total 407 441 92.2


line stmt bran cond sub pod time code
1             package TAP::DOM;
2             # git description: v0.96-1-g9b41662
3              
4             our $AUTHORITY = 'cpan:SCHWIGON';
5             # ABSTRACT: TAP as Document Object Model.
6             $TAP::DOM::VERSION = '0.97';
7 19     19   894213 use 5.006;
  19         183  
8 19     19   83 use strict;
  19         34  
  19         371  
9 19     19   89 use warnings;
  19         35  
  19         470  
10              
11 19     19   5862 use TAP::DOM::Entry;
  19         31  
  19         430  
12 19     19   5834 use TAP::DOM::Summary;
  19         34  
  19         437  
13 19     19   5562 use TAP::DOM::DocumentData;
  19         175  
  19         393  
14 19     19   5450 use TAP::DOM::Config;
  19         32  
  19         415  
15 19     19   8224 use TAP::Parser;
  19         733170  
  19         541  
16 19     19   6635 use TAP::Parser::Aggregator;
  19         90991  
  19         479  
17 19     19   6743 use YAML::Syck;
  19         26032  
  19         911  
18 19     19   7870 use Data::Dumper;
  19         88880  
  19         2463  
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             usebitsets
38             disable_global_kv_data
39             put_dangling_kv_data_under_lazy_plan
40             document_data_prefix
41             document_data_ignore
42             preprocess_ignorelines
43             preprocess_tap
44             noempty_tap
45             lowercase_fieldnames
46             lowercase_fieldvalues
47             trim_fieldvalues
48             ));
49              
50 19     19   5719 use parent 'Exporter';
  19         4399  
  19         87  
51             our @EXPORT_OK = qw( $IS_PLAN
52             $IS_OK
53             $IS_TEST
54             $IS_COMMENT
55             $IS_UNKNOWN
56             $IS_ACTUAL_OK
57             $IS_VERSION
58             $IS_PRAGMA
59             $IS_UNPLANNED
60             $IS_BAILOUT
61             $IS_YAML
62             $HAS_SKIP
63             $HAS_TODO
64             );
65             our %EXPORT_TAGS = (constants => [ qw( $IS_PLAN
66             $IS_OK
67             $IS_TEST
68             $IS_COMMENT
69             $IS_UNKNOWN
70             $IS_ACTUAL_OK
71             $IS_VERSION
72             $IS_PRAGMA
73             $IS_UNPLANNED
74             $IS_BAILOUT
75             $IS_YAML
76             $HAS_SKIP
77             $HAS_TODO
78             ) ] );
79              
80             our %mnemonic = (
81             severity => {
82             1 => 'ok',
83             2 => 'ok_todo',
84             3 => 'ok_skip',
85             4 => 'notok_todo',
86             5 => 'notok',
87             6 => 'notok_skip', # forbidden TAP semantic, should never happen
88             },
89             );
90              
91             # TAP severity level definition:
92             #
93             # |--------+---------------+----------+--------------+----------+------------+----------|
94             # | *type* | is_ok | has_todo | is_actual_ok | has_skip | *mnemonic* | *tapcon* |
95             # |--------+---------------+----------+--------------+----------+------------+----------|
96             # | plan | undef | undef | undef | 1 | ok_skip | 3 |
97             # |--------+---------------+----------+--------------+----------+------------+----------|
98             # | test | 1 | 0 | 0 | 0 | ok | 1 |
99             # | test | 1 | 1 | 1 | 0 | ok_todo | 2 |
100             # | test | 1 | 0 | 0 | 1 | ok_skip | 3 |
101             # | test | 1 | 1 | 0 | 0 | notok_todo | 4 |
102             # | test | 0 | 0 | 0 | 0 | notok | 5 |
103             # | test | 0 | 0 | 0 | 1 | notok_skip | 6 |
104             # |--------+---------------+----------+--------------+----------+------------+----------|
105             # | | | | | | missing | 0 |
106             # |--------+---------------+----------+--------------+----------+------------+----------|
107             # | *type* | *value* | | | | | |
108             # |--------+---------------+----------+--------------+----------+------------+----------|
109             # | pragma | +tapdom_error | | | | notok | 5 |
110             # |--------+---------------+----------+--------------+----------+------------+----------|
111              
112             our $severity = {};
113             #
114             # {type} {is_ok} {has_todo} {is_actual_ok} {has_skip} = $severity;
115             #
116             $severity->{plan} {''} {0} {0} {1} = 3; # ok_skip
117             $severity->{test} {1} {0} {0} {0} = 1; # ok
118             $severity->{test} {1} {1} {1} {0} = 2; # ok_todo
119             $severity->{test} {1} {0} {0} {1} = 3; # ok_skip
120             $severity->{test} {1} {1} {0} {0} = 4; # notok_todo
121             $severity->{test} {0} {0} {0} {0} = 5; # notok
122             $severity->{test} {0} {0} {0} {1} = 6; # notok_skip
123              
124             our $obvious_tap_line = qr/(1\.\.|ok\s|not\s+ok\s|#|\s|tap\s+version|pragma|Bail out!)/i;
125              
126             our $noempty_tap = "pragma +tapdom_error\n# document was empty";
127              
128             use Class::XSAccessor
129 19         197 chained => 1,
130             accessors => [qw( plan
131             lines
132             pragmas
133             tests_planned
134             tests_run
135             version
136             is_good_plan
137             skip_all
138             start_time
139             end_time
140             has_problems
141             exit
142             parse_errors
143             parse_errors_msgs
144             summary
145             tapdom_config
146             document_data
147 19     19   4395 )];
  19         36  
148              
149             sub _capture_group {
150 138     138   394 my ($s, $n) = @_; substr($s, $-[$n], $+[$n] - $-[$n]);
  138         549  
151             }
152              
153             # Optimize the TAP text before parsing it.
154             sub preprocess_ignorelines {
155 4     4 1 11 my %args = @_;
156              
157 4 50       10 if ($args{tap}) {
158              
159 4 50       12 if (my $ignorelines = $args{ignorelines}) {
160 4         6 my $dontignorelines = $args{dontignorelines};
161 4         5 my $tap = $args{tap};
162 4 100       9 if ($dontignorelines) {
163             # HIGHLY EXPERIMENTAL!
164             #
165             # We convert the 'dontignorelines' regex into a negative-lookahead
166             # condition and prepend it before the 'ignorelines'.
167             #
168             # Why? Because we want to utilize the cleanup in one single
169             # operation as fast as the regex engine can do it.
170 2 50       7 my $re_dontignorelines = $dontignorelines ? "(?!$dontignorelines)" : '';
171 2         30 my $re_filter = qr/^$re_dontignorelines$ignorelines.*[\r\n]*/m; # the /m scope needs to be here!
172 2         56 $tap =~ s/$re_filter//g;
173             } else {
174 2         37 $tap =~ s/^$ignorelines.*[\r\n]*//mg;
175             }
176 4         8 $args{tap} = $tap;
177 4         8 delete $args{ignorelines}; # don't try it again during parsing later
178             }
179             }
180              
181 4         14 return %args
182             }
183              
184             # Filter away obvious non-TAP lines before parsing it.
185             sub preprocess_tap {
186 4     4 1 8 my %args = @_;
187              
188 4 50       12 if ($args{tap}) {
189 4         8 my $tap = $args{tap};
190 4         125 $tap =~ s/^(?!$obvious_tap_line).*[\r\n]*//mg;
191 4         11 $args{tap} = $tap;
192             }
193              
194 4         15 return %args
195             }
196              
197             # Mark empty TAP with replacement lines
198             sub noempty_tap {
199 17     17 1 33 my %args = @_;
200              
201 17 100 100     92 if (defined($args{tap}) and $args{tap} eq '') {
    100 66        
202 3         5 $args{tap} = $noempty_tap;
203             }
204             elsif (defined($args{source}) and -z $args{source}) {
205 1         2 $args{tap} = $noempty_tap;
206 1         2 delete $args{source};
207             }
208              
209 17         48 return %args
210             }
211              
212             sub new {
213             # hash or hash ref
214 64     64 1 139910 my $class = shift;
215 64 50       249 my %args = @_ == 1 ? %{$_[0]} : @_;
  0         0  
216              
217 64         292 my @lines;
218             my $plan;
219 64         0 my $version;
220 64         0 my @pragmas;
221 64         0 my $bailout;
222 64         0 my %document_data;
223 64         0 my %dangling_kv_data;
224              
225 64 100       152 %args = preprocess_ignorelines(%args) if $args{preprocess_ignorelines};
226 64 100       132 %args = preprocess_tap(%args) if $args{preprocess_tap};
227 64 100       141 %args = noempty_tap(%args) if $args{noempty_tap};
228              
229 64         85 my %IGNORE = map { $_ => 1 } @{$args{ignore}};
  3         6  
  64         145  
230 64         96 my $IGNORELINES = $args{ignorelines};
231 64         82 my $DONTIGNORELINES = $args{dontignorelines};
232 64         69 my $USEBITSETS = $args{usebitsets};
233 64         70 my $DISABLE_GLOBAL_KV_DATA = $args{disable_global_kv_data};
234 64         80 my $PUT_DANGLING_KV_DATA_UNDER_LAZY_PLAN = $args{put_dangling_kv_data_under_lazy_plan};
235 64   50     207 my $DOC_DATA_PREFIX = $args{document_data_prefix} || 'Test-';
236 64         76 my $DOC_DATA_IGNORE = $args{document_data_ignore};
237 64         75 my $LOWERCASE_FIELDNAMES = $args{lowercase_fieldnames};
238 64         72 my $LOWERCASE_FIELDVALUES = $args{lowercase_fieldvalues};
239 64         120 my $TRIM_FIELDVALUES = $args{trim_fieldvalues};
240 64         273 my $NOEMPTY_TAP = $args{noempty_tap};
241 64         95 delete $args{ignore};
242 64         70 delete $args{ignorelines};
243 64         66 delete $args{dontignorelines};
244 64         65 delete $args{usebitsets};
245 64         160 delete $args{disable_global_kv_data};
246 64         71 delete $args{put_dangling_kv_data_under_lazy_plan};
247 64         66 delete $args{document_data_prefix};
248 64         68 delete $args{document_data_ignore};
249 64         63 delete $args{preprocess_ignorelines};
250 64         56 delete $args{preprocess_tap};
251 64         65 delete $args{noempty_tap};
252 64         62 delete $args{lowercase_fieldnames};
253 64         61 delete $args{lowercase_fieldvalues};
254 64         154 delete $args{trim_fieldvalues};
255              
256 64         594 my $document_data_regex = qr/^#\s*$DOC_DATA_PREFIX([^:]+)\s*:\s*(.*)$/;
257 64 100       172 my $document_data_ignore = defined($DOC_DATA_IGNORE) ? qr/$DOC_DATA_IGNORE/ : undef;
258              
259 64         391 my $parser = new TAP::Parser( { %args } );
260              
261 64         25964 my $aggregate = new TAP::Parser::Aggregator;
262 64         2852 $aggregate->start;
263              
264 64         1402 while ( my $result = $parser->next ) {
265 19     19   22073 no strict 'refs';
  19         33  
  19         8280  
266              
267 651 100 100     105420 next if $IGNORELINES && $result->raw =~ m/$IGNORELINES/ && !($DONTIGNORELINES && $result->raw =~ m/$DONTIGNORELINES/);
      100        
      100        
268              
269 625         1411 my $entry = TAP::DOM::Entry->new;
270 625 100       849 $entry->{is_has} = 0 if $USEBITSETS;
271              
272             # test info
273 625         784 foreach (qw(type raw as_string )) {
274 1875 100       5712 $entry->{$_} = $result->$_ unless $IGNORE{$_};
275             }
276              
277 625 100       3851 if ($result->is_test) {
278 169         673 foreach (qw(directive explanation number description )) {
279 676 100       1954 $entry->{$_} = $result->$_ unless $IGNORE{$_};
280             }
281 169         465 foreach (qw(is_ok is_unplanned )) {
282 338 100       1993 if ($USEBITSETS) {
283 8 100       18 $entry->{is_has} |= $result->$_ ? ${uc $_} : 0 unless $IGNORE{$_};
  4 50       41  
284             } else {
285 330 100       664 $entry->{$_} = $result->$_ ? 1 : 0 unless $IGNORE{$_};
    50          
286             }
287             }
288             }
289              
290             # plan
291 625 100       2924 if ($result->is_plan) {
292 58         259 $plan = $result->as_string;
293 58         167 foreach (qw(directive explanation)) {
294 116 100       429 $entry->{$_} = $result->$_ unless $IGNORE{$_};
295             }
296              
297             # save Dangling kv_data to plan entry. The situation
298             # that we already collected kv_data but haven't got
299             # a plan yet should only happen in documents with
300             # lazy plans (plan at the end).
301 58 50 33     251 if ($PUT_DANGLING_KV_DATA_UNDER_LAZY_PLAN and keys %dangling_kv_data) {
302 0         0 $entry->{kv_data}{$_} = $dangling_kv_data{$_} foreach keys %dangling_kv_data;
303             }
304             }
305              
306             # meta info
307 625         2205 foreach ((qw(has_skip has_todo))) {
308 1250 100       2815 if ($USEBITSETS) {
309 14 100       73 $entry->{is_has} |= $result->$_ ? ${uc $_} : 0 unless $IGNORE{$_};
  2 50       8  
310             } else {
311 1236 100       2375 $entry->{$_} = $result->$_ ? 1 : 0 unless $IGNORE{$_};
    50          
312             }
313             }
314             # Idea:
315             # use constants
316             # map to constants
317             # then loop
318 625         2112 foreach (qw( is_pragma is_comment is_bailout is_plan
319             is_version is_yaml is_unknown is_test))
320             {
321 5000 100       16889 if ($USEBITSETS) {
322 56 100       102 $entry->{is_has} |= $result->$_ ? ${uc $_} : 0 unless $IGNORE{$_};
  7 50       39  
323             } else {
324 4944 100       8769 $entry->{$_} = $result->$_ ? 1 : 0 unless $IGNORE{$_};
    50          
325             }
326             }
327 625 50       2552 if (! $IGNORE{is_actual_ok}) {
328             # XXX:
329             # I think it's confusing when the value of
330             # "is_actual_ok" only has a meaning when
331             # "has_todo" is true.
332             # This makes it difficult to evaluate later.
333             # But it's aligned with TAP::Parser
334             # which also sets this only on "has_todo".
335             #
336             # Maybe the problem is a general philosophical one
337             # in TAP::DOM to always have each hashkey existing.
338             # Hmmm...
339 625 100 100     826 my $is_actual_ok = ($result->has_todo && $result->is_actual_ok) ? 1 : 0;
340 625 100       2068 if ($USEBITSETS) {
341 7 100       11 $entry->{is_has} |= $is_actual_ok ? $IS_ACTUAL_OK : 0;
342             } else {
343 618         815 $entry->{is_actual_ok} = $is_actual_ok;
344             }
345             }
346 625 100 66     859 $entry->{data} = $result->data if $result->is_yaml && !$IGNORE{data};
347              
348 625 100 100     2761 if ($result->is_comment and $result->as_string =~ $document_data_regex)
349             {{ # extra block for 'last'
350             # we can't use $1, $2 because the regex could contain configured other groups
351 69         680 my ($key, $value) = (_capture_group($result->as_string, -2), _capture_group($result->as_string, -1));
  69         142  
352 69         176 $key =~ s/^\s+//; # strip leading whitespace
353 69         106 $key =~ s/\s+$//; # strip trailing whitespace
354              
355             # optional lowercase
356 69 100       106 $key = lc $key if $LOWERCASE_FIELDNAMES;
357 69 100       100 $value = lc $value if $LOWERCASE_FIELDVALUES;
358              
359             # optional value trimming
360 69 100       86 $value =~ s/\s+$// if $TRIM_FIELDVALUES; # there can be no leading whitespace
361              
362             # skip this field according to regex
363 69 100 66     196 last if $DOC_DATA_IGNORE and $document_data_ignore and $key =~ $document_data_ignore;
      100        
364              
365             # Store "# Test-key: value" entries also as
366             # 'kv_data' under their parent line.
367             # That line should be a test or a plan line, so that its
368             # place (or "data path") is structurally always the same.
369 62 100 100     129 if ($lines[-1]->is_test or $lines[-1]->is_plan or $lines[-1]->is_pragma) {
      100        
370 52         104 $lines[-1]->{kv_data}{$key} = $value;
371             } else {
372 10 50       28 if (!$plan) {
373             # We haven't got a plan yet, so that
374             # kv_data entry would get lost. As we
375             # might still get a lazy plan at end
376             # of document, so we save it up for
377             # that potential plan entry.
378 10         17 $dangling_kv_data{$key} = $value;
379             }
380             }
381 62 50 66     96 $document_data{$key} = $value unless $lines[-1]->is_test && $DISABLE_GLOBAL_KV_DATA;
382             }}
383              
384             # calculate severity
385 625 100 100     4031 if ($entry->{is_test} or $entry->{is_plan}) {
386 19     19   126 no warnings 'uninitialized';
  19         38  
  19         1168  
387             $entry->{severity} = $severity
388             ->{$entry->{type}}
389             ->{$entry->{is_ok}}
390             ->{$entry->{has_todo}}
391             ->{$entry->{is_actual_ok}}
392 222         773 ->{$entry->{has_skip}};
393             }
394 625 100       905 if ($entry->{is_pragma}) {
395 19     19   93 no warnings 'uninitialized';
  19         40  
  19         13429  
396 7 100       28 $entry->{severity} = $entry->{raw} =~ /^pragma\s+\+tapdom_error\s*$/ ? 5 : 0;
397             }
398 625 100       1064 $entry->{severity} = 0 if not defined $entry->{severity};
399              
400             # yaml and comments are taken as children of the line before
401 625 100 100     904 if ($result->is_yaml or $result->is_comment and @lines)
      100        
402             {
403 337         2396 push @{ $lines[-1]->{_children} }, $entry;
  337         1296  
404             }
405             else
406             {
407 288         3151 push @lines, $entry;
408             }
409             }
410 64         10951 @pragmas = $parser->pragmas;
411              
412 64         459 $aggregate->add( main => $parser );
413 64         5702 $aggregate->stop;
414              
415 64 100       1133 my $summary = TAP::DOM::Summary->new
    100          
    100          
416             (
417             failed => scalar $aggregate->failed,
418             parse_errors => scalar $aggregate->parse_errors,
419             planned => scalar $aggregate->planned,
420             passed => scalar $aggregate->passed,
421             skipped => scalar $aggregate->skipped,
422             todo => scalar $aggregate->todo,
423             todo_passed => scalar $aggregate->todo_passed,
424             wait => scalar $aggregate->wait,
425             exit => scalar $aggregate->exit,
426             elapsed => $aggregate->elapsed,
427             elapsed_timestr => $aggregate->elapsed_timestr,
428             all_passed => $aggregate->all_passed ? 1 : 0,
429             status => $aggregate->get_status,
430             total => $aggregate->total,
431             has_problems => $aggregate->has_problems ? 1 : 0,
432             has_errors => $aggregate->has_errors ? 1 : 0,
433             );
434              
435 64         12224 my $tapdom_config = TAP::DOM::Config->new
436             (
437             ignore => \%IGNORE,
438             ignorelines => $IGNORELINES,
439             dontignorelines => $DONTIGNORELINES,
440             usebitsets => $USEBITSETS,
441             disable_global_kv_data => $DISABLE_GLOBAL_KV_DATA,
442             put_dangling_kv_data_under_lazy_plan => $PUT_DANGLING_KV_DATA_UNDER_LAZY_PLAN,
443             document_data_prefix => $DOC_DATA_PREFIX,
444             document_data_ignore => $DOC_DATA_IGNORE,
445             lowercase_fieldnames => $LOWERCASE_FIELDNAMES,
446             lowercase_fieldvalues => $LOWERCASE_FIELDVALUES,
447             trim_fieldvalues => $TRIM_FIELDVALUES,
448             noempty_tap => $NOEMPTY_TAP,
449             );
450              
451 64         372 my $document_data = TAP::DOM::DocumentData->new(%document_data);
452              
453 64         197 my $tapdata = {
454             plan => $plan,
455             lines => \@lines,
456             pragmas => \@pragmas,
457             tests_planned => $parser->tests_planned,
458             tests_run => $parser->tests_run,
459             version => $parser->version,
460             is_good_plan => $parser->is_good_plan,
461             skip_all => $parser->skip_all,
462             start_time => $parser->start_time,
463             end_time => $parser->end_time,
464             has_problems => $parser->has_problems,
465             exit => $parser->exit,
466             parse_errors => scalar $parser->parse_errors,
467             parse_errors_msgs => [ $parser->parse_errors ],
468             summary => $summary,
469             tapdom_config => $tapdom_config,
470             document_data => $document_data,
471             };
472 64         4111 return bless $tapdata, $class;
473             }
474              
475             sub _entry_to_tapline
476             {
477 40     40   41 my ($self, $entry) = @_;
478              
479 40         28 my %IGNORE = %{$self->{tapdom_config}{ignore}};
  40         48  
480              
481 40         40 my $tapline = "";
482              
483             # ok/notok test lines
484 40 100 100     110 if ($entry->{is_test})
    100 66        
      33        
485             {
486             $tapline = join(" ",
487             # the original "NOT" is more difficult to reconstruct than it should...
488             ($entry->{has_todo}
489             ? $entry->{is_actual_ok} ? () : "not"
490             : $entry->{is_ok} ? () : "not"),
491             "ok",
492             ($entry->{number} || ()),
493             ($entry->{description} || ()),
494             ($entry->{has_skip} ? "# SKIP ".($entry->{explanation} || "")
495 16 100 33     80 : $entry->{has_todo }? "# TODO ".($entry->{explanation} || "")
    50 66        
    100 50        
    100 50        
    100          
496             : ()),
497             );
498             }
499             # pragmas and meta lines, but no version nor plan
500             elsif ($entry->{is_pragma} ||
501             $entry->{is_comment} ||
502             $entry->{is_bailout} ||
503             $entry->{is_yaml})
504             {
505 20 50       25 $tapline = $IGNORE{raw} ? $entry->{as_string} : $entry->{raw}; # if "raw" was 'ignored' try "as_string"
506             }
507 40         50 return $tapline;
508             }
509              
510             sub _lines_to_tap
511             {
512 8     8   11 my ($self, $lines) = @_;
513              
514 8         8 my @taplines;
515 8         12 foreach my $entry (@$lines)
516             {
517 40         46 my $tapline = $self->_entry_to_tapline($entry);
518 40 100       55 push @taplines, $tapline if $tapline;
519 40 100       66 push @taplines, $self->_lines_to_tap($entry->{_children}) if $entry->{_children};
520             }
521 8         19 return @taplines;
522             }
523              
524             sub to_tap
525             {
526 2     2 1 727 my ($self) = @_;
527              
528 2         9 my @taplines = $self->_lines_to_tap($self->{lines});
529 2         5 unshift @taplines, $self->{plan};
530 2         6 unshift @taplines, "TAP version ".$self->{version};
531              
532             return wantarray
533             ? @taplines
534 2 100       20 : join("\n", @taplines)."\n";
535             }
536              
537             1; # End of TAP::DOM
538              
539             __END__