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 ) = $c->benchmark( $code, $class, $c, @{ $c->req->args } );
166 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
169 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ? 1 : 0 ) }
172 if ( my $error = $@ ) {
174 unless ( ref $error ) {
176 $error = qq/Caught exception "$error"/;
179 $c->log->error($error);
195 $c->finalize_cookies;
197 if ( my $location = $c->response->redirect ) {
198 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
199 $c->response->header( Location => $location );
200 $c->response->status(302) if $c->response->status !~ /^3\d\d$/;
203 if ( $#{ $c->error } >= 0 ) {
207 if ( !$c->response->body && $c->response->status !~ /^(1|3)\d\d$/ ) {
211 if ( $c->response->body && !$c->response->content_length ) {
212 use bytes; # play safe with a utf8 aware perl
213 $c->response->content_length( length $c->response->body );
216 my $status = $c->finalize_headers;
221 =item $c->finalize_output
223 <obsolete>, see finalize_body
225 =item $c->finalize_body
231 sub finalize_body { }
233 =item $c->finalize_cookies
239 sub finalize_cookies {
242 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
243 my $cookie = CGI::Cookie->new(
245 -value => $cookie->{value},
246 -expires => $cookie->{expires},
247 -domain => $cookie->{domain},
248 -path => $cookie->{path},
249 -secure => $cookie->{secure} || 0
252 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
256 =item $c->finalize_error
265 $c->res->headers->content_type('text/html');
266 my $name = $c->config->{name} || 'Catalyst Application';
268 my ( $title, $error, $infos );
270 $error = join '<br/>', @{ $c->error };
271 $error ||= 'No output';
272 $title = $name = "$name on Catalyst $Catalyst::VERSION";
273 my $req = encode_entities Dumper $c->req;
274 my $res = encode_entities Dumper $c->res;
275 my $stash = encode_entities Dumper $c->stash;
278 <b><u>Request</u></b><br/>
280 <b><u>Response</u></b><br/>
282 <b><u>Stash</u></b><br/>
291 (en) Please come back later
292 (de) Bitte versuchen sie es spaeter nocheinmal
293 (nl) Gelieve te komen later terug
294 (no) Vennligst prov igjen senere
295 (fr) Veuillez revenir plus tard
296 (es) Vuelto por favor mas adelante
297 (pt) Voltado por favor mais tarde
298 (it) Ritornato prego piĆ¹ successivamente
303 $c->res->body( <<"" );
306 <title>$title</title>
307 <style type="text/css">
309 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
310 Tahoma, Arial, helvetica, sans-serif;
312 background-color: #eee;
317 background-color: #ccc;
318 border: 1px solid #aaa;
321 -moz-border-radius: 10px;
324 background-color: #977;
325 border: 1px solid #755;
329 -moz-border-radius: 10px;
332 background-color: #797;
333 border: 1px solid #575;
337 -moz-border-radius: 10px;
340 background-color: #779;
341 border: 1px solid #557;
344 -moz-border-radius: 10px;
350 <div class="error">$error</div>
351 <div class="infos">$infos</div>
352 <div class="name">$name</div>
359 =item $c->finalize_headers
365 sub finalize_headers { }
367 =item $c->handler( $class, @arguments )
374 my ( $class, @arguments ) = @_;
376 # Always expect worst case!
382 my $c = $class->prepare(@arguments);
383 $c->{stats} = \@stats;
388 if ( $class->debug ) {
390 ( $elapsed, $status ) = $class->benchmark($handler);
391 $elapsed = sprintf '%f', $elapsed;
392 my $av = sprintf '%.3f',
393 ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
394 my $t = Text::ASCIITable->new;
395 $t->setCols( 'Action', 'Time' );
396 $t->setColWidth( 'Action', 64, 1 );
397 $t->setColWidth( 'Time', 9, 1 );
399 for my $stat (@stats) { $t->addRow( $stat->[0], $stat->[1] ) }
400 $class->log->info( "Request took $elapsed" . "s ($av/s)",
403 else { $status = &$handler }
407 if ( my $error = $@ ) {
409 $class->log->error(qq/Caught exception in engine "$error"/);
416 =item $c->prepare(@arguments)
418 Turns the engine-specific request( Apache, CGI ... )
419 into a Catalyst context .
424 my ( $class, @arguments ) = @_;
428 request => Catalyst::Request->new(
432 headers => HTTP::Headers->new,
439 response => Catalyst::Response->new(
443 headers => HTTP::Headers->new,
452 my $secs = time - $START || 1;
453 my $av = sprintf '%.3f', $COUNT / $secs;
454 $c->log->debug('**********************************');
455 $c->log->debug("* Request $COUNT ($av/s) [$$]");
456 $c->log->debug('**********************************');
457 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
460 $c->prepare_request(@arguments);
461 $c->prepare_connection;
467 my $method = $c->req->method || '';
468 my $path = $c->req->path || '';
469 my $address = $c->req->address || '';
471 $c->log->debug(qq/"$method" request for "$path" from $address/)
474 if ( $c->request->method eq 'POST' and $c->request->content_length ) {
476 if ( $c->req->content_type eq 'application/x-www-form-urlencoded' ) {
477 $c->prepare_parameters;
479 elsif ( $c->req->content_type eq 'multipart/form-data' ) {
480 $c->prepare_parameters;
488 if ( $c->request->method eq 'GET' ) {
489 $c->prepare_parameters;
492 if ( $c->debug && keys %{ $c->req->params } ) {
493 my $t = Text::ASCIITable->new;
494 $t->setCols( 'Key', 'Value' );
495 $t->setColWidth( 'Key', 37, 1 );
496 $t->setColWidth( 'Value', 36, 1 );
497 for my $key ( sort keys %{ $c->req->params } ) {
498 my $param = $c->req->params->{$key};
499 my $value = defined($param) ? $param : '';
500 $t->addRow( $key, $value );
502 $c->log->debug( 'Parameters are', $t->draw );
508 =item $c->prepare_action
516 my $path = $c->req->path;
517 my @path = split /\//, $c->req->path;
518 $c->req->args( \my @args );
521 $path = join '/', @path;
522 if ( my $result = ${ $c->get_action($path) }[0] ) {
526 my $match = $result->[1];
527 my @snippets = @{ $result->[2] };
529 qq/Requested action is "$path" and matched "$match"/)
532 'Snippets are "' . join( ' ', @snippets ) . '"' )
533 if ( $c->debug && @snippets );
534 $c->req->action($match);
535 $c->req->snippets( \@snippets );
539 $c->req->action($path);
540 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
543 $c->req->match($path);
546 unshift @args, pop @path;
549 unless ( $c->req->action ) {
550 $c->req->action('default');
554 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
555 if ( $c->debug && @args );
558 =item $c->prepare_body
560 Prepare message body.
566 =item $c->prepare_connection
572 sub prepare_connection { }
574 =item $c->prepare_cookies
580 sub prepare_cookies {
583 if ( my $header = $c->request->header('Cookie') ) {
584 $c->req->cookies( { CGI::Cookie->parse($header) } );
588 =item $c->prepare_headers
594 sub prepare_headers { }
596 =item $c->prepare_parameters
602 sub prepare_parameters { }
604 =item $c->prepare_path
606 Prepare path and base.
612 =item $c->prepare_request
614 Prepare the engine request.
618 sub prepare_request { }
620 =item $c->prepare_uploads
626 sub prepare_uploads { }
640 Returns a C<Catalyst::Request> object.
648 Returns a C<Catalyst::Response> object.
662 $self->setup_components;
663 if ( $self->debug ) {
664 my $name = $self->config->{name} || 'Application';
665 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
669 =item $class->setup_components
675 sub setup_components {
679 my $class = ref $self || $self;
682 import Module::Pluggable::Fast
683 name => '_components',
685 '$class\::Controller', '$class\::C',
686 '$class\::Model', '$class\::M',
687 '$class\::View', '$class\::V'
690 if ( my $error = $@ ) {
692 die qq/Couldn't load components "$error"/;
695 $self->components( {} );
697 for my $comp ( $self->_components($self) ) {
698 $self->components->{ ref $comp } = $comp;
702 my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
703 $t->setCols('Class');
704 $t->setColWidth( 'Class', 75, 1 );
705 $t->addRow($_) for sort keys %{ $self->components };
706 $self->log->debug( 'Loaded components', $t->draw )
707 if ( @{ $t->{tbl_rows} } && $self->debug );
709 $self->setup_actions( [ $self, @comps ] );
714 Contains the return value of the last executed action.
718 Returns a hashref containing all your data.
720 $c->stash->{foo} ||= 'yada';
721 print $c->stash->{foo};
728 my $stash = @_ > 1 ? {@_} : $_[0];
729 while ( my ( $key, $val ) = each %$stash ) {
730 $self->{stash}->{$key} = $val;
733 return $self->{stash};
740 Sebastian Riedel, C<sri@cpan.org>
744 This program is free software, you can redistribute it and/or modify it under
745 the same terms as Perl itself.