File Coverage

blib/lib/Plack/Util.pm
Criterion Covered Total %
statement 196 207 94.6
branch 75 88 85.2
condition 22 31 70.9
subroutine 40 42 95.2
pod 17 19 89.4
total 350 387 90.4


line stmt bran cond sub pod time code
1             package Plack::Util;
2 146     146   640119 use strict;
  146         305  
  146         3432  
3 146     146   600 use Carp ();
  146         211  
  146         1966  
4 146     146   603 use Scalar::Util;
  146         271  
  146         5404  
5 146     146   41521 use IO::Handle;
  146         480612  
  146         5158  
6 146     146   65705 use overload ();
  146         61233  
  146         2452  
7 146     146   754 use File::Spec ();
  146         288  
  146         8563  
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   1010 use constant _SPLICE_SAME_ARRAY_SEGFAULT => $] < '5.008007';
  146         470  
  146         31040  
14              
15             sub load_class {
16 109     109 1 888 my($class, $prefix) = @_;
17              
18 109 100       1336 if ($prefix) {
19 108 100 66     6122 unless ($class =~ s/^\+// || $class =~ /^$prefix/) {
20 61         292 $class = "$prefix\::$class";
21             }
22             }
23              
24 109         479 my $file = $class;
25 109         1907 $file =~ s!::!/!g;
26 109         70511 require "$file.pm"; ## no critic
27              
28 108         559 return $class;
29             }
30              
31             sub is_real_fh ($) {
32 13     13 1 2784 my $fh = shift;
33              
34             {
35 146     146   1323 no warnings 'uninitialized';
  146         242  
  146         296007  
  13         25  
36 13 100 66     192 return FALSE if -p $fh or -c _ or -b _;
      66        
37             }
38              
39 11 100       59 my $reftype = Scalar::Util::reftype($fh) or return;
40 9 100 100     37 if ( $reftype eq 'IO'
      66        
41 7         66 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         46 my $m_fileno = $fh->fileno;
50 7 50       50 return FALSE unless defined $m_fileno;
51 7 100       33 return FALSE unless $m_fileno >= 0;
52              
53 4         8 my $f_fileno = fileno($fh);
54 4 50       21 return FALSE unless defined $f_fileno;
55 4 50       11 return FALSE unless $f_fileno >= 0;
56 4         16 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         13 return FALSE;
62             }
63             }
64              
65             sub set_io_path {
66 19     19 1 156 my($fh, $path) = @_;
67 19         170 bless $fh, 'Plack::Util::IOWithPath';
68 19         116 $fh->path($path);
69             }
70              
71             sub content_length {
72 598     598 1 2185 my $body = shift;
73              
74 598 50       1841 return unless defined $body;
75              
76 598 100       2381 if (ref $body eq 'ARRAY') {
    100          
77 595         1253 my $cl = 0;
78 595         4341 for my $chunk (@$body) {
79 664         2113 $cl += length $chunk;
80             }
81 595         3668 return $cl;
82             } elsif ( is_real_fh($body) ) {
83 2         28 return (-s $body) - tell($body);
84             }
85              
86 1         9 return;
87             }
88              
89             sub foreach {
90 713     713 1 7017 my($body, $cb) = @_;
91              
92 713 100       2642 if (ref $body eq 'ARRAY') {
93 701         5063 for my $line (@$body) {
94 758 50       4355 $cb->($line) if length $line;
95             }
96             } else {
97 12 50       178 local $/ = \65536 unless ref $/;
98 12         1272 while (defined(my $line = $body->getline)) {
99 10 50       1256 $cb->($line) if length $line;
100             }
101 6         818 $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   14 my $_file = shift;
113              
114 9         16 my $_package = $_file;
115 9         45 $_package =~ s/([^A-Za-z0-9_])/sprintf("_%2x", unpack("C", $1))/eg;
  106         322  
116              
117 9         121 local $0 = $_file; # so FindBin etc. works
118 9         28 local @ARGV = (); # Some frameworks might try to parse @ARGV
119              
120 9         806 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 6508 my $stuff = shift;
132              
133 9   50     101 local $ENV{PLACK_ENV} = $ENV{PLACK_ENV} || 'development';
134              
135 9 100       303 my $file = $stuff =~ /^[a-zA-Z0-9\_\:]+$/ ? class_to_file($stuff) : File::Spec->rel2abs($stuff);
136 9         30 my $app = _load_sandbox($file);
137 9 100       46 die "Error while loading $file: $@" if $@;
138              
139 7         35 return $app;
140             }
141              
142             sub run_app($$) {
143 740     740 1 2094 my($app, $env) = @_;
144              
145 740   66     2396 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 2766 my $headers = shift;
154             inline_object(
155 0     0   0 iter => sub { header_iter($headers, @_) },
156 21     21   53 get => sub { header_get($headers, @_) },
157 9     9   29 set => sub { header_set($headers, @_) },
158 587     587   2308 push => sub { header_push($headers, @_) },
159 1268     1268   6535 exists => sub { header_exists($headers, @_) },
160 22     22   43 remove => sub { header_remove($headers, @_) },
161 2     2   7 headers => sub { $headers },
162 691         29216 );
163             }
164              
165             sub header_iter {
166 666     666 0 2402 my($headers, $code) = @_;
167              
168 666         2233 my @headers = @$headers; # copy
169 666         6079 while (my($key, $val) = splice @headers, 0, 2) {
170 1487         4618 $code->($key, $val);
171             }
172             }
173              
174             sub header_get {
175 26     26 1 2656 my($headers, $key) = (shift, lc shift);
176              
177 26 100       71 return () if not @$headers;
178              
179 24         37 my $i = 0;
180              
181 24 100       62 if (wantarray) {
182             return map {
183 2 100 33     10 $key eq lc $headers->[$i++] ? $headers->[$i++] : ++$i && ();
  4         37  
184             } 1 .. @$headers/2;
185             }
186              
187 22         44 while ($i < @$headers) {
188 27 100       230 return $headers->[$i+1] if $key eq lc $headers->[$i];
189 5         8 $i += 2;
190             }
191              
192 0         0 ();
193             }
194              
195             sub header_set {
196 30     30 1 2199 my($headers, $key, $val) = @_;
197              
198 30 100       101 @$headers = ($key, $val), return if not @$headers;
199              
200 28         95 my ($i, $_key) = (0, lc $key);
201              
202             # locate and change existing header
203 28         94 while ($i < @$headers) {
204 35 100       137 $headers->[$i+1] = $val, last if $_key eq lc $headers->[$i];
205 27         59 $i += 2;
206             }
207              
208 28 100       75 if ($i > $#$headers) { # didn't find it?
209 20         53 push @$headers, $key, $val;
210 20         70 return;
211             }
212              
213 8         12 $i += 2; # found and changed it; so, first, skip that pair
214              
215 8 100       29 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         10 my $keep;
221             my @keep = grep {
222 4 100       11 $_ & 1 ? $keep : ($keep = $_key ne lc $headers->[$_]);
  10         49  
223             } $i .. $#$headers;
224              
225 4         11 my $remainder = @$headers - $i;
226 4 100       35 return if @keep == $remainder; # if we're not changing anything...
227              
228             splice @$headers, $i, $remainder, ( _SPLICE_SAME_ARRAY_SEGFAULT
229 1         2 ? @{[ @$headers[@keep] ]} # force different source array
230             : @$headers[@keep]
231             );
232 1         3 ();
233             }
234              
235             sub header_push {
236 590     590 1 3503 my($headers, $key, $val) = @_;
237 590         9449 push @$headers, $key, $val;
238             }
239              
240             sub header_exists {
241 1275     1275 1 8434 my($headers, $key) = (shift, lc shift);
242              
243 1275         2232 my $check;
244 1275         6308 for (@$headers) {
245 3363 100 100     15765 return 1 if ($check = not $check) and $key eq lc;
246             }
247              
248 1186         17691 return !1;
249             }
250              
251             sub header_remove {
252 40     40 1 2966 my($headers, $key) = (shift, lc shift);
253              
254 40 100       100 return if not @$headers;
255              
256 39         47 my $keep;
257             my @keep = grep {
258 39 100       78 $_ & 1 ? $keep : ($keep = $key ne lc $headers->[$_]);
  124         311  
259             } 0 .. $#$headers;
260              
261 39 100       132 @$headers = @$headers[@keep] if @keep < @$headers;
262 39         147 ();
263             }
264              
265             sub status_with_no_entity_body {
266 672     672 1 3427 my $status = shift;
267 672   66     28206 return $status < 200 || $status == 204 || $status == 304;
268             }
269              
270             sub encode_html {
271 42     42 1 46 my $str = shift;
272 42         43 $str =~ s/&/&/g;
273 42         41 $str =~ s/>/>/g;
274 42         38 $str =~ s/
275 42         39 $str =~ s/"/"/g;
276 42         32 $str =~ s/'/'/g;
277 42         89 return $str;
278             }
279              
280             sub inline_object {
281 733     733 1 30234 my %args = @_;
282 733         22861 bless \%args, 'Plack::Util::Prototype';
283             }
284              
285             sub response_cb {
286 762     762 1 2654 my($res, $cb) = @_;
287              
288             my $body_filter = sub {
289 762     762   1695 my($cb, $res) = @_;
290 762         3123 my $filter_cb = $cb->($res);
291             # If response_cb returns a callback, treat it as a $body filter
292 760 100 100     4856 if (defined $filter_cb && ref $filter_cb eq 'CODE') {
293 9         40 Plack::Util::header_remove($res->[1], 'Content-Length');
294 9 100       23 if (defined $res->[2]) {
295 2 50       7 if (ref $res->[2] eq 'ARRAY') {
296 2         3 for my $line (@{$res->[2]}) {
  2         6  
297 3         14 $line = $filter_cb->($line);
298             }
299             # Send EOF.
300 2         12 my $eof = $filter_cb->( undef );
301 2 50       13 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         15 return $filter_cb;
311             }
312             }
313 762         22928 };
314              
315 762 100       8255 if (ref $res eq 'ARRAY') {
    50          
316 741         3071 $body_filter->($cb, $res);
317 741         33814 return $res;
318             } elsif (ref $res eq 'CODE') {
319             return sub {
320 21     21   135 my $respond = shift;
321 21         36 my $cb = $cb; # To avoid the nested closure leak for 5.8.x
322             $res->(sub {
323 21         1500538 my $res = shift;
324 21         58 my $filter_cb = $body_filter->($cb, $res);
325 19 100       43 if ($filter_cb) {
326 7         19 my $writer = $respond->($res);
327 7 50       23 if ($writer) {
328             return Plack::Util::inline_object
329 10         21 write => sub { $writer->write($filter_cb->(@_)) },
330             close => sub {
331 7         17 my $chunk = $filter_cb->(undef);
332 7 50       19 $writer->write($chunk) if defined $chunk;
333 7         35 $writer->close;
334 7         51 };
335             }
336             } else {
337 12         34 return $respond->($res);
338             }
339 21         98 });
340 21         195 };
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   858 return $_[0]->{$_[1]} if Scalar::Util::blessed($_[0]);
351 0         0 goto &UNIVERSAL::can;
352             }
353              
354             sub AUTOLOAD {
355 1997     1997   6477 my $self = shift;
356 1997         4268 my $attr = $AUTOLOAD;
357 1997         21510 $attr =~ s/.*://;
358 1997 100       7471 if (ref($self->{$attr}) eq 'CODE') {
359 1996         5786 $self->{$attr}->(@_);
360             } else {
361 1         104 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   8603 use parent qw(IO::Handle);
  146         5223  
  146         1129  
369              
370             sub path {
371 21     21   86 my $self = shift;
372 21 100       81 if (@_) {
373 19         75 ${*$self}{+__PACKAGE__} = shift;
  19         171  
374             }
375 21         59 ${*$self}{+__PACKAGE__};
  21         76  
376             }
377              
378             package Plack::Util;
379              
380             1;
381              
382             __END__