File Coverage

blib/lib/Test2/Harness/Parser/TAP.pm
Criterion Covered Total %
statement 195 199 97.9
branch 87 96 90.6
condition 21 25 84.0
subroutine 34 34 100.0
pod 2 13 15.3
total 339 367 92.3


line stmt bran cond sub pod time code
1             package Test2::Harness::Parser::TAP;
2 24     24   123626 use strict;
  24         87  
  24         862  
3 24     24   135 use warnings;
  24         110  
  24         1313  
4              
5             our $VERSION = '0.000013';
6              
7 24     24   96 use Test2::Event::Bail;
  24         46  
  24         557  
8 24     24   160 use Test2::Event::Diag;
  24         68  
  24         397  
9 24     24   861 use Test2::Event::Encoding;
  24         486  
  24         456  
10 24     24   96 use Test2::Event::Exception;
  24         65  
  24         522  
11 24     24   94 use Test2::Event::Note;
  24         24  
  24         510  
12 24     24   156 use Test2::Event::Ok;
  24         45  
  24         471  
13 24     24   691 use Test2::Event::ParseError;
  24         67  
  24         427  
14 24     24   95 use Test2::Event::Plan;
  24         45  
  24         476  
15 24     24   72 use Test2::Event::Skip;
  24         67  
  24         534  
16 24     24   73 use Test2::Event::Subtest;
  24         46  
  24         409  
17 24     24   10306 use Test2::Event::TAP::Version;
  24         6817  
  24         541  
18 24     24   700 use Test2::Event::UnknownStderr;
  24         47  
  24         389  
19 24     24   646 use Test2::Event::UnknownStdout;
  24         45  
  24         456  
20 24     24   73 use Test2::Event::Waiting;
  24         67  
  24         407  
21 24     24   8361 use Test2::Harness::Parser::TAP::SubtestState;
  24         25  
  24         524  
22              
23 24     24   995 use Time::HiRes qw/sleep/;
  24         1975  
  24         271  
24              
25 24     24   4390 use base 'Test2::Harness::Parser';
  24         25  
  24         2454  
26 24     24   76 use Test2::Util::HashBase qw/_subtest_state/;
  24         25  
  24         76  
