line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Plack::Util; |
2
|
146
|
|
|
146
|
|
720792
|
use strict; |
|
146
|
|
|
|
|
442
|
|
|
146
|
|
|
|
|
4034
|
|
3
|
146
|
|
|
146
|
|
714
|
use Carp (); |
|
146
|
|
|
|
|
240
|
|
|
146
|
|
|
|
|
2170
|
|
4
|
146
|
|
|
146
|
|
678
|
use Scalar::Util; |
|
146
|
|
|
|
|
332
|
|
|
146
|
|
|
|
|
5972
|
|
5
|
146
|
|
|
146
|
|
51361
|
use IO::Handle; |
|
146
|
|
|
|
|
573165
|
|
|
146
|
|
|
|
|
5798
|
|
6
|
146
|
|
|
146
|
|
78205
|
use overload (); |
|
146
|
|
|
|
|
75559
|
|
|
146
|
|
|
|
|
2834
|
|
7
|
146
|
|
|
146
|
|
892
|
use File::Spec (); |
|
146
|
|
|
|
|
285
|
|
|
146
|
|
|
|
|
9934
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
sub TRUE() { 1==1 } |
10
|
|
|
|
|
|
|
sub FALSE() { !TRUE } |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
# there does not seem to be a relevant RT or perldelta entry for this |
13
|
146
|
|
|
146
|
|
1238
|
use constant _SPLICE_SAME_ARRAY_SEGFAULT => $] < '5.008007'; |
|
146
|
|
|
|
|
322
|
|
|
146
|
|
|
|
|
35635
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
sub load_class { |
16
|
109
|
|
|
109
|
1
|
1029
|
my($class, $prefix) = @_; |
17
|
|
|
|
|
|
|
|
18
|
109
|
100
|
|
|
|
1673
|
if ($prefix) { |
19
|
108
|
100
|
66
|
|
|
6675
|
unless ($class =~ s/^\+// || $class =~ /^$prefix/) { |
20
|
61
|
|
|
|
|
916
|
$class = "$prefix\::$class"; |
21
|
|
|
|
|
|
|
} |
22
|
|
|
|
|
|
|
} |
23
|
|
|
|
|
|
|
|
24
|
109
|
|
|
|
|
585
|
my $file = $class; |
25
|
109
|
|
|
|
|
2241
|
$file =~ s!::!/!g; |
26
|
109
|
|
|
|
|
81577
|
require "$file.pm"; ## no critic |
27
|
|
|
|
|
|
|
|
28
|
108
|
|
|
|
|
523
|
return $class; |
29
|
|
|
|
|
|
|
} |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
sub is_real_fh ($) { |
32
|
13
|
|
|
13
|
1
|
2824
|
my $fh = shift; |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
{ |
35
|
146
|
|
|
146
|
|
1198
|
no warnings 'uninitialized'; |
|
146
|
|
|
|
|
279
|
|
|
146
|
|
|
|
|
351480
|
|
|
13
|
|
|
|
|
24
|
|
36
|
13
|
100
|
66
|
|
|
236
|
return FALSE if -p $fh or -c _ or -b _; |
|
|
|
66
|
|
|
|
|
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
|
39
|
11
|
100
|
|
|
|
83
|
my $reftype = Scalar::Util::reftype($fh) or return; |
40
|
9
|
100
|
100
|
|
|
48
|
if ( $reftype eq 'IO' |
|
|
|
66
|
|
|
|
|
41
|
7
|
|
|
|
|
91
|
or $reftype eq 'GLOB' && *{$fh}{IO} |
42
|
|
|
|
|
|
|
) { |
43
|
|
|
|
|
|
|
# if it's a blessed glob make sure to not break encapsulation with |
44
|
|
|
|
|
|
|
# fileno($fh) (e.g. if you are filtering output then file descriptor |
45
|
|
|
|
|
|
|
# based operations might no longer be valid). |
46
|
|
|
|
|
|
|
# then ensure that the fileno *opcode* agrees too, that there is a |
47
|
|
|
|
|
|
|
# valid IO object inside $fh either directly or indirectly and that it |
48
|
|
|
|
|
|
|
# corresponds to a real file descriptor. |
49
|
7
|
|
|
|
|
50
|
my $m_fileno = $fh->fileno; |
50
|
7
|
50
|
|
|
|
64
|
return FALSE unless defined $m_fileno; |
51
|
7
|
100
|
|
|
|
42
|
return FALSE unless $m_fileno >= 0; |
52
|
|
|
|
|
|
|
|
53
|
4
|
|
|
|
|
9
|
my $f_fileno = fileno($fh); |
54
|
4
|
50
|
|
|
|
16
|
return FALSE unless defined $f_fileno; |
55
|
4
|
50
|
|
|
|
26
|
return FALSE unless $f_fileno >= 0; |
56
|
4
|
|
|
|
|
24
|
return TRUE; |
57
|
|
|
|
|
|
|
} else { |
58
|
|
|
|
|
|
|
# anything else, including GLOBS without IO (even if they are blessed) |
59
|
|
|
|
|
|
|
# and non GLOB objects that look like filehandle objects cannot have a |
60
|
|
|
|
|
|
|
# valid file descriptor in fileno($fh) context so may break. |
61
|
2
|
|
|
|
|
15
|
return FALSE; |
62
|
|
|
|
|
|
|
} |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
sub set_io_path { |
66
|
19
|
|
|
19
|
1
|
191
|
my($fh, $path) = @_; |
67
|
19
|
|
|
|
|
155
|
bless $fh, 'Plack::Util::IOWithPath'; |
68
|
19
|
|
|
|
|
95
|
$fh->path($path); |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
sub content_length { |
72
|
598
|
|
|
598
|
1
|
2434
|
my $body = shift; |
73
|
|
|
|
|
|
|
|
74
|
598
|
50
|
|
|
|
2422
|
return unless defined $body; |
75
|
|
|
|
|
|
|
|
76
|
598
|
100
|
|
|
|
3336
|
if (ref $body eq 'ARRAY') { |
|
|
100
|
|
|
|
|
|
77
|
595
|
|
|
|
|
1226
|
my $cl = 0; |
78
|
595
|
|
|
|
|
4717
|
for my $chunk (@$body) { |
79
|
664
|
|
|
|
|
2801
|
$cl += length $chunk; |
80
|
|
|
|
|
|
|
} |
81
|
595
|
|
|
|
|
5082
|
return $cl; |
82
|
|
|
|
|
|
|
} elsif ( is_real_fh($body) ) { |
83
|
2
|
|
|
|
|
36
|
return (-s $body) - tell($body); |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
|
86
|
1
|
|
|
|
|
12
|
return; |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
sub foreach { |
90
|
713
|
|
|
713
|
1
|
6350
|
my($body, $cb) = @_; |
91
|
|
|
|
|
|
|
|
92
|
713
|
100
|
|
|
|
3007
|
if (ref $body eq 'ARRAY') { |
93
|
701
|
|
|
|
|
6124
|
for my $line (@$body) { |
94
|
758
|
50
|
|
|
|
7686
|
$cb->($line) if length $line; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
} else { |
97
|
12
|
50
|
|
|
|
250
|
local $/ = \65536 unless ref $/; |
98
|
12
|
|
|
|
|
1231
|
while (defined(my $line = $body->getline)) { |
99
|
10
|
50
|
|
|
|
1191
|
$cb->($line) if length $line; |
100
|
|
|
|
|
|
|
} |
101
|
6
|
|
|
|
|
743
|
$body->close; |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
sub class_to_file { |
106
|
1
|
|
|
1
|
0
|
2
|
my $class = shift; |
107
|
1
|
|
|
|
|
3
|
$class =~ s!::!/!g; |
108
|
1
|
|
|
|
|
3
|
$class . ".pm"; |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
sub _load_sandbox { |
112
|
9
|
|
|
9
|
|
18
|
my $_file = shift; |
113
|
|
|
|
|
|
|
|
114
|
9
|
|
|
|
|
18
|
my $_package = $_file; |
115
|
9
|
|
|
|
|
58
|
$_package =~ s/([^A-Za-z0-9_])/sprintf("_%2x", unpack("C", $1))/eg; |
|
106
|
|
|
|
|
402
|
|
116
|
|
|
|
|
|
|
|
117
|
9
|
|
|
|
|
136
|
local $0 = $_file; # so FindBin etc. works |
118
|
9
|
|
|
|
|
33
|
local @ARGV = (); # Some frameworks might try to parse @ARGV |
119
|
|
|
|
|
|
|
|
120
|
9
|
|
|
|
|
992
|
return eval sprintf <<'END_EVAL', $_package; |
121
|
|
|
|
|
|
|
package Plack::Sandbox::%s; |
122
|
|
|
|
|
|
|
{ |
123
|
|
|
|
|
|
|
my $app = do $_file; |
124
|
|
|
|
|
|
|
if ( !$app && ( my $error = $@ || $! )) { die $error; } |
125
|
|
|
|
|
|
|
$app; |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
END_EVAL |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
sub load_psgi { |
131
|
9
|
|
|
9
|
1
|
9051
|
my $stuff = shift; |
132
|
|
|
|
|
|
|
|
133
|
9
|
|
50
|
|
|
128
|
local $ENV{PLACK_ENV} = $ENV{PLACK_ENV} || 'development'; |
134
|
|
|
|
|
|
|
|
135
|
9
|
100
|
|
|
|
395
|
my $file = $stuff =~ /^[a-zA-Z0-9\_\:]+$/ ? class_to_file($stuff) : File::Spec->rel2abs($stuff); |
136
|
9
|
|
|
|
|
32
|
my $app = _load_sandbox($file); |
137
|
9
|
100
|
|
|
|
58
|
die "Error while loading $file: $@" if $@; |
138
|
|
|
|
|
|
|
|
139
|
7
|
|
|
|
|
53
|
return $app; |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
sub run_app($$) { |
143
|
740
|
|
|
740
|
1
|
2291
|
my($app, $env) = @_; |
144
|
|
|
|
|
|
|
|
145
|
740
|
|
66
|
|
|
2305
|
return eval { $app->($env) } || do { |
146
|
|
|
|
|
|
|
my $body = "Internal Server Error"; |
147
|
|
|
|
|
|
|
$env->{'psgi.errors'}->print($@); |
148
|
|
|
|
|
|
|
[ 500, [ 'Content-Type' => 'text/plain', 'Content-Length' => length($body) ], [ $body ] ]; |
149
|
|
|
|
|
|
|
}; |
150
|
|
|
|
|
|
|
} |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
sub headers { |
153
|
691
|
|
|
691
|
1
|
3413
|
my $headers = shift; |
154
|
|
|
|
|
|
|
inline_object( |
155
|
0
|
|
|
0
|
|
0
|
iter => sub { header_iter($headers, @_) }, |
156
|
21
|
|
|
21
|
|
49
|
get => sub { header_get($headers, @_) }, |
157
|
9
|
|
|
9
|
|
34
|
set => sub { header_set($headers, @_) }, |
158
|
587
|
|
|
587
|
|
2953
|
push => sub { header_push($headers, @_) }, |
159
|
1268
|
|
|
1268
|
|
4486
|
exists => sub { header_exists($headers, @_) }, |
160
|
22
|
|
|
22
|
|
56
|
remove => sub { header_remove($headers, @_) }, |
161
|
2
|
|
|
2
|
|
9
|
headers => sub { $headers }, |
162
|
691
|
|
|
|
|
42706
|
); |
163
|
|
|
|
|
|
|
} |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
sub header_iter { |
166
|
666
|
|
|
666
|
0
|
3388
|
my($headers, $code) = @_; |
167
|
|
|
|
|
|
|
|
168
|
666
|
|
|
|
|
3384
|
my @headers = @$headers; # copy |
169
|
666
|
|
|
|
|
9939
|
while (my($key, $val) = splice @headers, 0, 2) { |
170
|
1487
|
|
|
|
|
5051
|
$code->($key, $val); |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
sub header_get { |
175
|
26
|
|
|
26
|
1
|
2066
|
my($headers, $key) = (shift, lc shift); |
176
|
|
|
|
|
|
|
|
177
|
26
|
100
|
|
|
|
83
|
return () if not @$headers; |
178
|
|
|
|
|
|
|
|
179
|
24
|
|
|
|
|
44
|
my $i = 0; |
180
|
|
|
|
|
|
|
|
181
|
24
|
100
|
|
|
|
59
|
if (wantarray) { |
182
|
|
|
|
|
|
|
return map { |
183
|
2
|
100
|
33
|
|
|
11
|
$key eq lc $headers->[$i++] ? $headers->[$i++] : ++$i && (); |
|
4
|
|
|
|
|
38
|
|
184
|
|
|
|
|
|
|
} 1 .. @$headers/2; |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
|
187
|
22
|
|
|
|
|
69
|
while ($i < @$headers) { |
188
|
27
|
100
|
|
|
|
311
|
return $headers->[$i+1] if $key eq lc $headers->[$i]; |
189
|
5
|
|
|
|
|
11
|
$i += 2; |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
|
192
|
0
|
|
|
|
|
0
|
(); |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
sub header_set { |
196
|
30
|
|
|
30
|
1
|
2699
|
my($headers, $key, $val) = @_; |
197
|
|
|
|
|
|
|
|
198
|
30
|
100
|
|
|
|
105
|
@$headers = ($key, $val), return if not @$headers; |
199
|
|
|
|
|
|
|
|
200
|
28
|
|
|
|
|
141
|
my ($i, $_key) = (0, lc $key); |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
# locate and change existing header |
203
|
28
|
|
|
|
|
107
|
while ($i < @$headers) { |
204
|
35
|
100
|
|
|
|
164
|
$headers->[$i+1] = $val, last if $_key eq lc $headers->[$i]; |
205
|
27
|
|
|
|
|
74
|
$i += 2; |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
|
208
|
28
|
100
|
|
|
|
118
|
if ($i > $#$headers) { # didn't find it? |
209
|
20
|
|
|
|
|
60
|
push @$headers, $key, $val; |
210
|
20
|
|
|
|
|
96
|
return; |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
|
213
|
8
|
|
|
|
|
16
|
$i += 2; # found and changed it; so, first, skip that pair |
214
|
|
|
|
|
|
|
|
215
|
8
|
100
|
|
|
|
40
|
return if $i > $#$headers; # anything left? |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
# yes... so do the same thing as header_remove |
218
|
|
|
|
|
|
|
# but for the tail of the array only, starting at $i |
219
|
|
|
|
|
|
|
|
220
|
4
|
|
|
|
|
8
|
my $keep; |
221
|
|
|
|
|
|
|
my @keep = grep { |
222
|
4
|
100
|
|
|
|
14
|
$_ & 1 ? $keep : ($keep = $_key ne lc $headers->[$_]); |
|
10
|
|
|
|
|
50
|
|
223
|
|
|
|
|
|
|
} $i .. $#$headers; |
224
|
|
|
|
|
|
|
|
225
|
4
|
|
|
|
|
13
|
my $remainder = @$headers - $i; |
226
|
4
|
100
|
|
|
|
47
|
return if @keep == $remainder; # if we're not changing anything... |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
splice @$headers, $i, $remainder, ( _SPLICE_SAME_ARRAY_SEGFAULT |
229
|
1
|
|
|
|
|
3
|
? @{[ @$headers[@keep] ]} # force different source array |
230
|
|
|
|
|
|
|
: @$headers[@keep] |
231
|
|
|
|
|
|
|
); |
232
|
1
|
|
|
|
|
2
|
(); |
233
|
|
|
|
|
|
|
} |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
sub header_push { |
236
|
590
|
|
|
590
|
1
|
4239
|
my($headers, $key, $val) = @_; |
237
|
590
|
|
|
|
|
19535
|
push @$headers, $key, $val; |
238
|
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
sub header_exists { |
241
|
1275
|
|
|
1275
|
1
|
7763
|
my($headers, $key) = (shift, lc shift); |
242
|
|
|
|
|
|
|
|
243
|
1275
|
|
|
|
|
2124
|
my $check; |
244
|
1275
|
|
|
|
|
8890
|
for (@$headers) { |
245
|
3363
|
100
|
100
|
|
|
20093
|
return 1 if ($check = not $check) and $key eq lc; |
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
|
248
|
1186
|
|
|
|
|
17697
|
return !1; |
249
|
|
|
|
|
|
|
} |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
sub header_remove { |
252
|
40
|
|
|
40
|
1
|
3553
|
my($headers, $key) = (shift, lc shift); |
253
|
|
|
|
|
|
|
|
254
|
40
|
100
|
|
|
|
103
|
return if not @$headers; |
255
|
|
|
|
|
|
|
|
256
|
39
|
|
|
|
|
56
|
my $keep; |
257
|
|
|
|
|
|
|
my @keep = grep { |
258
|
39
|
100
|
|
|
|
133
|
$_ & 1 ? $keep : ($keep = $key ne lc $headers->[$_]); |
|
124
|
|
|
|
|
364
|
|
259
|
|
|
|
|
|
|
} 0 .. $#$headers; |
260
|
|
|
|
|
|
|
|
261
|
39
|
100
|
|
|
|
139
|
@$headers = @$headers[@keep] if @keep < @$headers; |
262
|
39
|
|
|
|
|
184
|
(); |
263
|
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
sub status_with_no_entity_body { |
266
|
672
|
|
|
672
|
1
|
2035
|
my $status = shift; |
267
|
672
|
|
66
|
|
|
31747
|
return $status < 200 || $status == 204 || $status == 304; |
268
|
|
|
|
|
|
|
} |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
sub encode_html { |
271
|
42
|
|
|
42
|
1
|
49
|
my $str = shift; |
272
|
42
|
|
|
|
|
57
|
$str =~ s/&/&/g; |
273
|
42
|
|
|
|
|
50
|
$str =~ s/>/>/g; |
274
|
42
|
|
|
|
|
53
|
$str =~ s/</g; |
275
|
42
|
|
|
|
|
50
|
$str =~ s/"/"/g; |
276
|
42
|
|
|
|
|
47
|
$str =~ s/'/'/g; |
277
|
42
|
|
|
|
|
104
|
return $str; |
278
|
|
|
|
|
|
|
} |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
sub inline_object { |
281
|
733
|
|
|
733
|
1
|
47477
|
my %args = @_; |
282
|
733
|
|
|
|
|
29612
|
bless \%args, 'Plack::Util::Prototype'; |
283
|
|
|
|
|
|
|
} |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
sub response_cb { |
286
|
762
|
|
|
762
|
1
|
3343
|
my($res, $cb) = @_; |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
my $body_filter = sub { |
289
|
762
|
|
|
762
|
|
2666
|
my($cb, $res) = @_; |
290
|
762
|
|
|
|
|
4179
|
my $filter_cb = $cb->($res); |
291
|
|
|
|
|
|
|
# If response_cb returns a callback, treat it as a $body filter |
292
|
760
|
100
|
100
|
|
|
7170
|
if (defined $filter_cb && ref $filter_cb eq 'CODE') { |
293
|
9
|
|
|
|
|
43
|
Plack::Util::header_remove($res->[1], 'Content-Length'); |
294
|
9
|
100
|
|
|
|
24
|
if (defined $res->[2]) { |
295
|
2
|
50
|
|
|
|
19
|
if (ref $res->[2] eq 'ARRAY') { |
296
|
2
|
|
|
|
|
4
|
for my $line (@{$res->[2]}) { |
|
2
|
|
|
|
|
6
|
|
297
|
3
|
|
|
|
|
19
|
$line = $filter_cb->($line); |
298
|
|
|
|
|
|
|
} |
299
|
|
|
|
|
|
|
# Send EOF. |
300
|
2
|
|
|
|
|
7
|
my $eof = $filter_cb->( undef ); |
301
|
2
|
50
|
|
|
|
14
|
push @{ $res->[2] }, $eof if defined $eof; |
|
0
|
|
|
|
|
0
|
|
302
|
|
|
|
|
|
|
} else { |
303
|
0
|
|
|
|
|
0
|
my $body = $res->[2]; |
304
|
0
|
|
|
|
|
0
|
my $getline = sub { $body->getline }; |
|
0
|
|
|
|
|
0
|
|
305
|
|
|
|
|
|
|
$res->[2] = Plack::Util::inline_object |
306
|
0
|
|
|
|
|
0
|
getline => sub { $filter_cb->($getline->()) }, |
307
|
0
|
|
|
|
|
0
|
close => sub { $body->close }; |
|
0
|
|
|
|
|
0
|
|
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
} else { |
310
|
7
|
|
|
|
|
19
|
return $filter_cb; |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
} |
313
|
762
|
|
|
|
|
30255
|
}; |
314
|
|
|
|
|
|
|
|
315
|
762
|
100
|
|
|
|
10941
|
if (ref $res eq 'ARRAY') { |
|
|
50
|
|
|
|
|
|
316
|
741
|
|
|
|
|
5863
|
$body_filter->($cb, $res); |
317
|
741
|
|
|
|
|
40374
|
return $res; |
318
|
|
|
|
|
|
|
} elsif (ref $res eq 'CODE') { |
319
|
|
|
|
|
|
|
return sub { |
320
|
21
|
|
|
21
|
|
94
|
my $respond = shift; |
321
|
21
|
|
|
|
|
36
|
my $cb = $cb; # To avoid the nested closure leak for 5.8.x |
322
|
|
|
|
|
|
|
$res->(sub { |
323
|
21
|
|
|
|
|
1500692
|
my $res = shift; |
324
|
21
|
|
|
|
|
54
|
my $filter_cb = $body_filter->($cb, $res); |
325
|
19
|
100
|
|
|
|
52
|
if ($filter_cb) { |
326
|
7
|
|
|
|
|
20
|
my $writer = $respond->($res); |
327
|
7
|
50
|
|
|
|
28
|
if ($writer) { |
328
|
|
|
|
|
|
|
return Plack::Util::inline_object |
329
|
10
|
|
|
|
|
27
|
write => sub { $writer->write($filter_cb->(@_)) }, |
330
|
|
|
|
|
|
|
close => sub { |
331
|
7
|
|
|
|
|
24
|
my $chunk = $filter_cb->(undef); |
332
|
7
|
50
|
|
|
|
32
|
$writer->write($chunk) if defined $chunk; |
333
|
7
|
|
|
|
|
34
|
$writer->close; |
334
|
7
|
|
|
|
|
55
|
}; |
335
|
|
|
|
|
|
|
} |
336
|
|
|
|
|
|
|
} else { |
337
|
12
|
|
|
|
|
47
|
return $respond->($res); |
338
|
|
|
|
|
|
|
} |
339
|
21
|
|
|
|
|
117
|
}); |
340
|
21
|
|
|
|
|
255
|
}; |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
|
343
|
0
|
|
|
|
|
0
|
return $res; |
344
|
|
|
|
|
|
|
} |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
package Plack::Util::Prototype; |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
our $AUTOLOAD; |
349
|
|
|
|
|
|
|
sub can { |
350
|
3
|
50
|
|
3
|
|
1225
|
return $_[0]->{$_[1]} if Scalar::Util::blessed($_[0]); |
351
|
0
|
|
|
|
|
0
|
goto &UNIVERSAL::can; |
352
|
|
|
|
|
|
|
} |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
sub AUTOLOAD { |
355
|
1997
|
|
|
1997
|
|
8516
|
my $self = shift; |
356
|
1997
|
|
|
|
|
7626
|
my $attr = $AUTOLOAD; |
357
|
1997
|
|
|
|
|
30908
|
$attr =~ s/.*://; |
358
|
1997
|
100
|
|
|
|
10058
|
if (ref($self->{$attr}) eq 'CODE') { |
359
|
1996
|
|
|
|
|
7003
|
$self->{$attr}->(@_); |
360
|
|
|
|
|
|
|
} else { |
361
|
1
|
|
|
|
|
162
|
Carp::croak(qq/Can't locate object method "$attr" via package "Plack::Util::Prototype"/); |
362
|
|
|
|
|
|
|
} |
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
0
|
|
|
sub DESTROY { } |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
package Plack::Util::IOWithPath; |
368
|
146
|
|
|
146
|
|
10214
|
use parent qw(IO::Handle); |
|
146
|
|
|
|
|
5982
|
|
|
146
|
|
|
|
|
1899
|
|
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
sub path { |
371
|
21
|
|
|
21
|
|
107
|
my $self = shift; |
372
|
21
|
100
|
|
|
|
93
|
if (@_) { |
373
|
19
|
|
|
|
|
74
|
${*$self}{+__PACKAGE__} = shift; |
|
19
|
|
|
|
|
223
|
|
374
|
|
|
|
|
|
|
} |
375
|
21
|
|
|
|
|
56
|
${*$self}{+__PACKAGE__}; |
|
21
|
|
|
|
|
91
|
|
376
|
|
|
|
|
|
|
} |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
package Plack::Util; |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
1; |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
__END__ |