1 package Catalyst::Engine;
4 use base qw/Class::Data::Inheritable Class::Accessor::Fast/;
6 use UNIVERSAL::require;
11 use Time::HiRes qw/gettimeofday tv_interval/;
13 use Catalyst::Exception;
14 use Catalyst::Request;
15 use Catalyst::Request::Upload;
16 use Catalyst::Response;
20 $Data::Dumper::Terse = 1;
22 __PACKAGE__->mk_classdata('components');
23 __PACKAGE__->mk_accessors(qw/counter depth request response state/);
29 # For backwards compatibility
30 *finalize_output = \&finalize_body;
35 our $RECURSION = 1000;
36 our $DETACH = "catalyst_detach\n";
40 Catalyst::Engine - The Catalyst Engine
52 =item $c->benchmark($coderef)
54 Takes a coderef with arguments and returns elapsed time as float.
56 my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
57 $c->log->info( sprintf "Processing took %f seconds", $elapsed );
64 my $time = [gettimeofday];
65 my @return = &$code(@_);
66 my $elapsed = tv_interval $time;
67 return wantarray ? ( $elapsed, @return ) : $elapsed;
72 =item $c->component($name)
74 Get a component object by name.
76 $c->comp('MyApp::Model::MyModel')->do_stuff;
78 Regex search for a component.
80 $c->comp('mymodel')->do_stuff;
91 if ( my $component = $c->components->{$name} ) {
96 for my $component ( keys %{ $c->components } ) {
97 return $c->components->{$component} if $component =~ /$name/i;
102 return sort keys %{ $c->components };
107 Returns a hashref containing coderefs and execution counts.
108 (Needed for deep recursion detection)
112 Returns the actual forward depth.
116 =item $c->error($error, ...)
118 =item $c->error($arrayref)
120 Returns an arrayref containing error messages.
122 my @error = @{ $c->error };
126 $c->error('Something bad happened');
132 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
133 push @{ $c->{error} }, @$error;
137 =item $c->execute($class, $coderef)
139 Execute a coderef in given class and catch exceptions.
140 Errors are available via $c->error.
145 my ( $c, $class, $code ) = @_;
146 $class = $c->components->{$class} || $class;
148 my $callsub = ( caller(1) )[3];
152 $action = $c->actions->{reverse}->{"$code"};
153 $action = "/$action" unless $action =~ /\-\>/;
154 $c->counter->{"$code"}++;
156 if ( $c->counter->{"$code"} > $RECURSION ) {
157 my $error = qq/Deep recursion detected in "$action"/;
158 $c->log->error($error);
164 $action = "-> $action" if $callsub =~ /forward$/;
171 my ( $elapsed, @state ) =
172 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
173 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
176 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) }
180 if ( my $error = $@ ) {
182 if ( $error eq $DETACH ) { die $DETACH if $c->{depth} > 1 }
184 unless ( ref $error ) {
186 $error = qq/Caught exception "$error"/;
189 $c->log->error($error);
206 $c->finalize_cookies;
208 if ( my $location = $c->response->redirect ) {
209 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
210 $c->response->header( Location => $location );
211 $c->response->status(302) if $c->response->status !~ /^3\d\d$/;
214 if ( $#{ $c->error } >= 0 ) {
218 if ( !$c->response->body && $c->response->status == 200 ) {
222 if ( $c->response->body && !$c->response->content_length ) {
223 $c->response->content_length( bytes::length( $c->response->body ) );
226 if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
227 $c->response->headers->remove_header("Content-Length");
228 $c->response->body('');
231 if ( $c->request->method eq 'HEAD' ) {
232 $c->response->body('');
235 my $status = $c->finalize_headers;
240 =item $c->finalize_output
242 <obsolete>, see finalize_body
244 =item $c->finalize_body
250 sub finalize_body { }
252 =item $c->finalize_cookies
258 sub finalize_cookies {
261 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
262 my $cookie = CGI::Cookie->new(
264 -value => $cookie->{value},
265 -expires => $cookie->{expires},
266 -domain => $cookie->{domain},
267 -path => $cookie->{path},
268 -secure => $cookie->{secure} || 0
271 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
275 =item $c->finalize_error
284 $c->res->headers->content_type('text/html');
285 my $name = $c->config->{name} || 'Catalyst Application';
287 my ( $title, $error, $infos );
289 $error = join '<br/>', @{ $c->error };
290 $error ||= 'No output';
291 $title = $name = "$name on Catalyst $Catalyst::VERSION";
292 my $req = encode_entities Dumper $c->req;
293 my $res = encode_entities Dumper $c->res;
294 my $stash = encode_entities Dumper $c->stash;
297 <b><u>Request</u></b><br/>
299 <b><u>Response</u></b><br/>
301 <b><u>Stash</u></b><br/>
310 (en) Please come back later
311 (de) Bitte versuchen sie es spaeter nocheinmal
312 (nl) Gelieve te komen later terug
313 (no) Vennligst prov igjen senere
314 (fr) Veuillez revenir plus tard
315 (es) Vuelto por favor mas adelante
316 (pt) Voltado por favor mais tarde
317 (it) Ritornato prego piĆ¹ successivamente
322 $c->res->body( <<"" );
325 <title>$title</title>
326 <style type="text/css">
328 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
329 Tahoma, Arial, helvetica, sans-serif;
331 background-color: #eee;
336 background-color: #ccc;
337 border: 1px solid #aaa;
340 -moz-border-radius: 10px;
343 background-color: #977;
344 border: 1px solid #755;
348 -moz-border-radius: 10px;
351 background-color: #797;
352 border: 1px solid #575;
356 -moz-border-radius: 10px;
359 background-color: #779;
360 border: 1px solid #557;
363 -moz-border-radius: 10px;
369 <div class="error">$error</div>
370 <div class="infos">$infos</div>
371 <div class="name">$name</div>
378 =item $c->finalize_headers
384 sub finalize_headers { }
386 =item $c->handler( $class, @arguments )
393 my ( $class, @arguments ) = @_;
395 # Always expect worst case!
401 my $c = $class->prepare(@arguments);
402 $c->{stats} = \@stats;
407 if ( $class->debug ) {
409 ( $elapsed, $status ) = $class->benchmark($handler);
410 $elapsed = sprintf '%f', $elapsed;
411 my $av = sprintf '%.3f',
412 ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
413 my $t = Text::ASCIITable->new;
414 $t->setCols( 'Action', 'Time' );
415 $t->setColWidth( 'Action', 64, 1 );
416 $t->setColWidth( 'Time', 9, 1 );
418 for my $stat (@stats) { $t->addRow( $stat->[0], $stat->[1] ) }
419 $class->log->info( "Request took ${elapsed}s ($av/s)\n" . $t->draw );
421 else { $status = &$handler }
425 if ( my $error = $@ ) {
427 $class->log->error(qq/Caught exception in engine "$error"/);
434 =item $c->prepare(@arguments)
436 Turns the engine-specific request( Apache, CGI ... )
437 into a Catalyst context .
442 my ( $class, @arguments ) = @_;
447 request => Catalyst::Request->new(
451 headers => HTTP::Headers->new,
458 response => Catalyst::Response->new(
462 headers => HTTP::Headers->new( 'Content-Length' => 0 ),
471 my $secs = time - $START || 1;
472 my $av = sprintf '%.3f', $COUNT / $secs;
473 $c->log->debug('**********************************');
474 $c->log->debug("* Request $COUNT ($av/s) [$$]");
475 $c->log->debug('**********************************');
476 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
479 $c->prepare_request(@arguments);
480 $c->prepare_connection;
486 my $method = $c->req->method || '';
487 my $path = $c->req->path || '';
488 my $address = $c->req->address || '';
490 $c->log->debug(qq/"$method" request for "$path" from $address/)
493 if ( $c->request->method eq 'POST' and $c->request->content_length ) {
495 if ( $c->req->content_type eq 'application/x-www-form-urlencoded' ) {
496 $c->prepare_parameters;
498 elsif ( $c->req->content_type eq 'multipart/form-data' ) {
499 $c->prepare_parameters;
507 if ( $c->request->method eq 'GET' ) {
508 $c->prepare_parameters;
511 if ( $c->debug && keys %{ $c->req->params } ) {
512 my $t = Text::ASCIITable->new;
513 $t->setCols( 'Key', 'Value' );
514 $t->setColWidth( 'Key', 37, 1 );
515 $t->setColWidth( 'Value', 36, 1 );
516 for my $key ( sort keys %{ $c->req->params } ) {
517 my $param = $c->req->params->{$key};
518 my $value = defined($param) ? $param : '';
519 $t->addRow( $key, $value );
521 $c->log->debug( "Parameters are:\n" . $t->draw );
527 =item $c->prepare_action
535 my $path = $c->req->path;
536 my @path = split /\//, $c->req->path;
537 $c->req->args( \my @args );
540 $path = join '/', @path;
541 if ( my $result = ${ $c->get_action($path) }[0] ) {
545 my $match = $result->[1];
546 my @snippets = @{ $result->[2] };
548 qq/Requested action is "$path" and matched "$match"/)
551 'Snippets are "' . join( ' ', @snippets ) . '"' )
552 if ( $c->debug && @snippets );
553 $c->req->action($match);
554 $c->req->snippets( \@snippets );
558 $c->req->action($path);
559 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
562 $c->req->match($path);
565 unshift @args, pop @path;
568 unless ( $c->req->action ) {
569 $c->req->action('default');
573 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
574 if ( $c->debug && @args );
577 =item $c->prepare_body
579 Prepare message body.
585 =item $c->prepare_connection
591 sub prepare_connection { }
593 =item $c->prepare_cookies
599 sub prepare_cookies {
602 if ( my $header = $c->request->header('Cookie') ) {
603 $c->req->cookies( { CGI::Cookie->parse($header) } );
607 =item $c->prepare_headers
613 sub prepare_headers { }
615 =item $c->prepare_parameters
621 sub prepare_parameters { }
623 =item $c->prepare_path
625 Prepare path and base.
631 =item $c->prepare_request
633 Prepare the engine request.
637 sub prepare_request { }
639 =item $c->prepare_uploads
645 sub prepare_uploads { }
659 Returns a C<Catalyst::Request> object.
667 Returns a C<Catalyst::Response> object.
673 Contains the return value of the last executed action.
677 Returns a hashref containing all your data.
679 $c->stash->{foo} ||= 'yada';
680 print $c->stash->{foo};
687 my $stash = @_ > 1 ? {@_} : $_[0];
688 while ( my ( $key, $val ) = each %$stash ) {
689 $self->{stash}->{$key} = $val;
692 return $self->{stash};
699 Sebastian Riedel, C<sri@cpan.org>
703 This program is free software, you can redistribute it and/or modify it under
704 the same terms as Perl itself.