File Coverage

blib/lib/Catalyst/Engine.pm
Criterion Covered Total %
statement 167 197 84.8
branch 50 58 86.2
condition 9 18 50.0
subroutine 28 35 80.0
pod 23 23 100.0
total 277 331 83.7


line stmt bran cond sub pod time code
1             package Catalyst::Engine;
2              
3 48     48   630 use strict;
  48         484  
  48         1383  
4 48     48   743 use base 'Class::Accessor::Fast';
  48         480  
  48         768  
5 48     48   2414 use CGI::Simple::Cookie;
  48         1008  
  48         1941  
6 48     48   991 use Data::Dump qw/dump/;
  48         492  
  48         753  
7 48     48   2616 use HTML::Entities;
  48         627  
  48         1494  
8 48     48   3212 use HTTP::Body;
  48         765  
  48         1390  
9 48     48   1120 use HTTP::Headers;
  48         463  
  48         960  
10 48     48   866 use URI::QueryParam;
  48         1074  
  48         1072  
11 48     48   780 use Scalar::Util ();
  48         442  
  48         503  
12              
13             # input position and length
14             __PACKAGE__->mk_accessors(qw/read_position read_length/);
15              
16             # Stringify to class
17 48     48   846 use overload '""' => sub { return ref shift }, fallback => 1;
  48     1901   523  
  48         782  
  1901         38857  
