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;
18 require Module::Pluggable::Fast;
21 $Data::Dumper::Terse = 1;
23 __PACKAGE__->mk_classdata('components');
24 __PACKAGE__->mk_accessors(qw/counter request response state/);
30 # For backwards compatibility
31 *finalize_output = \&finalize_body;
36 our $RECURSION = 1000;
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 =item $c->error($error, ...)
114 =item $c->error($arrayref)
116 Returns an arrayref containing error messages.
118 my @error = @{ $c->error };
122 $c->error('Something bad happened');
128 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
129 push @{ $c->{error} }, @$error;
133 =item $c->execute($class, $coderef)
135 Execute a coderef in given class and catch exceptions.
136 Errors are available via $c->error.
141 my ( $c, $class, $code ) = @_;
142 $class = $c->components->{$class} || $class;
144 my $callsub = ( caller(1) )[3];
148 $action = $c->actions->{reverse}->{"$code"};
149 $action = "/$action" unless $action =~ /\-\>/;
150 $c->counter->{"$code"}++;
152 if ( $c->counter->{"$code"} > $RECURSION ) {
153 my $error = qq/Deep recursion detected in "$action"/;
154 $c->log->error($error);
160 $action = "-> $action" if $callsub =~ /forward$/;
166 my ( $elapsed, @state ) = $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 } ) || 0 ) }
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.
664 # Initialize our data structure
665 $self->components( {} );
667 $self->setup_components;
669 if ( $self->debug ) {
670 my $t = Text::ASCIITable->new;
671 $t->setOptions( 'hide_HeadRow', 1 );
672 $t->setOptions( 'hide_HeadLine', 1 );
673 $t->setCols('Class');
674 $t->setColWidth( 'Class', 75, 1 );
675 $t->addRow($_) for sort keys %{ $self->components };
676 $self->log->debug( 'Loaded components', $t->draw )
677 if ( @{ $t->{tbl_rows} } );
680 # Add our self to components, since we are also a component
681 $self->components->{ $self } = $self;
683 $self->setup_actions;
685 if ( $self->debug ) {
686 my $name = $self->config->{name} || 'Application';
687 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
691 =item $class->setup_components
697 sub setup_components {
701 my ( $component, $context ) = @_;
703 unless ( $component->isa('Catalyst::Base') ) {
707 my $suffix = Catalyst::Utils::class2classsuffix($component);
708 my $config = $self->config->{$suffix} || {};
713 $instance = $component->new( $context, $config );
716 if ( my $error = $@ ) {
718 die qq/Couldn't instantiate component "$component", "$error"/;
725 Module::Pluggable::Fast->import(
726 name => '_components',
728 "$self\::Controller", "$self\::C",
729 "$self\::Model", "$self\::M",
730 "$self\::View", "$self\::V"
732 callback => $callback
736 if ( my $error = $@ ) {
738 die qq/Couldn't load components "$error"/;
741 for my $component ( $self->_components($self) ) {
742 $self->components->{ ref $component || $component } = $component;
748 Contains the return value of the last executed action.
752 Returns a hashref containing all your data.
754 $c->stash->{foo} ||= 'yada';
755 print $c->stash->{foo};
762 my $stash = @_ > 1 ? {@_} : $_[0];
763 while ( my ( $key, $val ) = each %$stash ) {
764 $self->{stash}->{$key} = $val;
767 return $self->{stash};
774 Sebastian Riedel, C<sri@cpan.org>
778 This program is free software, you can redistribute it and/or modify it under
779 the same terms as Perl itself.