27              
28 10     10 0 22106 sub init { $_[0]->_init }
29 265     265 1 112007 sub morph { $_[0]->_init }
30              
31             sub _init {
32 275     275   534 my $self = shift;
33 275         3093 $self->{+_SUBTEST_STATE} = Test2::Harness::Parser::TAP::SubtestState->new;
34             }
35              
36             sub step {
37 9511     9511 1 83069 my $self = shift;
38              
39 9511         28348 my @events = ($self->parse_stdout, $self->parse_stderr);
40             # If in_subtest is defined then the object is part of a buffered subtest
41             # and therefore cannot be starting a streaming subtest.
42 9511 100       25470 return map { defined $_->in_subtest ? $_ : $self->{+_SUBTEST_STATE}->maybe_start_streaming_subtest($_) } @events;
  5548         16472  
43             }
44              
45             sub parse_stderr {
46 9521     9521 0 19462 my $self = shift;
47              
48 9521 100       22859 my $line = $self->proc->get_err_line(peek => 1) or return;
49              
50 50 100       702 return $self->slurp_comments('STDERR')
51             if $line =~ m/^\s*#/;
52              
53 4         10 $line = $self->proc->get_err_line();
54 4         23 chomp(my $out = $line);
55 4 50       9 return unless length($out);
56 4         19 return Test2::Event::UnknownStderr->new(output => $out);
57             }
58              
59             sub parse_stdout {
60 9511     9511 0 9709 my $self = shift;
61              
62 9511 100       33944 my $line = $self->proc->get_out_line(peek => 1) or return;
63              
64 1265 100       5201 return $self->slurp_comments('STDOUT')
65             if $line =~ m/^\s*#/;
66              
67 1210         2582 $line = $self->proc->get_out_line();
68 1210         3747 my @events = $self->parse_tap_line($line);
69 1210 100       4356 return @events if @events;
70              
71 6         9 chomp(my $out = $line);
72 6 50       25 return unless length($out);
73 0         0 return Test2::Event::UnknownStdout->new(output => $out);
74             }
75              
76             sub parse_tap_line {
77 5791     5791 0 4709 my $self = shift;
78 5791         5595 my ($line) = @_;
79              
80 5791         6465 chomp($line);
81 5791 100       25538 my ($lead, $str) = ($line =~ m/^(\s+)(.+)$/) ? ($1, $2) : ('', $line);
82 5791         5770 $lead =~ s/\t/ /g;
83 5791         6661 my $nest = length($lead) / 4;
84              
85 5791         3843 my @events;
86             # The buffered_subtest parsing always starts by trying to parse an "ok"
87             # line, so we don't need to try parsing that _again_.
88 5791         9653 my @types = qw/buffered_subtest plan bail version/;
89 5791         7396 for my $type (@types) {
90 7772         9414 my $sub = "parse_tap_$type";
91 7772 100       13883 if (@events = $self->$sub($str, $nest)) {
92 5451         5817 last;
93             }
94             }
95              
96 5791         10588 return @events;
97             }
98              
99             sub parse_tap_buffered_subtest {
100 5791     5791 0 4509 my $self = shift;
101 5791         5019 my ($line, $nest) = @_;
102              
103 5791 100       8066 my ($st_ok, @errors) = $self->parse_tap_ok($line, $nest) or return;
104 4490 100       16865 return ($st_ok, @errors) unless $line =~ /\s*\{\s*\)?\s*$/;
105              
106 686         2241 my $id = $self->{+_SUBTEST_STATE}->next_id;
107              
108 686         697 my @events;
109             my @subevents;
110 686         611 my $count = 0;
111 686         687 while (1) {
112 5267         21254 my $line = $self->proc->get_out_line();
113 5267 50       8087 unless (defined $line) {
114 0         0 sleep 0.1;
115 0 0       0 die "Abrupt end to buffered subtest?" if $count++ > 10;
116 0         0 next;
117             }
118              
119 5267 100       10122 last if $line =~ m/^\s*\}\s*$/;
120 4581         6361 my @e = $self->parse_tap_line($line);
121 4581         4432 push @events => @e;
122             # We might have events where in_subtest is already set in the case of
123             # nested buffered subtests. In that case, we want those nested
124             # subevents to _not_ be part of this particular subtest. Instead, they
125             # are part of the child subtest contained in the parent. However, we
126             # still want to emit _all_ the events as we see them, so we need to do
127             # some filtering here.
128 4581         4005 push @subevents => grep { !defined $_->in_subtest } @e;
  4319         7267  
129             }
130              
131 686         2226 $_->set_in_subtest($id) for @subevents;
132              
133             # If this is a buffered subtest marked as todo, then the "{" marking the
134             # subtest ends up in the todo field instead of the name;
135 686         10265 my $todo = $st_ok->todo;
136 686 100       2339 $todo =~ s/\s*\{\s*$// if defined $todo;
137              
138 686         1378 my $name = $st_ok->name;
139 686 50       3798 $name =~ s/\s*\{\s*$// if defined $name;
140              
141 686         1595 my %st = (
142             subtest_id => $id,
143             name => $name,
144             pass => $st_ok->pass,
145             todo => $todo,
146             nested => $nest,
147             subevents => \@subevents,
148             );
149              
150 686         7194 my $st = Test2::Event::Subtest->new(%st);
151              
152 686         27722 return (@events, $st, @errors);
153             }
154              
155             sub parse_tap_ok {
156 5839     5839 0 55308 my $self = shift;
157 5839         4853 my ($line, $nest) = @_;
158              
159 5839         4336 my ($pass, $todo, $skip, $num, @errors);
160              
161 5839 100       25148 return unless $line =~ s/^(not )?ok\b//;
162 4538         7456 $pass = !$1;
163              
164 4538 100 100     18118 push @errors => "'ok' is not immediately followed by a space."
165             if $line && !($line =~ m/^ /);
166              
167 4538 100       13314 if ($line =~ s/^(\s*)(\d+)\b//) {
168 4504         5125 my $space = $1;
169 4504         4371 $num = $2;
170              
171 4504 100       8315 push @errors => "Extra space after 'ok'"
172             if length($space) > 1;
173             }
174              
175             # Not strictly compliant, but compliant with what Test-Simple does...
176             # Standard does not have a todo & skip.
177 4538 100       7815 if ($line =~ s/#\s*(todo & skip|todo|skip)(.*)$//i) {
178 75         132 my ($directive, $reason) = ($1, $2);
179              
180 75 100       341 push @errors => "No space before the '#' for the '$directive' directive."
181             unless $line =~ s/\s+$//;
182              
183 75 100 100     389 push @errors => "No space between '$directive' directive and reason."
184             if $reason && !($reason =~ s/^\s+//);
185              
186 75 100       232 $skip = $reason if $directive =~ m/skip/i;
187 75 100       223 $todo = $reason if $directive =~ m/todo/i;
188             }
189              
190             # Standard says that everything after the ok (except the number) is part of
191             # the name. Most things add a dash between them, and I am deviating from
192             # standards by stripping it and surrounding whitespace.
193 4538         10810 $line =~ s/\s*-\s*//;
194              
195 4538         5163 $line =~ s/^\s+//;
196 4538         6542 $line =~ s/\s+$//;
197              
198 4538         2993 my $event;
199 4538 100       8430 if ($line =~ /^Subtest: (.+)$/) {
    100          
200 12         45 $event = Test2::Event::Subtest->new($self->{+_SUBTEST_STATE}->finish_streaming_subtest($pass, $line, $nest));
201             }
202             elsif (defined $skip) {
203 29         262 $event = Test2::Event::Skip->new(
204             reason => $skip,
205             pass => $pass,
206             name => $line,
207             nested => $nest,
208             );
209             }
210             else {
211 4497 100       14260 $event = Test2::Event::Ok->new(
212             defined($todo) ? (todo => $todo) : (),
213             pass => $pass,
214             name => $line,
215             nested => $nest,
216             );
217             }
218              
219             return (
220             $event,
221 4538         64930 map { Test2::Event::ParseError->new(parse_error => $_) } @errors,
  8         19  
222             );
223             }
224              
225             sub parse_tap_version {
226 346     346 0 3628 my $self = shift;
227 346         294 my ($line, $nest) = @_;
228              
229 346 100       1073 return unless $line =~ s/^TAP version\s*//;
230              
231 4         18 return Test2::Event::TAP::Version->new(
232             version => $line,
233             nested => $nest,
234             );
235             }
236              
237             sub parse_tap_plan {
238 1313     1313 0 7583 my $self = shift;
239 1313         1273 my ($line, $nest) = @_;
240              
241 1313 100       4811 return unless $line =~ s/^1\.\.(\d+)//;
242 969         1735 my $max = $1;
243              
244 969         819 my ($directive, $reason);
245              
246 969 100       2293 if ($max == 0) {
247 23 100       725 if ($line =~ s/^\s*#\s*//) {
248 19 50       161 if ($line =~ s/^(skip)\S*\s*//i) {
249 19         71 $directive = uc($1);
250 19         89 $reason = $line;
251 19         71 $line = "";
252             }
253             }
254              
255 23   100     181 $directive ||= "SKIP";
256 23   100     117 $reason ||= "no reason given";
257             }
258              
259 969         3068 my $event = Test2::Event::Plan->new(
260             max => $max,
261             directive => $directive,
262             reason => $reason,
263             nested => $nest,
264             );
265              
266 969 100       21857 return $event unless $line =~ m/\S/;
267              
268             return (
269 2         16 $event,
270             Test2::Event::ParseError->new(
271             parse_error => 'Extra characters after plan.',
272             ),
273             );
274             }
275              
276             sub parse_tap_bail {
277 346     346 0 5428 my $self = shift;
278 346         314 my ($line, $nest) = @_;
279              
280 346 100       813 return unless $line =~ s/^Bail out! *//;
281              
282 4         15 return Test2::Event::Bail->new(
283             reason => $line,
284             nested => $nest,
285             );
286             }
287              
288             sub slurp_comments {
289 115     115 0 7484 my $self = shift;
290 115         242 my ($io) = @_;
291              
292 115 100       655 my $meth = $io eq 'STDERR' ? 'get_err_line' : 'get_out_line';
293              
294 115         323 my $raw = $self->proc->$meth;
295 115         465 my ($nest, $diag) = strip_comment($raw);
296              
297 115 50 33     736 die "Not a comment? ($raw)"
298             unless defined($nest) && defined($diag);
299              
300 115 100       246 my $failed = $diag =~ m/^Failed test/ ? 1 : 0;
301              
302 115         131 while (1) {
303 1062 100       1571 my $line = $self->proc->$meth(peek => 1) or last;
304 971         1320 my ($lnest, $msg) = strip_comment($line);
305 971 100 66     3051 last unless defined($lnest) && defined($msg);
306 959 100       1318 last if $lnest != $nest;
307 955 100       1352 last if $msg =~ m/^Failed test/;
308 953 100 100     1471 last if $failed && $msg !~ m/^at /;
309              
310 951         1400 $raw .= $self->proc->$meth;
311              
312 951 50       2173 $diag .= "\n$msg" if $msg;
313 951 100       1365 last if $failed;
314             }
315              
316 115 100       371 my $class = $io eq 'STDERR' ? 'Test2::Event::Diag' : 'Test2::Event::Note';
317 115         708 return $class->new(
318             message => $diag,
319             nested => $nest,
320             );
321             }
322              
323             sub strip_comment {
324 1094     1094 0 4299 my $line = shift;
325 1094         942 chomp($line);
326 1094         3937 my ($nest, $hash, $space, $msg) = split /(#)(\s*)/, $line, 2;
327 1094 100 100     2276 return unless $msg || $hash || $space;
      66        
328              
329 1080         963 $nest = length($nest) / 4;
330             # We want to preserve any space in the comment _after_ the first space,
331             # since proper TAP is formatted as "# $msg". So the first space is part of
332             # the comment marker, while subsequent space is significant.
333 1080         1878 $space =~ s/^ //;
334 1080         1831 return ($nest, $space . $msg);
335             }
336              
337             1;
338              
339             __END__