18              
19             # Amount of data to read from input on each pass
20             our $CHUNKSIZE = 64 * 1024;
21              
22             =head1 NAME
23            
24             Catalyst::Engine - The Catalyst Engine
25            
26             =head1 SYNOPSIS
27            
28             See L<Catalyst>.
29            
30             =head1 DESCRIPTION
31            
32             =head1 METHODS
33            
34            
35             =head2 $self->finalize_body($c)
36            
37             Finalize body. Prints the response output.
38            
39             =cut
40              
41             sub finalize_body {
42 816     816 1 35887     my ( $self, $c ) = @_;
43 816         13719     my $body = $c->response->body;
44 48     48   1010     no warnings 'uninitialized';
  48         485  
  48         1294  
45 816 100 66     22036     if ( Scalar::Util::blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
      66        
46 2         99         while ( !eof $body ) {
47 2         76             read $body, my ($buffer), $CHUNKSIZE;
48 2 50       31             last unless $self->write( $c, $buffer );
49                     }
50 2         49         close $body;
51                 }
52                 else {
53 814         19337         $self->write( $c, $body );
54                 }
55             }
56              
57             =head2 $self->finalize_cookies($c)
58            
59             Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
60             response headers.
61            
62             =cut
63              
64             sub finalize_cookies {
65 816     816 1 46345     my ( $self, $c ) = @_;
66              
67 816         10193     my @cookies;
68              
69 816         9432     foreach my $name ( keys %{ $c->response->cookies } ) {
  816         16150  
70              
71 6         796         my $val = $c->response->cookies->{$name};
72              
73 6 100 50     536         my $cookie = (
74                         Scalar::Util::blessed($val)
75                         ? $val
76                         : CGI::Simple::Cookie->new(
77                             -name => $name,
78                             -value => $val->{value},
79                             -expires => $val->{expires},
80                             -domain => $val->{domain},
81                             -path => $val->{path},
82                             -secure => $val->{secure} || 0
83                         )
84                     );
85              
86 6         2247         push @cookies, $cookie->as_string;
87                 }
88              
89 816         14237     for my $cookie (@cookies) {
90 6         494         $c->res->headers->push_header( 'Set-Cookie' => $cookie );
91                 }
92             }
93              
94             =head2 $self->finalize_error($c)
95            
96             Output an apropriate error message, called if there's an error in $c
97             after the dispatch has finished. Will output debug messages if Catalyst
98             is in debug mode, or a `please come back later` message otherwise.
99            
100             =cut
101              
102             sub finalize_error {
103 14     14 1 504     my ( $self, $c ) = @_;
104              
105 14         183     $c->res->content_type('text/html; charset=utf-8');
106 14   33     2507     my $name = $c->config->{name} || join(' ', split('::', ref $c));
107              
108 14         160     my ( $title, $error, $infos );
109 14 50       193     if ( $c->debug ) {
110              
111             # For pretty dumps
112 0         0         $error = join '', map {
113 0         0                 '<p><code class="error">'
114                           . encode_entities($_)
115                           . '</code></p>'
116 0         0         } @{ $c->error };
117 0   0     0         $error ||= 'No output';
118 0         0         $error = qq{<pre wrap="">$error</pre>};
119 0         0         $title = $name = "$name on Catalyst $Catalyst::VERSION";
120 0         0         $name = "<h1>$name</h1>";
121              
122             # Don't show context in the dump
123 0         0         delete $c->req->{_context};
124 0         0         delete $c->res->{_context};
125              
126             # Don't show body parser in the dump
127 0         0         delete $c->req->{_body};
128              
129             # Don't show response header state in dump
130 0         0         delete $c->res->{_finalized_headers};
131              
132 0         0         my @infos;
133 0         0         my $i = 0;
134 0         0         for my $dump ( $c->dump_these ) {
135 0         0             my $name = $dump->[0];
136 0         0             my $value = encode_entities( dump( $dump->[1] ));
137 0         0             push @infos, sprintf <<"EOF", $name, $value;
138             <h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
139             <div id="dump_$i">
140             <pre wrap="">%s</pre>
141             </div>
142             EOF
143 0         0             $i++;
144                     }
145 0         0         $infos = join "\n", @infos;
146                 }
147                 else {
148 14         125         $title = $name;
149 14         489         $error = '';
150 14         190         $infos = <<"";
151             <pre>
152             (en) Please come back later
153             (fr) SVP veuillez revenir plus tard
154             (de) Bitte versuchen sie es spaeter nocheinmal
155             (at) Konnten's bitt'schoen spaeter nochmal reinschauen
156             (no) Vennligst prov igjen senere
157             (dk) Venligst prov igen senere
158             (pl) Prosze sprobowac pozniej
159             </pre>
160            
161 14         130         $name = '';
162                 }
163 14         248     $c->res->body( <<"" );
164             <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
165             "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
166             <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
167             <head>
168             <meta http-equiv="Content-Language" content="en" />
169             <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
170             <title>$title</title>
171             <script type="text/javascript">
172             <!--
173             function toggleDump (dumpElement) {
174             var e = document.getElementById( dumpElement );
175             if (e.style.display == "none") {
176             e.style.display = "";
177             }
178             else {
179             e.style.display = "none";
180             }
181             }
182             -->
183             </script>
184             <style type="text/css">
185             body {
186             font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
187             Tahoma, Arial, helvetica, sans-serif;
188             color: #333;
189             background-color: #eee;
190             margin: 0px;
191             padding: 0px;
192             }
193             :link, :link:hover, :visited, :visited:hover {
194             color: #000;
195             }
196             div.box {
197             position: relative;
198             background-color: #ccc;
199             border: 1px solid #aaa;
200             padding: 4px;
201             margin: 10px;
202             }
203             div.error {
204             background-color: #cce;
205             border: 1px solid #755;
206             padding: 8px;
207             margin: 4px;
208             margin-bottom: 10px;
209             }
210             div.infos {
211             background-color: #eee;
212             border: 1px solid #575;
213             padding: 8px;
214             margin: 4px;
215             margin-bottom: 10px;
216             }
217             div.name {
218             background-color: #cce;
219             border: 1px solid #557;
220             padding: 8px;
221             margin: 4px;
222             }
223             code.error {
224             display: block;
225             margin: 1em 0;
226             overflow: auto;
227             }
228             div.name h1, div.error p {
229             margin: 0;
230             }
231             h2 {
232             margin-top: 0;
233             margin-bottom: 10px;
234             font-size: medium;
235             font-weight: bold;
236             text-decoration: underline;
237             }
238             h1 {
239             font-size: medium;
240             font-weight: normal;
241             }
242             /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
243             /* Browser specific (not valid) styles to make preformatted text wrap */
244             pre {
245             white-space: pre-wrap; /* css-3 */
246             white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
247             white-space: -pre-wrap; /* Opera 4-6 */
248             white-space: -o-pre-wrap; /* Opera 7 */
249             word-wrap: break-word; /* Internet Explorer 5.5+ */
250             }
251             </style>
252             </head>
253             <body>
254             <div class="box">
255             <div class="error">$error</div>
256             <div class="infos">$infos</div>
257             <div class="name">$name</div>
258             </div>
259             </body>
260             </html>
261            
262              
263             # Trick IE
264 14         336     $c->res->{body} .= ( ' ' x 512 );
265              
266             # Return 500
267 14         554     $c->res->status(500);
268             }
269              
270             =head2 $self->finalize_headers($c)
271            
272             Abstract method, allows engines to write headers to response
273            
274             =cut
275              
276 0     0 1 0 sub finalize_headers { }
277              
278             =head2 $self->finalize_read($c)
279            
280             =cut
281              
282             sub finalize_read {
283 11     11 1 129     my ( $self, $c ) = @_;
284              
285 11         152     undef $self->{_prepared_read};
286             }
287              
288             =head2 $self->finalize_uploads($c)
289            
290             Clean up after uploads, deleting temp files.
291            
292             =cut
293              
294             sub finalize_uploads {
295 816     816 1 24384     my ( $self, $c ) = @_;
296              
297 816 100       9453     if ( keys %{ $c->request->uploads } ) {
  816         13202  
298 5         43         for my $key ( keys %{ $c->request->uploads } ) {
  5         57  
299 8         434             my $upload = $c->request->uploads->{$key};
300 10         343             unlink map { $_->tempname }
  10         172  
301 1         12               grep { -e $_->tempname }
302 8 100       96               ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
303                     }
304                 }
305             }
306              
307             =head2 $self->prepare_body($c)
308            
309             sets up the L<Catalyst::Request> object body using L<HTTP::Body>
310            
311             =cut
312              
313             sub prepare_body {
314 818     818 1 29135     my ( $self, $c ) = @_;
315                 
316 818   100     12077     my $length = $c->request->header('Content-Length') || 0;
317              
318 818         167612     $self->read_length( $length );
319              
320 818 100       42323     if ( $length > 0 ) {
321 11 50       130         unless ( $c->request->{_body} ) {
322 11         615             my $type = $c->request->header('Content-Type');
323 11         2013             $c->request->{_body} = HTTP::Body->new( $type, $length );
324 11 50       1406             $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
325                           if exists $c->config->{uploadtmp};
326                     }
327                     
328 11         1552         while ( my $buffer = $self->read($c) ) {
329 12         435             $c->prepare_body_chunk($buffer);
330                     }
331              
332             # paranoia against wrong Content-Length header
333 11         132         my $remaining = $length - $self->read_position;
334 11 100       265         if ( $remaining > 0 ) {
335 1         18             $self->finalize_read($c);
336 1         129             Catalyst::Exception->throw(
337                             "Wrong Content-Length value: $length" );
338                     }
339                 }
340                 else {
341             # Defined but will cause all body code to be skipped
342 807         10654         $c->request->{_body} = 0;
343                 }
344             }
345              
346             =head2 $self->prepare_body_chunk($c)
347            
348             Add a chunk to the request body.
349            
350             =cut
351              
352             sub prepare_body_chunk {
353 12     12 1 821     my ( $self, $c, $chunk ) = @_;
354              
355 12         232