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     $c->request->{_body}->add($chunk);
356             }
357              
358             =head2 $self->prepare_body_parameters($c)
359            
360             Sets up parameters from body.
361            
362             =cut
363              
364             sub prepare_body_parameters {
365 817     817 1 35098     my ( $self, $c ) = @_;
366                 
367 817 100       13991     return unless $c->request->{_body};
368                 
369 10         367     $c->request->body_parameters( $c->request->{_body}->param );
370             }
371              
372             =head2 $self->prepare_connection($c)
373            
374             Abstract method implemented in engines.
375            
376             =cut
377              
378 0     0 1 0 sub prepare_connection { }
379              
380             =head2 $self->prepare_cookies($c)
381            
382             Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
383            
384             =cut
385              
386             sub prepare_cookies {
387 818     818 1 35395     my ( $self, $c ) = @_;
388              
389 818 100       16790     if ( my $header = $c->request->header('Cookie') ) {
390 1         148         $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
391                 }
392             }
393              
394             =head2 $self->prepare_headers($c)
395            
396             =cut
397              
398 0     0 1 0 sub prepare_headers { }
399              
400             =head2 $self->prepare_parameters($c)
401            
402             sets up parameters from query and post parameters.
403            
404             =cut
405              
406             sub prepare_parameters {
407 817     817 1 44414     my ( $self, $c ) = @_;
408              
409             # We copy, no references
410 817         7848     foreach my $name ( keys %{ $c->request->query_parameters } ) {
  817         13289  
411 11         121         my $param = $c->request->query_parameters->{$name};
412 11 100       116         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
  3         62  
413 11         120         $c->request->parameters->{$name} = $param;
414                 }
415              
416             # Merge query and body parameters
417 817         11475     foreach my $name ( keys %{ $c->request->body_parameters } ) {
  817         15302  
418 5         111         my $param = $c->request->body_parameters->{$name};
419 5 100       61         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
  2         23  
420 5 100       60         if ( my $old_param = $c->request->parameters->{$name} ) {
421 1 50       12             if ( ref $old_param eq 'ARRAY' ) {
422 1 50       10                 push @{ $c->request->parameters->{$name} },
  1         12  
423                               ref $param eq 'ARRAY' ? @$param : $param;
424                         }
425 0         0             else { $c->request->parameters->{$name} = [ $old_param, $param ] }
426                     }
427 4         49         else { $c->request->parameters->{$name} = $param }
428                 }
429             }
430              
431             =head2 $self->prepare_path($c)
432            
433             abstract method, implemented by engines.
434            
435             =cut
436              
437 0     0 1 0 sub prepare_path { }
438              
439             =head2 $self->prepare_request($c)
440            
441             =head2 $self->prepare_query_parameters($c)
442            
443             process the query string and extract query parameters.
444            
445             =cut
446              
447             sub prepare_query_parameters {
448 8     8 1 82     my ( $self, $c, $query_string ) = @_;
449              
450             # replace semi-colons
451 8         87     $query_string =~ s/;/&/g;
452              
453 8         145     my $u = URI->new( '', 'http' );
454 8         527     $u->query($query_string);
455 8         537     for my $key ( $u->query_param ) {
456 11         1953         my @vals = $u->query_param($key);
457 11 100       2304         $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
458                 }
459             }
460              
461             =head2 $self->prepare_read($c)
462            
463             prepare to read from the engine.
464            
465             =cut
466              
467             sub prepare_read {
468 11     11 1 111     my ( $self, $c ) = @_;
469              
470             # Reset the read position
471 11         174     $self->read_position(0);
472             }
473              
474             =head2 $self->prepare_request(@arguments)
475            
476             Populate the context object from the request object.
477            
478             =cut
479              
480 0     0 1 0 sub prepare_request { }
481              
482             =head2 $self->prepare_uploads($c)
483            
484             =cut
485              
486             sub prepare_uploads {
487 817     817 1 24846     my ( $self, $c ) = @_;
488                 
489 817 100       11799     return unless $c->request->{_body};
490                 
491 10         227     my $uploads = $c->request->{_body}->upload;
492 10         440     for my $name ( keys %$uploads ) {
493 8         73         my $files = $uploads->{$name};
494 8 100       94         $files = ref $files eq 'ARRAY' ? $files : [$files];
495 8         69         my @uploads;
496 8         105         for my $upload (@$files) {
497 10         151             my $u = Catalyst::Request::Upload->new;
498 10         322             $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
  10         174  
499 10         2833             $u->type( $u->headers->content_type );
500 10         1150             $u->tempname( $upload->{tempname} );
501 10         248             $u->size( $upload->{size} );
502 10         240             $u->filename( $upload->{filename} );
503 10         236             push @uploads, $u;
504                     }
505 8 100       109         $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
506              
507             # support access to the filename as a normal param
508 8         76         my @filenames = map { $_->{filename} } @uploads;
  10         112  
509             # append, if there's already params with this name
510 8 100       91         if (exists $c->request->parameters->{$name}) {
511 1 50       13             if (ref $c->request->parameters->{$name} eq 'ARRAY') {
512 0         0                 push @{ $c->request->parameters->{$name} }, @filenames;
  0         0  
513                         }
514                         else {
515 1         12                 $c->request->parameters->{$name} =
516                                 [ $c->request->parameters->{$name}, @filenames ];
517                         }
518                     }
519                     else {
520 7 100       85             $c->request->parameters->{$name} =
521                             @filenames > 1 ? \@filenames : $filenames[0];
522                     }
523                 }
524             }
525              
526             =head2 $self->prepare_write($c)
527            
528             Abstract method. Implemented by the engines.
529            
530             =cut
531              
532 39     39 1 1337 sub prepare_write { }
533              
534             =head2 $self->read($c, [$maxlength])
535            
536             =cut
537              
538             sub read {
539 23     23 1 8739     my ( $self, $c, $maxlength ) = @_;
540              
541 23 100       319     unless ( $self->{_prepared_read} ) {
542 11         144         $self->prepare_read($c);
543 11         297         $self->{_prepared_read} = 1;
544                 }
545              
546 23         357     my $remaining = $self->read_length - $self->read_position;
547 23   33     261     $maxlength ||= $CHUNKSIZE;
548              
549             # Are we done reading?
550 23 100       232     if ( $remaining <= 0 ) {
551 10         178         $self->finalize_read($c);
552 10         124         return;
553                 }
554              
555 13 100       137     my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
556 13         174     my $rc = $self->read_chunk( $c, my $buffer, $readlen );
557 13 50       1421     if ( defined $rc ) {
558 13         176         $self->read_position( $self->read_position + $rc );
559 13         502         return $buffer;
560                 }
561                 else {
562 0         0         Catalyst::Exception->throw(
563                         message => "Unknown error reading input: $!" );
564                 }
565             }
566              
567             =head2 $self->read_chunk($c, $buffer, $length)
568            
569             Each engine inplements read_chunk as its preferred way of reading a chunk
570             of data.
571            
572             =cut
573              
574 0     0 1 0 sub read_chunk { }
575              
576             =head2 $self->read_length
577            
578             The length of input data to be read. This is obtained from the Content-Length
579             header.
580            
581             =head2 $self->read_position
582            
583             The amount of input data that has already been read.
584            
585             =head2 $self->run($c)
586            
587             Start the engine. Implemented by the various engine classes.
588            
589             =cut
590              
591 0     0 1 0 sub run { }
592              
593             =head2 $self->write($c, $buffer)
594            
595             Writes the buffer to the client. Can only be called once for a request.
596            
597             =cut
598              
599             sub write {
600 846     846 1 13813     my ( $self, $c, $buffer ) = @_;
601              
602 846 100       11508     unless ( $self->{_prepared_write} ) {
603 39         650         $self->prepare_write($c);
604 39         576         $self->{_prepared_write} = 1;
605                 }
606              
607 846         39960     print STDOUT $buffer;
608             }
609              
610              
611             =head2 $self->finalize_output
612            
613             <obsolete>, see finalize_body
614            
615             =head1 AUTHORS
616            
617             Sebastian Riedel, <sri@cpan.org>
618            
619             Andy Grundman, <andy@hybridized.org>
620            
621             =head1 COPYRIGHT
622            
623             This program is free software, you can redistribute it and/or modify it under
624             the same terms as Perl itself.
625            
626             =cut
627              
628             1;
629