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::Request;
14 use Catalyst::Request::Upload;
15 use Catalyst::Response;
17 require Module::Pluggable::Fast;
20 $Data::Dumper::Terse = 1;
22 __PACKAGE__->mk_classdata('components');
23 __PACKAGE__->mk_accessors(qw/counter request response state/);
29 # For backwards compatibility
30 *finalize_output = \&finalize_body;
35 our $RECURSION = 1000;
39 Catalyst::Engine - The Catalyst Engine
51 =item $c->benchmark($coderef)
53 Takes a coderef with arguments and returns elapsed time as float.
55 my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
56 $c->log->info( sprintf "Processing took %f seconds", $elapsed );
63 my $time = [gettimeofday];
64 my @return = &$code(@_);
65 my $elapsed = tv_interval $time;
66 return wantarray ? ( $elapsed, @return ) : $elapsed;
71 =item $c->component($name)
73 Get a component object by name.
75 $c->comp('MyApp::Model::MyModel')->do_stuff;
77 Regex search for a component.
79 $c->comp('mymodel')->do_stuff;
90 if ( my $component = $c->components->{$name} ) {
95 for my $component ( keys %{ $c->components } ) {
96 return $c->components->{$component} if $component =~ /$name/i;
101 return sort keys %{ $c->components };
106 Returns a hashref containing coderefs and execution counts.
107 (Needed for deep recursion detection)
111 =item $c->error($error, ...)
113 =item $c->error($arrayref)
115 Returns an arrayref containing error messages.
117 my @error = @{ $c->error };
121 $c->error('Something bad happened');
127 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
128 push @{ $c->{error} }, @$error;
132 =item $c->execute($class, $coderef)
134 Execute a coderef in given class and catch exceptions.
135 Errors are available via $c->error.
140 my ( $c, $class, $code ) = @_;
141 $class = $c->components->{$class} || $class;
143 my $callsub = ( caller(1) )[3];
147 $action = $c->actions->{reverse}->{"$code"};
148 $action = "/$action" unless $action =~ /\-\>/;
149 $c->counter->{"$code"}++;
151 if ( $c->counter->{"$code"} > $RECURSION ) {
152 my $error = qq/Deep recursion detected in "$action"/;
153 $c->log->error($error);
159 $action = "-> $action" if $callsub =~ /forward$/;
165 my ( $elapsed, @state ) =
166 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
167 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
170 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
173 if ( my $error = $@ ) {
175 unless ( ref $error ) {
177 $error = qq/Caught exception "$error"/;
180 $c->log->error($error);
196 $c->finalize_cookies;
198 if ( my $location = $c->response->redirect ) {
199 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
200 $c->response->header( Location => $location );
201 $c->response->status(302) if $c->response->status !~ /^3\d\d$/;
204 if ( $#{ $c->error } >= 0 ) {
208 if ( !$c->response->body && $c->response->status !~ /^(1|3)\d\d$/ ) {
212 if ( $c->response->body && !$c->response->content_length ) {
213 use bytes; # play safe with a utf8 aware perl
214 $c->response->content_length( length $c->response->body );
217 my $status = $c->finalize_headers;
222 =item $c->finalize_output
224 <obsolete>, see finalize_body
226 =item $c->finalize_body
232 sub finalize_body { }
234 =item $c->finalize_cookies
240 sub finalize_cookies {
243 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
244 my $cookie = CGI::Cookie->new(
246 -value => $cookie->{value},
247 -expires => $cookie->{expires},
248 -domain => $cookie->{domain},
249 -path => $cookie->{path},
250 -secure => $cookie->{secure} || 0
253 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
257 =item $c->finalize_error
266 $c->res->headers->content_type('text/html');
267 my $name = $c->config->{name} || 'Catalyst Application';
269 my ( $title, $error, $infos );
271 $error = join '<br/>', @{ $c->error };
272 $error ||= 'No output';
273 $title = $name = "$name on Catalyst $Catalyst::VERSION";
274 my $req = encode_entities Dumper $c->req;
275 my $res = encode_entities Dumper $c->res;
276 my $stash = encode_entities Dumper $c->stash;
279 <b><u>Request</u></b><br/>
281 <b><u>Response</u></b><br/>
283 <b><u>Stash</u></b><br/>
292 (en) Please come back later
293 (de) Bitte versuchen sie es spaeter nocheinmal
294 (nl) Gelieve te komen later terug
295 (no) Vennligst prov igjen senere
296 (fr) Veuillez revenir plus tard
297 (es) Vuelto por favor mas adelante
298 (pt) Voltado por favor mais tarde
299 (it) Ritornato prego piĆ¹ successivamente
304 $c->res->body( <<"" );
307 <title>$title</title>
308 <style type="text/css">
310 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
311 Tahoma, Arial, helvetica, sans-serif;
313 background-color: #eee;
318 background-color: #ccc;
319 border: 1px solid #aaa;
322 -moz-border-radius: 10px;
325 background-color: #977;
326 border: 1px solid #755;
330 -moz-border-radius: 10px;
333 background-color: #797;
334 border: 1px solid #575;
338 -moz-border-radius: 10px;
341 background-color: #779;
342 border: 1px solid #557;
345 -moz-border-radius: 10px;
351 <div class="error">$error</div>
352 <div class="infos">$infos</div>
353 <div class="name">$name</div>
360 =item $c->finalize_headers
366 sub finalize_headers { }
368 =item $c->handler( $class, @arguments )
375 my ( $class, @arguments ) = @_;
377 # Always expect worst case!
383 my $c = $class->prepare(@arguments);
384 $c->{stats} = \@stats;
389 if ( $class->debug ) {
391 ( $elapsed, $status ) = $class->benchmark($handler);
392 $elapsed = sprintf '%f', $elapsed;
393 my $av = sprintf '%.3f',
394 ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
395 my $t = Text::ASCIITable->new;
396 $t->setCols( 'Action', 'Time' );
397 $t->setColWidth( 'Action', 64, 1 );
398 $t->setColWidth( 'Time', 9, 1 );
400 for my $stat (@stats) { $t->addRow( $stat->[0], $stat->[1] ) }
401 $class->log->info( "Request took $elapsed" . "s ($av/s)",
404 else { $status = &$handler }
408 if ( my $error = $@ ) {
410 $class->log->error(qq/Caught exception in engine "$error"/);
417 =item $c->prepare(@arguments)
419 Turns the engine-specific request( Apache, CGI ... )
420 into a Catalyst context .
425 my ( $class, @arguments ) = @_;
429 request => Catalyst::Request->new(
433 headers => HTTP::Headers->new,
440 response => Catalyst::Response->new(
444 headers => HTTP::Headers->new,
453 my $secs = time - $START || 1;
454 my $av = sprintf '%.3f', $COUNT / $secs;
455 $c->log->debug('**********************************');
456 $c->log->debug("* Request $COUNT ($av/s) [$$]");
457 $c->log->debug('**********************************');
458 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
461 $c->prepare_request(@arguments);
462 $c->prepare_connection;
468 my $method = $c->req->method || '';
469 my $path = $c->req->path || '';
470 my $hostname = $c->req->hostname || '';
471 my $address = $c->req->address || '';
473 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
476 if ( $c->request->method eq 'POST' and $c->request->content_length ) {
478 if ( $c->req->content_type eq 'application/x-www-form-urlencoded' ) {
479 $c->prepare_parameters;
481 elsif ( $c->req->content_type eq 'multipart/form-data' ) {
482 $c->prepare_parameters;
490 if ( $c->request->method eq 'GET' ) {
491 $c->prepare_parameters;
494 if ( $c->debug && keys %{ $c->req->params } ) {
495 my $t = Text::ASCIITable->new;
496 $t->setCols( 'Key', 'Value' );
497 $t->setColWidth( 'Key', 37, 1 );
498 $t->setColWidth( 'Value', 36, 1 );
499 for my $key ( sort keys %{ $c->req->params } ) {
500 my $param = $c->req->params->{$key};
501 my $value = defined($param) ? $param : '';
502 $t->addRow( $key, $value );
504 $c->log->debug( 'Parameters are', $t->draw );
510 =item $c->prepare_action
518 my $path = $c->req->path;
519 my @path = split /\//, $c->req->path;
520 $c->req->args( \my @args );
523 $path = join '/', @path;
524 if ( my $result = ${ $c->get_action($path) }[0] ) {
528 my $match = $result->[1];
529 my @snippets = @{ $result->[2] };
531 qq/Requested action is "$path" and matched "$match"/)
534 'Snippets are "' . join( ' ', @snippets ) . '"' )
535 if ( $c->debug && @snippets );
536 $c->req->action($match);
537 $c->req->snippets( \@snippets );
541 $c->req->action($path);
542 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
545 $c->req->match($path);
548 unshift @args, pop @path;
551 unless ( $c->req->action ) {
552 $c->req->action('default');
556 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
557 if ( $c->debug && @args );
560 =item $c->prepare_body
562 Prepare message body.
568 =item $c->prepare_connection
574 sub prepare_connection { }
576 =item $c->prepare_cookies
582 sub prepare_cookies {
585 if ( my $header = $c->request->header('Cookie') ) {
586 $c->req->cookies( { CGI::Cookie->parse($header) } );
590 =item $c->prepare_headers
596 sub prepare_headers { }
598 =item $c->prepare_parameters
604 sub prepare_parameters { }
606 =item $c->prepare_path
608 Prepare path and base.
614 =item $c->prepare_request
616 Prepare the engine request.
620 sub prepare_request { }
622 =item $c->prepare_uploads
628 sub prepare_uploads { }
642 Returns a C<Catalyst::Request> object.
650 Returns a C<Catalyst::Response> object.
664 $self->setup_components;
665 if ( $self->debug ) {
666 my $name = $self->config->{name} || 'Application';
667 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
671 =item $class->setup_components
677 sub setup_components {
681 my $class = ref $self || $self;
684 import Module::Pluggable::Fast
685 name => '_components',
687 '$class\::Controller', '$class\::C',
688 '$class\::Model', '$class\::M',
689 '$class\::View', '$class\::V'
692 if ( my $error = $@ ) {
694 die qq/Couldn't load components "$error"/;
697 $self->components( {} );
699 for my $comp ( $self->_components($self) ) {
700 $self->components->{ ref $comp } = $comp;
704 my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
705 $t->setCols('Class');
706 $t->setColWidth( 'Class', 75, 1 );
707 $t->addRow($_) for sort keys %{ $self->components };
708 $self->log->debug( 'Loaded components', $t->draw )
709 if ( @{ $t->{tbl_rows} } && $self->debug );
711 $self->setup_actions( [ $self, @comps ] );
716 Contains the return value of the last executed action.
720 Returns a hashref containing all your data.
722 $c->stash->{foo} ||= 'yada';
723 print $c->stash->{foo};
730 my $stash = @_ > 1 ? {@_} : $_[0];
731 while ( my ( $key, $val ) = each %$stash ) {
732 $self->{stash}->{$key} = $val;
735 return $self->{stash};
742 Sebastian Riedel, C<sri@cpan.org>
746 This program is free software, you can redistribute it and/or modify it under
747 the same terms as Perl itself.