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__ |