Added recursive -r flag to prove example
[catagits/Catalyst-Runtime.git] / lib / Catalyst / Engine.pm
CommitLineData
fc7ec1d9 1package Catalyst::Engine;
2
3use strict;
424b2705 4use base qw/Class::Data::Inheritable Class::Accessor::Fast/;
d70195d8 5use attributes ();
fc7ec1d9 6use UNIVERSAL::require;
6dc87a0f 7use CGI::Cookie;
fc7ec1d9 8use Data::Dumper;
9use HTML::Entities;
10use HTTP::Headers;
11use Time::HiRes qw/gettimeofday tv_interval/;
0f7ecc53 12use Text::ASCIITable;
a2f2cde9 13use Catalyst::Exception;
fc7ec1d9 14use Catalyst::Request;
146554c5 15use Catalyst::Request::Upload;
fc7ec1d9 16use Catalyst::Response;
a268a011 17use Catalyst::Utils;
fc7ec1d9 18
1abd6db7 19__PACKAGE__->mk_classdata('components');
6ef62eb2 20__PACKAGE__->mk_accessors(qw/counter depth request response state/);
fc7ec1d9 21
fc7ec1d9 22*comp = \&component;
23*req = \&request;
24*res = \&response;
25
06e1b616 26# For backwards compatibility
27*finalize_output = \&finalize_body;
28
99fe1710 29# For statistics
e88fa058 30our $COUNT = 1;
31our $START = time;
32our $RECURSION = 1000;
6ef62eb2 33our $DETACH = "catalyst_detach\n";
fc7ec1d9 34
35=head1 NAME
36
37Catalyst::Engine - The Catalyst Engine
38
39=head1 SYNOPSIS
40
41See L<Catalyst>.
42
43=head1 DESCRIPTION
44
23f9d934 45=head1 METHODS
fc7ec1d9 46
23f9d934 47=over 4
48
23f9d934 49=item $c->benchmark($coderef)
fc7ec1d9 50
51Takes a coderef with arguments and returns elapsed time as float.
52
53 my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
54 $c->log->info( sprintf "Processing took %f seconds", $elapsed );
55
56=cut
57
58sub benchmark {
59 my $c = shift;
60 my $code = shift;
61 my $time = [gettimeofday];
62 my @return = &$code(@_);
63 my $elapsed = tv_interval $time;
64 return wantarray ? ( $elapsed, @return ) : $elapsed;
65}
66
23f9d934 67=item $c->comp($name)
68
69=item $c->component($name)
fc7ec1d9 70
71Get a component object by name.
72
73 $c->comp('MyApp::Model::MyModel')->do_stuff;
74
75Regex search for a component.
76
77 $c->comp('mymodel')->do_stuff;
78
79=cut
80
81sub component {
3245f607 82 my $c = shift;
99fe1710 83
e88fa058 84 if (@_) {
99fe1710 85
3245f607 86 my $name = shift;
87
88 if ( my $component = $c->components->{$name} ) {
89 return $component;
90 }
91
92 else {
93 for my $component ( keys %{ $c->components } ) {
94 return $c->components->{$component} if $component =~ /$name/i;
95 }
fc7ec1d9 96 }
97 }
99fe1710 98
3245f607 99 return sort keys %{ $c->components };
fc7ec1d9 100}
101
e88fa058 102=item $c->counter
103
104Returns a hashref containing coderefs and execution counts.
105(Needed for deep recursion detection)
106
6ef62eb2 107=item $c->depth
108
109Returns the actual forward depth.
110
a554cc3b 111=item $c->error
23f9d934 112
a554cc3b 113=item $c->error($error, ...)
23f9d934 114
a554cc3b 115=item $c->error($arrayref)
fc7ec1d9 116
a554cc3b 117Returns an arrayref containing error messages.
fc7ec1d9 118
a554cc3b 119 my @error = @{ $c->error };
fc7ec1d9 120
121Add a new error.
122
a554cc3b 123 $c->error('Something bad happened');
fc7ec1d9 124
125=cut
126
a554cc3b 127sub error {
fc7ec1d9 128 my $c = shift;
a554cc3b 129 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
130 push @{ $c->{error} }, @$error;
131 return $c->{error};
fc7ec1d9 132}
133
6dc87a0f 134=item $c->execute($class, $coderef)
135
136Execute a coderef in given class and catch exceptions.
137Errors are available via $c->error.
138
139=cut
140
141sub execute {
142 my ( $c, $class, $code ) = @_;
91571b7b 143 $class = $c->components->{$class} || $class;
6dc87a0f 144 $c->state(0);
39de91b0 145 my $callsub = ( caller(1) )[3];
99fe1710 146
e88fa058 147 my $action = '';
148 if ( $c->debug ) {
149 $action = $c->actions->{reverse}->{"$code"};
150 $action = "/$action" unless $action =~ /\-\>/;
151 $c->counter->{"$code"}++;
152
153 if ( $c->counter->{"$code"} > $RECURSION ) {
154 my $error = qq/Deep recursion detected in "$action"/;
155 $c->log->error($error);
156 $c->error($error);
157 $c->state(0);
158 return $c->state;
159 }
160
161 $action = "-> $action" if $callsub =~ /forward$/;
162 }
163
6ef62eb2 164 $c->{depth}++;
6dc87a0f 165 eval {
166 if ( $c->debug )
167 {
6ef62eb2 168 my ( $elapsed, @state ) =
169 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
0f7ecc53 170 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
6dc87a0f 171 $c->state(@state);
172 }
3ceed047 173 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) }
6dc87a0f 174 };
6ef62eb2 175 $c->{depth}--;
99fe1710 176
6dc87a0f 177 if ( my $error = $@ ) {
b9ffe28b 178
6ef62eb2 179 if ( $error eq $DETACH ) { die $DETACH if $c->{depth} > 1 }
180 else {
181 unless ( ref $error ) {
182 chomp $error;
183 $error = qq/Caught exception "$error"/;
184 }
b9ffe28b 185
6ef62eb2 186 $c->log->error($error);
187 $c->error($error);
188 $c->state(0);
189 }
6dc87a0f 190 }
191 return $c->state;
192}
193
23f9d934 194=item $c->finalize
fc7ec1d9 195
ca39d576 196Finalize request.
fc7ec1d9 197
198=cut
199
200sub finalize {
201 my $c = shift;
23f9d934 202
6dc87a0f 203 $c->finalize_cookies;
204
49490aab 205 if ( my $location = $c->response->redirect ) {
23f9d934 206 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
6dc87a0f 207 $c->response->header( Location => $location );
e7c0c583 208 $c->response->status(302) if $c->response->status !~ /^3\d\d$/;
6dc87a0f 209 }
210
969647fd 211 if ( $#{ $c->error } >= 0 ) {
212 $c->finalize_error;
23f9d934 213 }
6ef62eb2 214
d290eee8 215 if ( !$c->response->body && $c->response->status == 200 ) {
969647fd 216 $c->finalize_error;
217 }
fc7ec1d9 218
d7945f32 219 if ( $c->response->body && !$c->response->content_length ) {
d290eee8 220 $c->response->content_length( bytes::length( $c->response->body ) );
221 }
6ef62eb2 222
d290eee8 223 if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
224 $c->response->headers->remove_header("Content-Length");
225 $c->response->body('');
226 }
6ef62eb2 227
d290eee8 228 if ( $c->request->method eq 'HEAD' ) {
229 $c->response->body('');
fc7ec1d9 230 }
969647fd 231
fc7ec1d9 232 my $status = $c->finalize_headers;
06e1b616 233 $c->finalize_body;
fc7ec1d9 234 return $status;
235}
236
cd3bb248 237=item $c->finalize_output
238
239<obsolete>, see finalize_body
240
06e1b616 241=item $c->finalize_body
242
243Finalize body.
244
245=cut
246
247sub finalize_body { }
248
6dc87a0f 249=item $c->finalize_cookies
250
251Finalize cookies.
252
253=cut
254
255sub finalize_cookies {
256 my $c = shift;
257
258 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
259 my $cookie = CGI::Cookie->new(
260 -name => $name,
261 -value => $cookie->{value},
262 -expires => $cookie->{expires},
263 -domain => $cookie->{domain},
264 -path => $cookie->{path},
265 -secure => $cookie->{secure} || 0
266 );
267
268 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
269 }
270}
271
969647fd 272=item $c->finalize_error
273
ca39d576 274Finalize error.
969647fd 275
276=cut
277
278sub finalize_error {
279 my $c = shift;
280
281 $c->res->headers->content_type('text/html');
282 my $name = $c->config->{name} || 'Catalyst Application';
283
284 my ( $title, $error, $infos );
285 if ( $c->debug ) {
62d9b030 286
287 # For pretty dumps
288 local $Data::Dumper::Terse = 1;
289 $error = join '',
290 map { '<code class="error">' . encode_entities($_) . '</code>' }
291 @{ $c->error };
969647fd 292 $error ||= 'No output';
293 $title = $name = "$name on Catalyst $Catalyst::VERSION";
294 my $req = encode_entities Dumper $c->req;
295 my $res = encode_entities Dumper $c->res;
296 my $stash = encode_entities Dumper $c->stash;
297 $infos = <<"";
298<br/>
299<b><u>Request</u></b><br/>
300<pre>$req</pre>
301<b><u>Response</u></b><br/>
302<pre>$res</pre>
303<b><u>Stash</u></b><br/>
304<pre>$stash</pre>
305
306 }
307 else {
308 $title = $name;
309 $error = '';
310 $infos = <<"";
311<pre>
312(en) Please come back later
313(de) Bitte versuchen sie es spaeter nocheinmal
314(nl) Gelieve te komen later terug
315(no) Vennligst prov igjen senere
316(fr) Veuillez revenir plus tard
317(es) Vuelto por favor mas adelante
318(pt) Voltado por favor mais tarde
319(it) Ritornato prego piĆ¹ successivamente
320</pre>
321
322 $name = '';
323 }
e060fe05 324 $c->res->body( <<"" );
969647fd 325<html>
326<head>
327 <title>$title</title>
328 <style type="text/css">
329 body {
330 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
331 Tahoma, Arial, helvetica, sans-serif;
332 color: #ddd;
333 background-color: #eee;
334 margin: 0px;
335 padding: 0px;
336 }
337 div.box {
338 background-color: #ccc;
339 border: 1px solid #aaa;
340 padding: 4px;
341 margin: 10px;
342 -moz-border-radius: 10px;
343 }
344 div.error {
345 background-color: #977;
346 border: 1px solid #755;
347 padding: 8px;
348 margin: 4px;
349 margin-bottom: 10px;
350 -moz-border-radius: 10px;
351 }
352 div.infos {
353 background-color: #797;
354 border: 1px solid #575;
355 padding: 8px;
356 margin: 4px;
357 margin-bottom: 10px;
358 -moz-border-radius: 10px;
359 }
360 div.name {
361 background-color: #779;
362 border: 1px solid #557;
363 padding: 8px;
364 margin: 4px;
365 -moz-border-radius: 10px;
366 }
7f8e0078 367 code.error {
368 display: block;
369 margin: 1em 0;
370 overflow: auto;
371 white-space: pre;
372 }
969647fd 373 </style>
374</head>
375<body>
376 <div class="box">
377 <div class="error">$error</div>
378 <div class="infos">$infos</div>
379 <div class="name">$name</div>
380 </div>
381</body>
382</html>
383
384}
385
23f9d934 386=item $c->finalize_headers
fc7ec1d9 387
ca39d576 388Finalize headers.
fc7ec1d9 389
390=cut
391
392sub finalize_headers { }
393
e2fd5b5f 394=item $c->handler( $class, @arguments )
fc7ec1d9 395
ca39d576 396Handles the request.
fc7ec1d9 397
398=cut
399
6dc87a0f 400sub handler {
e2fd5b5f 401 my ( $class, @arguments ) = @_;
fc7ec1d9 402
403 # Always expect worst case!
404 my $status = -1;
405 eval {
d41516b2 406 my @stats = ();
99fe1710 407
fc7ec1d9 408 my $handler = sub {
e2fd5b5f 409 my $c = $class->prepare(@arguments);
d41516b2 410 $c->{stats} = \@stats;
63b763c5 411 $c->dispatch;
fc7ec1d9 412 return $c->finalize;
413 };
99fe1710 414
fc7ec1d9 415 if ( $class->debug ) {
416 my $elapsed;
417 ( $elapsed, $status ) = $class->benchmark($handler);
418 $elapsed = sprintf '%f', $elapsed;
e88fa058 419 my $av = sprintf '%.3f',
420 ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
0f7ecc53 421 my $t = Text::ASCIITable->new;
422 $t->setCols( 'Action', 'Time' );
3f36a3a3 423 $t->setColWidth( 'Action', 64, 1 );
424 $t->setColWidth( 'Time', 9, 1 );
0822f9a4 425
cd677e12 426 for my $stat (@stats) { $t->addRow( $stat->[0], $stat->[1] ) }
62d9b030 427 $class->log->info(
428 "Request took ${elapsed}s ($av/s)\n" . $t->draw );
fc7ec1d9 429 }
430 else { $status = &$handler }
99fe1710 431
fc7ec1d9 432 };
99fe1710 433
fc7ec1d9 434 if ( my $error = $@ ) {
435 chomp $error;
436 $class->log->error(qq/Caught exception in engine "$error"/);
437 }
99fe1710 438
fc7ec1d9 439 $COUNT++;
440 return $status;
441}
442
e2fd5b5f 443=item $c->prepare(@arguments)
fc7ec1d9 444
a554cc3b 445Turns the engine-specific request( Apache, CGI ... )
446into a Catalyst context .
fc7ec1d9 447
448=cut
449
450sub prepare {
e2fd5b5f 451 my ( $class, @arguments ) = @_;
99fe1710 452
fc7ec1d9 453 my $c = bless {
e88fa058 454 counter => {},
6ef62eb2 455 depth => 0,
fc7ec1d9 456 request => Catalyst::Request->new(
457 {
458 arguments => [],
459 cookies => {},
460 headers => HTTP::Headers->new,
461 parameters => {},
bfde09a2 462 secure => 0,
fc7ec1d9 463 snippets => [],
464 uploads => {}
465 }
466 ),
467 response => Catalyst::Response->new(
bfde09a2 468 {
03222156 469 body => '',
bfde09a2 470 cookies => {},
d290eee8 471 headers => HTTP::Headers->new( 'Content-Length' => 0 ),
03222156 472 status => 200
bfde09a2 473 }
fc7ec1d9 474 ),
b768faa3 475 stash => {},
476 state => 0
fc7ec1d9 477 }, $class;
99fe1710 478
fc7ec1d9 479 if ( $c->debug ) {
480 my $secs = time - $START || 1;
481 my $av = sprintf '%.3f', $COUNT / $secs;
1a0250cb 482 $c->log->debug('**********************************');
fc7ec1d9 483 $c->log->debug("* Request $COUNT ($av/s) [$$]");
1a0250cb 484 $c->log->debug('**********************************');
fc7ec1d9 485 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
486 }
99fe1710 487
e2fd5b5f 488 $c->prepare_request(@arguments);
bfde09a2 489 $c->prepare_connection;
ac733264 490 $c->prepare_headers;
1a80619d 491 $c->prepare_cookies;
bfde09a2 492 $c->prepare_path;
06e1b616 493 $c->prepare_action;
99fe1710 494
6ef62eb2 495 my $method = $c->req->method || '';
496 my $path = $c->req->path || '';
497 my $address = $c->req->address || '';
06e1b616 498
b4ca0ee8 499 $c->log->debug(qq/"$method" request for "$path" from $address/)
0556eb49 500 if $c->debug;
99fe1710 501
06e1b616 502 if ( $c->request->method eq 'POST' and $c->request->content_length ) {
503
504 if ( $c->req->content_type eq 'application/x-www-form-urlencoded' ) {
505 $c->prepare_parameters;
506 }
507 elsif ( $c->req->content_type eq 'multipart/form-data' ) {
508 $c->prepare_parameters;
509 $c->prepare_uploads;
510 }
511 else {
512 $c->prepare_body;
513 }
514 }
515
516 if ( $c->request->method eq 'GET' ) {
517 $c->prepare_parameters;
518 }
c85ff642 519
520 if ( $c->debug && keys %{ $c->req->params } ) {
0f7ecc53 521 my $t = Text::ASCIITable->new;
522 $t->setCols( 'Key', 'Value' );
0822f9a4 523 $t->setColWidth( 'Key', 37, 1 );
524 $t->setColWidth( 'Value', 36, 1 );
f78172f1 525 for my $key ( sort keys %{ $c->req->params } ) {
6d1ab915 526 my $param = $c->req->params->{$key};
527 my $value = defined($param) ? $param : '';
cd677e12 528 $t->addRow( $key, $value );
c85ff642 529 }
f45789b1 530 $c->log->debug( "Parameters are:\n" . $t->draw );
c85ff642 531 }
99fe1710 532
fc7ec1d9 533 return $c;
534}
535
23f9d934 536=item $c->prepare_action
fc7ec1d9 537
ca39d576 538Prepare action.
fc7ec1d9 539
540=cut
541
542sub prepare_action {
543 my $c = shift;
544 my $path = $c->req->path;
545 my @path = split /\//, $c->req->path;
546 $c->req->args( \my @args );
99fe1710 547
fc7ec1d9 548 while (@path) {
7833fdfc 549 $path = join '/', @path;
0169d3a8 550 if ( my $result = ${ $c->get_action($path) }[0] ) {
fc7ec1d9 551
552 # It's a regex
553 if ($#$result) {
7e5adedd 554 my $match = $result->[1];
555 my @snippets = @{ $result->[2] };
81f6fc50 556 $c->log->debug(
557 qq/Requested action is "$path" and matched "$match"/)
fc7ec1d9 558 if $c->debug;
559 $c->log->debug(
560 'Snippets are "' . join( ' ', @snippets ) . '"' )
561 if ( $c->debug && @snippets );
562 $c->req->action($match);
563 $c->req->snippets( \@snippets );
564 }
99fe1710 565
fc7ec1d9 566 else {
567 $c->req->action($path);
81f6fc50 568 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
fc7ec1d9 569 }
99fe1710 570
fc7ec1d9 571 $c->req->match($path);
fc7ec1d9 572 last;
573 }
574 unshift @args, pop @path;
575 }
99fe1710 576
fc7ec1d9 577 unless ( $c->req->action ) {
ac733264 578 $c->req->action('default');
87e67021 579 $c->req->match('');
fc7ec1d9 580 }
99fe1710 581
5783a9a5 582 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
583 if ( $c->debug && @args );
fc7ec1d9 584}
585
06e1b616 586=item $c->prepare_body
587
588Prepare message body.
589
590=cut
591
592sub prepare_body { }
593
c9afa5fc 594=item $c->prepare_connection
0556eb49 595
ca39d576 596Prepare connection.
0556eb49 597
598=cut
599
600sub prepare_connection { }
601
c9afa5fc 602=item $c->prepare_cookies
fc7ec1d9 603
ca39d576 604Prepare cookies.
fc7ec1d9 605
606=cut
607
6dc87a0f 608sub prepare_cookies {
609 my $c = shift;
610
611 if ( my $header = $c->request->header('Cookie') ) {
612 $c->req->cookies( { CGI::Cookie->parse($header) } );
613 }
614}
fc7ec1d9 615
23f9d934 616=item $c->prepare_headers
fc7ec1d9 617
ca39d576 618Prepare headers.
fc7ec1d9 619
620=cut
621
622sub prepare_headers { }
623
23f9d934 624=item $c->prepare_parameters
fc7ec1d9 625
ca39d576 626Prepare parameters.
fc7ec1d9 627
628=cut
629
630sub prepare_parameters { }
631
23f9d934 632=item $c->prepare_path
fc7ec1d9 633
ca39d576 634Prepare path and base.
fc7ec1d9 635
636=cut
637
638sub prepare_path { }
639
23f9d934 640=item $c->prepare_request
fc7ec1d9 641
ca39d576 642Prepare the engine request.
fc7ec1d9 643
644=cut
645
646sub prepare_request { }
647
23f9d934 648=item $c->prepare_uploads
fc7ec1d9 649
ca39d576 650Prepare uploads.
fc7ec1d9 651
652=cut
653
654sub prepare_uploads { }
655
c9afa5fc 656=item $c->run
657
ca39d576 658Starts the engine.
c9afa5fc 659
660=cut
661
662sub run { }
663
61b1e958 664=item $c->request
fc7ec1d9 665
ca39d576 666=item $c->req
23f9d934 667
ca39d576 668Returns a C<Catalyst::Request> object.
fc7ec1d9 669
ca39d576 670 my $req = $c->req;
61b1e958 671
672=item $c->response
673
ca39d576 674=item $c->res
675
fc7ec1d9 676Returns a C<Catalyst::Response> object.
677
678 my $res = $c->res;
679
63b763c5 680=item $c->state
681
682Contains the return value of the last executed action.
683
23f9d934 684=item $c->stash
fc7ec1d9 685
ca39d576 686Returns a hashref containing all your data.
fc7ec1d9 687
688 $c->stash->{foo} ||= 'yada';
689 print $c->stash->{foo};
690
691=cut
692
693sub stash {
694 my $self = shift;
e88fa058 695 if (@_) {
c19e2f4a 696 my $stash = @_ > 1 ? {@_} : $_[0];
fc7ec1d9 697 while ( my ( $key, $val ) = each %$stash ) {
698 $self->{stash}->{$key} = $val;
699 }
700 }
701 return $self->{stash};
702}
703
23f9d934 704=back
705
fc7ec1d9 706=head1 AUTHOR
707
708Sebastian Riedel, C<sri@cpan.org>
709
710=head1 COPYRIGHT
711
712This program is free software, you can redistribute it and/or modify it under
713the same terms as Perl itself.
714
715=cut
716
7171;