line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Test::ParallelSubtest; |
2
|
10
|
|
|
10
|
|
244938
|
use strict; |
|
10
|
|
|
|
|
41
|
|
|
10
|
|
|
|
|
530
|
|
3
|
10
|
|
|
10
|
|
63
|
use warnings; |
|
10
|
|
|
|
|
23
|
|
|
10
|
|
|
|
|
775
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
our $VERSION = '0.05'; |
6
|
|
|
|
|
|
|
$VERSION = eval $VERSION; |
7
|
|
|
|
|
|
|
|
8
|
10
|
|
|
10
|
|
6351
|
use Test::Builder::Module; |
|
10
|
|
|
|
|
89750
|
|
|
10
|
|
|
|
|
71
|
|
9
|
|
|
|
|
|
|
our @ISA = qw(Test::Builder::Module); |
10
|
|
|
|
|
|
|
our @EXPORT = qw(bg_subtest_wait bg_subtest max_parallel); |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
our @_kids; |
13
|
|
|
|
|
|
|
our $_i_am_a_child = 0; |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
our $MaxParallel = 4; |
16
|
|
|
|
|
|
|
|
17
|
10
|
|
|
10
|
|
1106
|
use Carp; |
|
10
|
|
|
|
|
20
|
|
|
10
|
|
|
|
|
1006
|
|
18
|
10
|
|
|
10
|
|
9783
|
use Sub::Prepend (); |
|
10
|
|
|
|
|
32061
|
|
|
10
|
|
|
|
|
317
|
|
19
|
10
|
|
|
10
|
|
12395
|
use TAP::Parser; |
|
10
|
|
|
|
|
971186
|
|
|
10
|
|
|
|
|
379
|
|
20
|
10
|
|
|
10
|
|
118
|
use Test::Builder; |
|
10
|
|
|
|
|
21
|
|
|
10
|
|
|
|
|
250
|
|
21
|
10
|
|
|
10
|
|
20445
|
use Test::ParallelSubtest::Capture; |
|
10
|
|
|
|
|
30
|
|
|
10
|
|
|
|
|
8672
|
|
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
Test::Builder->new->can('subtest') or croak |
24
|
|
|
|
|
|
|
"Need a version of Test::Builder with subtest support"; |
25
|
|
|
|
|
|
|
|
26
|
10
|
100
|
|
10
|
|
19549
|
END { bg_subtest_wait() if @_kids } |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
Sub::Prepend::prepend( |
29
|
|
|
|
|
|
|
'Test::Builder::done_testing' => \&bg_subtest_wait |
30
|
|
|
|
|
|
|
); |
31
|
|
|
|
|
|
|
Sub::Prepend::prepend( |
32
|
|
|
|
|
|
|
'Test::Builder::subtest' => sub { |
33
|
|
|
|
|
|
|
# Wait for kids just before entering a subtest. |
34
|
|
|
|
|
|
|
bg_subtest_wait(); |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
# Wait for kids just before leaving a subtest. |
37
|
|
|
|
|
|
|
my $subtests = $_[2]; |
38
|
|
|
|
|
|
|
$_[2] = sub { |
39
|
|
|
|
|
|
|
$subtests->(); |
40
|
|
|
|
|
|
|
bg_subtest_wait(); |
41
|
|
|
|
|
|
|
}; |
42
|
|
|
|
|
|
|
} |
43
|
|
|
|
|
|
|
); |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
sub import_extra { |
46
|
10
|
|
|
10
|
1
|
609
|
my ($class, $list) = @_; |
47
|
|
|
|
|
|
|
|
48
|
10
|
|
|
|
|
27
|
my @other; |
49
|
10
|
|
|
|
|
50
|
while (@$list >= 2) { |
50
|
21
|
|
|
|
|
49
|
my $item = shift @$list; |
51
|
21
|
100
|
|
|
|
53
|
if ($item eq 'max_parallel') { |
52
|
7
|
|
|
|
|
28
|
max_parallel(shift @$list); |
53
|
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
else { |
55
|
14
|
|
|
|
|
47
|
push @other, $item; |
56
|
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
10
|
|
|
|
|
35
|
@$list = @other; |
60
|
|
|
|
|
|
|
|
61
|
10
|
|
|
|
|
36
|
return; |
62
|
|
|
|
|
|
|
} |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
sub max_parallel (;$) { |
65
|
15
|
|
|
15
|
1
|
2342
|
my $new_value = shift; |
66
|
|
|
|
|
|
|
|
67
|
15
|
|
|
|
|
24
|
my $old_value = $MaxParallel; |
68
|
15
|
100
|
|
|
|
60
|
if (defined $new_value) { |
69
|
9
|
50
|
|
|
|
61
|
$new_value =~ /^[0-9]+\z/ or croak "non-numeric max_parallel value"; |
70
|
9
|
|
|
|
|
25
|
$MaxParallel = $new_value; |
71
|
|
|
|
|
|
|
} |
72
|
|
|
|
|
|
|
|
73
|
15
|
|
|
|
|
56
|
return $old_value; |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
sub bg_subtest ($&) { |
77
|
24
|
|
|
24
|
1
|
638
|
my ($name, $subtests) = @_; |
78
|
|
|
|
|
|
|
|
79
|
24
|
100
|
|
|
|
191
|
$_i_am_a_child and croak "bg_subtest() called from a child process"; |
80
|
|
|
|
|
|
|
|
81
|
23
|
|
|
|
|
865
|
my $tb = Test::Builder->new; |
82
|
|
|
|
|
|
|
|
83
|
23
|
100
|
|
|
|
384
|
if ($MaxParallel < 1) { |
84
|
|
|
|
|
|
|
# We've been told not to fork. |
85
|
1
|
|
|
|
|
7
|
return $tb->subtest($name, $subtests); |
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
|
88
|
22
|
|
|
|
|
82
|
while (@_kids >= $MaxParallel) { |
89
|
14
|
|
|
|
|
122
|
_wait_for_next_kid(); |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
|
92
|
22
|
|
|
|
|
93
|
my ($read_pipe, $write_pipe, $pid) = _pipe_and_fork(); |
93
|
|
|
|
|
|
|
|
94
|
22
|
50
|
|
|
|
219
|
if (!defined $pid) { |
95
|
|
|
|
|
|
|
# Can't fork, fall back to a subtest() call. |
96
|
0
|
|
|
|
|
0
|
return $tb->subtest($name, $subtests); |
97
|
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
|
99
|
22
|
|
|
|
|
1218
|
my $out_fh = $tb->output; |
100
|
22
|
|
|
|
|
2771
|
my $fail_fh = $tb->failure_output; |
101
|
22
|
|
|
|
|
446
|
my $todo_fh = $tb->todo_output; |
102
|
|
|
|
|
|
|
|
103
|
22
|
100
|
|
|
|
384
|
if ($pid) { |
104
|
|
|
|
|
|
|
# parent |
105
|
16
|
|
|
|
|
487
|
close $write_pipe; |
106
|
16
|
|
|
|
|
3422
|
my @caller = caller(); |
107
|
16
|
|
|
|
|
1932
|
push @_kids, { |
108
|
|
|
|
|
|
|
Pid => $pid, |
109
|
|
|
|
|
|
|
Ppid => $$, |
110
|
|
|
|
|
|
|
Pipe => $read_pipe, |
111
|
|
|
|
|
|
|
Out => [$out_fh, $fail_fh, $todo_fh], |
112
|
|
|
|
|
|
|
TestName => $name, |
113
|
|
|
|
|
|
|
Caller => "$caller[1] line $caller[2]", |
114
|
|
|
|
|
|
|
}; |
115
|
16
|
|
|
|
|
2260
|
return; |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
else { |
118
|
|
|
|
|
|
|
# child |
119
|
6
|
|
|
|
|
776
|
close $read_pipe; |
120
|
6
|
|
|
|
|
361
|
local $Test::Builder::Level = $Test::Builder::Level + 1; |
121
|
6
|
|
|
|
|
357
|
_child($write_pipe, $name, $subtests); |
122
|
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
sub _child { |
126
|
6
|
|
|
6
|
|
188
|
my ($write_pipe, $name, $subtests) = @_; |
127
|
|
|
|
|
|
|
|
128
|
6
|
|
|
|
|
721
|
$_i_am_a_child = 1; |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
# Capture the outputs of the subtest as strings. |
131
|
6
|
|
|
|
|
1656
|
my $outer_out = ''; |
132
|
6
|
|
|
|
|
92
|
my $outer_fail = ''; |
133
|
6
|
|
|
|
|
73
|
my $outer_todo = ''; |
134
|
6
|
|
|
|
|
327
|
my $tb = Test::Builder->new; |
135
|
6
|
|
|
|
|
456
|
$tb->output(\$outer_out); |
136
|
6
|
|
|
|
|
12198
|
$tb->failure_output(\$outer_fail); |
137
|
6
|
|
|
|
|
396
|
$tb->todo_output(\$outer_todo); |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
# Capture the outputs of tests within the subtest for replay |
140
|
|
|
|
|
|
|
# in the parent. |
141
|
6
|
|
|
|
|
627
|
my $capture = Test::ParallelSubtest::Capture->new; |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
$tb->subtest($name, sub { |
144
|
6
|
|
|
6
|
|
50
|
$capture->install($tb); |
145
|
6
|
|
|
|
|
192
|
$subtests->(); |
146
|
6
|
|
|
|
|
452
|
}); |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
# Pass all the captured output to the parent process. |
149
|
6
|
|
|
|
|
5498
|
_len_prefixed_writes($write_pipe, |
150
|
|
|
|
|
|
|
\$outer_out, \$outer_fail, \$outer_todo, $capture->as_string_ref |
151
|
|
|
|
|
|
|
); |
152
|
|
|
|
|
|
|
|
153
|
6
|
|
|
|
|
1755
|
close $write_pipe; |
154
|
|
|
|
|
|
|
|
155
|
10
|
|
|
10
|
|
71
|
no warnings 'redefine'; |
|
10
|
|
|
|
|
14
|
|
|
10
|
|
|
|
|
7091
|
|
156
|
6
|
|
|
0
|
|
492
|
*Test::Builder::DESTROY = sub {}; # For T::B fork in subtest bug |
|
0
|
|
|
|
|
0
|
|
157
|
6
|
|
|
|
|
1196
|
exit(0); |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
sub bg_subtest_wait { |
161
|
26
|
100
|
|
26
|
1
|
1075
|
return if $_i_am_a_child; |
162
|
|
|
|
|
|
|
|
163
|
5
|
|
|
|
|
61
|
_wait_for_next_kid() while @_kids; |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
sub _pipe_and_fork { |
167
|
22
|
|
|
22
|
|
37
|
my ($read_pipe, $write_pipe, $pid); |
168
|
|
|
|
|
|
|
|
169
|
22
|
|
|
|
|
31
|
while (1) { |
170
|
22
|
|
|
|
|
731
|
my $pipe_ok = pipe $read_pipe, $write_pipe; |
171
|
22
|
50
|
|
|
|
73
|
if ($pipe_ok) { |
172
|
22
|
|
|
|
|
43937
|
$pid = fork; |
173
|
22
|
50
|
|
|
|
2549
|
if (defined $pid) { |
174
|
22
|
|
|
|
|
1550
|
return ($read_pipe, $write_pipe, $pid); |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
} |
177
|
|
|
|
|
|
|
|
178
|
0
|
0
|
|
|
|
0
|
if (@_kids) { |
179
|
|
|
|
|
|
|
# The pipe or fork failure could be due to a resource limit, |
180
|
|
|
|
|
|
|
# reap a kid and try again. |
181
|
0
|
|
|
|
|
0
|
_wait_for_next_kid(); |
182
|
|
|
|
|
|
|
} |
183
|
|
|
|
|
|
|
else { |
184
|
|
|
|
|
|
|
# No kids and pipe+fork won't work, give up. |
185
|
0
|
|
|
|
|
0
|
return; |
186
|
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
sub _wait_for_next_kid { |
191
|
16
|
|
|
16
|
|
136
|
my $kid = shift @_kids; |
192
|
|
|
|
|
|
|
|
193
|
16
|
50
|
33
|
|
|
356
|
return unless $kid and $kid->{Ppid} == $$; |
194
|
|
|
|
|
|
|
|
195
|
16
|
|
|
|
|
109
|
my $tb = Test::Builder->new; |
196
|
16
|
|
|
|
|
121
|
my ($out_dest, $fail_dest, $todo_dest) = @{ $kid->{Out} }; |
|
16
|
|
|
|
|
33
|
|
197
|
|
|
|
|
|
|
|
198
|
16
|
|
|
|
|
423
|
my ($outer_out, $outer_fail, $outer_todo, $inner_capture) |
199
|
|
|
|
|
|
|
= _len_prefixed_reads($kid->{Pipe}, 4); |
200
|
|
|
|
|
|
|
|
201
|
16
|
|
|
|
|
22769255
|
waitpid $kid->{Pid}, 0; # Don't let zombies build up. |
202
|
|
|
|
|
|
|
|
203
|
16
|
50
|
|
|
|
276
|
if (!defined $outer_out) { |
204
|
0
|
|
|
|
|
0
|
my $name = "failed child process for '$kid->{TestName}'"; |
205
|
0
|
|
|
|
|
0
|
_run_test_from_kid_in_parent(0, $name, undef, undef, <
|
206
|
|
|
|
|
|
|
ERROR: bg_subtest "$kid->{TestName}" ($kid->{Caller}) aborted: |
207
|
|
|
|
|
|
|
Lost contact with the child process. |
208
|
|
|
|
|
|
|
END |
209
|
0
|
|
|
|
|
0
|
return; |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
|
212
|
16
|
|
|
|
|
256
|
my ($ok, $name, $todo, $skip) = _parse_outer_output_line($$outer_out); |
213
|
|
|
|
|
|
|
|
214
|
16
|
50
|
|
|
|
67
|
if (!defined $ok) { |
215
|
0
|
|
|
|
|
0
|
$name = "parse child output for '$kid->{TestName}'"; |
216
|
0
|
|
|
|
|
0
|
_run_test_from_kid_in_parent(0, $name, undef, undef, <
|
217
|
|
|
|
|
|
|
ERROR: bg_subtest "$kid->{TestName}" ($kid->{Caller}) aborted: |
218
|
|
|
|
|
|
|
Parsing failure in Test::ParallelSubtest - cannot parse: |
219
|
|
|
|
|
|
|
[$$outer_out] |
220
|
|
|
|
|
|
|
END |
221
|
0
|
|
|
|
|
0
|
return; |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
|
224
|
16
|
50
|
33
|
|
|
84
|
if (defined $todo and $Test::Builder::VERSION >= 0.95_02) { |
225
|
|
|
|
|
|
|
# Recent Test::Builder redirects the fail output to the todo |
226
|
|
|
|
|
|
|
# output for a todo subtest. |
227
|
0
|
|
|
|
|
0
|
$fail_dest = $todo_dest; |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
|
230
|
16
|
|
|
|
|
246
|
my $cap = Test::ParallelSubtest::Capture->new($inner_capture); |
231
|
16
|
50
|
|
|
|
132
|
if ( ! $cap->replay_writes($out_dest, $fail_dest, $todo_dest) ) { |
232
|
0
|
|
|
|
|
0
|
$name = "garbled child output for '$name'"; |
233
|
0
|
|
|
|
|
0
|
_run_test_from_kid_in_parent(0, $name, undef, undef, <
|
234
|
|
|
|
|
|
|
ERROR: bg_subtest "$name" ($kid->{Caller}) aborted: |
235
|
|
|
|
|
|
|
Garbled captured output from the child process |
236
|
|
|
|
|
|
|
END |
237
|
0
|
|
|
|
|
0
|
return; |
238
|
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
|
|
240
|
16
|
|
|
|
|
70
|
_run_test_from_kid_in_parent($ok, $name, $todo, $skip); |
241
|
|
|
|
|
|
|
|
242
|
16
|
|
|
|
|
525
|
print $fail_dest $$outer_fail; |
243
|
16
|
|
|
|
|
806
|
print $todo_dest $$outer_todo; |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
sub _run_test_from_kid_in_parent { |
247
|
16
|
|
|
16
|
|
41
|
my ($ok, $name, $todo, $skip, $internal_failure) = @_; |
248
|
|
|
|
|
|
|
|
249
|
10
|
|
|
10
|
|
101
|
no warnings 'redefine'; |
|
10
|
|
|
|
|
20
|
|
|
10
|
|
|
|
|
10105
|
|
250
|
16
|
|
|
16
|
|
329
|
local *Test::Builder::todo = sub { $todo }; |
|
16
|
|
|
|
|
2280
|
|
251
|
16
|
|
|
32
|
|
195
|
local *Test::Builder::in_todo = sub { defined $todo }; |
|
32
|
|
|
|
|
2449
|
|
252
|
|
|
|
|
|
|
|
253
|
16
|
|
|
|
|
105
|
my $tb = Test::Builder->new; |
254
|
|
|
|
|
|
|
|
255
|
16
|
50
|
|
|
|
245
|
if ($internal_failure) { |
|
|
50
|
|
|
|
|
|
256
|
0
|
|
|
|
|
0
|
$tb->ok($ok, $name); |
257
|
0
|
|
|
|
|
0
|
$tb->diag($internal_failure); |
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
elsif (defined $skip) { |
260
|
0
|
|
|
|
|
0
|
$tb->skip($skip); |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
else { |
263
|
16
|
|
|
|
|
70
|
_ok_without_diag_output($tb, $ok, $name); |
264
|
|
|
|
|
|
|
} |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
sub _ok_without_diag_output { |
268
|
16
|
|
|
16
|
|
54
|
my ($tb, $pass, $name) = @_; |
269
|
|
|
|
|
|
|
|
270
|
16
|
|
|
|
|
32
|
my $discard = ''; |
271
|
16
|
|
|
|
|
97
|
my $save_fail = $tb->failure_output; |
272
|
16
|
|
|
|
|
233
|
my $save_todo = $tb->todo_output; |
273
|
16
|
|
|
|
|
144
|
$tb->failure_output(\$discard); |
274
|
16
|
|
|
|
|
64880
|
$tb->todo_output(\$discard); |
275
|
|
|
|
|
|
|
|
276
|
16
|
|
|
|
|
860
|
$tb->ok($pass, $name); |
277
|
|
|
|
|
|
|
|
278
|
16
|
|
|
|
|
5315
|
$tb->todo_output($save_todo); |
279
|
16
|
|
|
|
|
453
|
$tb->failure_output($save_fail); |
280
|
|
|
|
|
|
|
} |
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
sub _parse_outer_output_line { |
283
|
16
|
|
|
16
|
|
98
|
my $output = shift; |
284
|
|
|
|
|
|
|
|
285
|
16
|
|
|
|
|
528
|
while ($output =~ s/^(\s*#\s*.*\n)//) { |
286
|
16
|
|
|
|
|
235
|
_print_to(Test::Builder->new->output, $1); |
287
|
|
|
|
|
|
|
} |
288
|
16
|
|
|
|
|
110
|
$output =~ s/^\s*//; # it may have been generated within a subtest |
289
|
|
|
|
|
|
|
|
290
|
16
|
50
|
|
|
|
751
|
my $parser = TAP::Parser->new( { tap => $output } ) or return; |
291
|
16
|
50
|
|
|
|
22624
|
my $result = $parser->next or return; |
292
|
16
|
50
|
|
|
|
30235
|
$result->is_test or return; |
293
|
|
|
|
|
|
|
|
294
|
16
|
|
|
|
|
181
|
my $ok = $result->is_actual_ok; |
295
|
16
|
|
|
|
|
127
|
my $name = $result->description; |
296
|
16
|
|
|
|
|
144
|
$name =~ s/- //; |
297
|
16
|
|
|
|
|
209
|
$name =~ s/\\#/#/g; |
298
|
16
|
50
|
|
|
|
66
|
my $todo = $result->has_todo ? $result->explanation : undef; |
299
|
16
|
50
|
|
|
|
148
|
my $skip = $result->has_skip ? $result->explanation : undef; |
300
|
|
|
|
|
|
|
|
301
|
16
|
|
|
|
|
380
|
return ($ok, $name, $todo, $skip); |
302
|
|
|
|
|
|
|
} |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
sub _len_prefixed_writes { |
305
|
6
|
|
|
6
|
|
23
|
my ($fh, @data) = @_; |
306
|
|
|
|
|
|
|
|
307
|
6
|
|
|
|
|
20
|
print $fh map { pack('N', length $$_) . $$_ } @data; |
|
24
|
|
|
|
|
156
|
|
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
sub _len_prefixed_reads { |
311
|
16
|
|
|
16
|
|
25
|
my ($fh, $count) = @_; |
312
|
|
|
|
|
|
|
|
313
|
16
|
|
|
|
|
160
|
my @results; |
314
|
16
|
|
|
|
|
81
|
while ($count--) { |
315
|
64
|
|
|
|
|
269
|
my $lenbuf = ''; |
316
|
64
|
50
|
|
|
|
15276987
|
read $fh, $lenbuf, 4 or return; |
317
|
64
|
50
|
|
|
|
216
|
length($lenbuf) == 4 or return; |
318
|
64
|
|
|
|
|
256
|
my $wantlen = unpack 'N', $lenbuf; |
319
|
|
|
|
|
|
|
|
320
|
64
|
|
|
|
|
171
|
my $buf = ''; |
321
|
64
|
100
|
|
|
|
755
|
if ($wantlen) { |
322
|
32
|
50
|
|
|
|
233
|
read $fh, $buf, $wantlen or return; |
323
|
32
|
50
|
|
|
|
144
|
length($buf) == $wantlen or return; |
324
|
|
|
|
|
|
|
} |
325
|
64
|
|
|
|
|
357
|
push @results, \$buf; |
326
|
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
|
328
|
16
|
|
|
|
|
81
|
return @results; |
329
|
|
|
|
|
|
|
} |
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
sub _print_to { |
332
|
16
|
|
|
16
|
|
655
|
my ($dest, $msg) = @_; |
333
|
|
|
|
|
|
|
|
334
|
16
|
50
|
|
|
|
212
|
if (ref $dest =~ /^SCALAR/) { |
335
|
0
|
|
|
|
|
0
|
$$dest .= $msg; |
336
|
|
|
|
|
|
|
} else { |
337
|
16
|
|
|
|
|
42
|
print {$dest} $msg; |
|
16
|
|
|
|
|
1306
|
|
338
|
|
|
|
|
|
|
} |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
1; |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
__END__ |