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 $address = $c->req->address || '';
472 $c->log->debug(qq/"$method" request for "$path" from $address/)
475 if ( $c->request->method eq 'POST' and $c->request->content_length ) {
477 if ( $c->req->content_type eq 'application/x-www-form-urlencoded' ) {
478 $c->prepare_parameters;
480 elsif ( $c->req->content_type eq 'multipart/form-data' ) {
481 $c->prepare_parameters;
489 if ( $c->request->method eq 'GET' ) {
490 $c->prepare_parameters;
493 if ( $c->debug && keys %{ $c->req->params } ) {
494 my $t = Text::ASCIITable->new;
495 $t->setCols( 'Key', 'Value' );
496 $t->setColWidth( 'Key', 37, 1 );
497 $t->setColWidth( 'Value', 36, 1 );
498 for my $key ( sort keys %{ $c->req->params } ) {
499 my $param = $c->req->params->{$key};
500 my $value = defined($param) ? $param : '';
501 $t->addRow( $key, $value );
503 $c->log->debug( 'Parameters are', $t->draw );
509 =item $c->prepare_action
517 my $path = $c->req->path;
518 my @path = split /\//, $c->req->path;
519 $c->req->args( \my @args );
522 $path = join '/', @path;
523 if ( my $result = ${ $c->get_action($path) }[0] ) {
527 my $match = $result->[1];
528 my @snippets = @{ $result->[2] };
530 qq/Requested action is "$path" and matched "$match"/)
533 'Snippets are "' . join( ' ', @snippets ) . '"' )
534 if ( $c->debug && @snippets );
535 $c->req->action($match);
536 $c->req->snippets( \@snippets );
540 $c->req->action($path);
541 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
544 $c->req->match($path);
547 unshift @args, pop @path;
550 unless ( $c->req->action ) {
551 $c->req->action('default');
555 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
556 if ( $c->debug && @args );
559 =item $c->prepare_body
561 Prepare message body.
567 =item $c->prepare_connection
573 sub prepare_connection { }
575 =item $c->prepare_cookies
581 sub prepare_cookies {
584 if ( my $header = $c->request->header('Cookie') ) {
585 $c->req->cookies( { CGI::Cookie->parse($header) } );
589 =item $c->prepare_headers
595 sub prepare_headers { }
597 =item $c->prepare_parameters
603 sub prepare_parameters { }
605 =item $c->prepare_path
607 Prepare path and base.
613 =item $c->prepare_request
615 Prepare the engine request.
619 sub prepare_request { }
621 =item $c->prepare_uploads
627 sub prepare_uploads { }
641 Returns a C<Catalyst::Request> object.
649 Returns a C<Catalyst::Response> object.
663 $self->setup_components;
664 if ( $self->debug ) {
665 my $name = $self->config->{name} || 'Application';
666 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
670 =item $class->setup_components
676 sub setup_components {
680 my $class = ref $self || $self;
683 import Module::Pluggable::Fast
684 name => '_components',
686 '$class\::Controller', '$class\::C',
687 '$class\::Model', '$class\::M',
688 '$class\::View', '$class\::V'
691 if ( my $error = $@ ) {
693 die qq/Couldn't load components "$error"/;
696 $self->components( {} );
698 for my $comp ( $self->_components($self) ) {
699 $self->components->{ ref $comp } = $comp;
703 my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
704 $t->setCols('Class');
705 $t->setColWidth( 'Class', 75, 1 );
706 $t->addRow($_) for sort keys %{ $self->components };
707 $self->log->debug( 'Loaded components', $t->draw )
708 if ( @{ $t->{tbl_rows} } && $self->debug );
710 $self->setup_actions( [ $self, @comps ] );
715 Contains the return value of the last executed action.
719 Returns a hashref containing all your data.
721 $c->stash->{foo} ||= 'yada';
722 print $c->stash->{foo};
729 my $stash = @_ > 1 ? {@_} : $_[0];
730 while ( my ( $key, $val ) = each %$stash ) {
731 $self->{stash}->{$key} = $val;
734 return $self->{stash};
741 Sebastian Riedel, C<sri@cpan.org>
745 This program is free software, you can redistribute it and/or modify it under
746 the same terms as Perl itself.