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/request response state/);
29 # For backwards compatibility
30 *finalize_output = \&finalize_body;
38 Catalyst::Engine - The Catalyst Engine
50 =item $c->benchmark($coderef)
52 Takes a coderef with arguments and returns elapsed time as float.
54 my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
55 $c->log->info( sprintf "Processing took %f seconds", $elapsed );
62 my $time = [gettimeofday];
63 my @return = &$code(@_);
64 my $elapsed = tv_interval $time;
65 return wantarray ? ( $elapsed, @return ) : $elapsed;
70 =item $c->component($name)
72 Get a component object by name.
74 $c->comp('MyApp::Model::MyModel')->do_stuff;
76 Regex search for a component.
78 $c->comp('mymodel')->do_stuff;
89 if ( my $component = $c->components->{$name} ) {
94 for my $component ( keys %{ $c->components } ) {
95 return $c->components->{$component} if $component =~ /$name/i;
100 return sort keys %{ $c->components };
105 =item $c->error($error, ...)
107 =item $c->error($arrayref)
109 Returns an arrayref containing error messages.
111 my @error = @{ $c->error };
115 $c->error('Something bad happened');
121 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
122 push @{ $c->{error} }, @$error;
126 =item $c->execute($class, $coderef)
128 Execute a coderef in given class and catch exceptions.
129 Errors are available via $c->error.
134 my ( $c, $class, $code ) = @_;
135 $class = $c->components->{$class} || $class;
137 my $callsub = ( caller(1) )[3];
142 my $action = $c->actions->{reverse}->{"$code"};
143 $action = "/$action" unless $action =~ /\-\>/;
144 $action = "-> $action" if $callsub =~ /forward$/;
145 my ( $elapsed, @state ) =
146 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
147 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
150 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
153 if ( my $error = $@ ) {
155 unless ( ref $error ) {
157 $error = qq/Caught exception "$error"/;
160 $c->log->error($error);
176 $c->finalize_cookies;
178 if ( my $location = $c->response->redirect ) {
179 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
180 $c->response->header( Location => $location );
181 $c->response->status(302) if $c->response->status !~ /^3\d\d$/;
184 if ( $#{ $c->error } >= 0 ) {
188 if ( !$c->response->body && $c->response->status !~ /^(1|3)\d\d$/ ) {
192 if ( $c->response->body && !$c->response->content_length ) {
193 use bytes; # play safe with a utf8 aware perl
194 $c->response->content_length( length $c->response->body );
197 my $status = $c->finalize_headers;
202 =item $c->finalize_body
208 sub finalize_body { }
210 =item $c->finalize_cookies
216 sub finalize_cookies {
219 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
220 my $cookie = CGI::Cookie->new(
222 -value => $cookie->{value},
223 -expires => $cookie->{expires},
224 -domain => $cookie->{domain},
225 -path => $cookie->{path},
226 -secure => $cookie->{secure} || 0
229 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
233 =item $c->finalize_error
242 $c->res->headers->content_type('text/html');
243 my $name = $c->config->{name} || 'Catalyst Application';
245 my ( $title, $error, $infos );
247 $error = join '<br/>', @{ $c->error };
248 $error ||= 'No output';
249 $title = $name = "$name on Catalyst $Catalyst::VERSION";
250 my $req = encode_entities Dumper $c->req;
251 my $res = encode_entities Dumper $c->res;
252 my $stash = encode_entities Dumper $c->stash;
255 <b><u>Request</u></b><br/>
257 <b><u>Response</u></b><br/>
259 <b><u>Stash</u></b><br/>
268 (en) Please come back later
269 (de) Bitte versuchen sie es spaeter nocheinmal
270 (nl) Gelieve te komen later terug
271 (no) Vennligst prov igjen senere
272 (fr) Veuillez revenir plus tard
273 (es) Vuelto por favor mas adelante
274 (pt) Voltado por favor mais tarde
275 (it) Ritornato prego piĆ¹ successivamente
280 $c->res->body( <<"" );
283 <title>$title</title>
284 <style type="text/css">
286 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
287 Tahoma, Arial, helvetica, sans-serif;
289 background-color: #eee;
294 background-color: #ccc;
295 border: 1px solid #aaa;
298 -moz-border-radius: 10px;
301 background-color: #977;
302 border: 1px solid #755;
306 -moz-border-radius: 10px;
309 background-color: #797;
310 border: 1px solid #575;
314 -moz-border-radius: 10px;
317 background-color: #779;
318 border: 1px solid #557;
321 -moz-border-radius: 10px;
327 <div class="error">$error</div>
328 <div class="infos">$infos</div>
329 <div class="name">$name</div>
336 =item $c->finalize_headers
342 sub finalize_headers { }
344 =item $c->handler( $class, $engine )
351 my ( $class, $engine ) = @_;
353 # Always expect worst case!
359 my $c = $class->prepare($engine);
360 $c->{stats} = \@stats;
365 if ( $class->debug ) {
367 ( $elapsed, $status ) = $class->benchmark($handler);
368 $elapsed = sprintf '%f', $elapsed;
369 my $av = sprintf '%.3f', ( $elapsed == 0 ? '??' : (1 / $elapsed) );
370 my $t = Text::ASCIITable->new;
371 $t->setCols( 'Action', 'Time' );
372 $t->setColWidth( 'Action', 64, 1 );
373 $t->setColWidth( 'Time', 9, 1 );
375 for my $stat (@stats) { $t->addRow( $stat->[0], $stat->[1] ) }
376 $class->log->info( "Request took $elapsed" . "s ($av/s)",
379 else { $status = &$handler }
383 if ( my $error = $@ ) {
385 $class->log->error(qq/Caught exception in engine "$error"/);
392 =item $c->prepare($engine)
394 Turns the engine-specific request( Apache, CGI ... )
395 into a Catalyst context .
400 my ( $class, $engine ) = @_;
403 request => Catalyst::Request->new(
407 headers => HTTP::Headers->new,
414 response => Catalyst::Response->new(
418 headers => HTTP::Headers->new,
427 my $secs = time - $START || 1;
428 my $av = sprintf '%.3f', $COUNT / $secs;
429 $c->log->debug('**********************************');
430 $c->log->debug("* Request $COUNT ($av/s) [$$]");
431 $c->log->debug('**********************************');
432 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
435 $c->prepare_request($engine);
436 $c->prepare_connection;
442 my $method = $c->req->method || '';
443 my $path = $c->req->path || '';
444 my $hostname = $c->req->hostname || '';
445 my $address = $c->req->address || '';
447 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
450 if ( $c->request->method eq 'POST' and $c->request->content_length ) {
452 if ( $c->req->content_type eq 'application/x-www-form-urlencoded' ) {
453 $c->prepare_parameters;
455 elsif ( $c->req->content_type eq 'multipart/form-data' ) {
456 $c->prepare_parameters;
464 if ( $c->request->method eq 'GET' ) {
465 $c->prepare_parameters;
468 if ( $c->debug && keys %{ $c->req->params } ) {
469 my $t = Text::ASCIITable->new;
470 $t->setCols( 'Key', 'Value' );
471 $t->setColWidth( 'Key', 37, 1 );
472 $t->setColWidth( 'Value', 36, 1 );
473 for my $key ( sort keys %{ $c->req->params } ) {
474 my $param = $c->req->params->{$key};
475 my $value = defined($param) ? $param : '';
476 $t->addRow( $key, $value );
478 $c->log->debug( 'Parameters are', $t->draw );
484 =item $c->prepare_action
492 my $path = $c->req->path;
493 my @path = split /\//, $c->req->path;
494 $c->req->args( \my @args );
497 $path = join '/', @path;
498 if ( my $result = ${ $c->get_action($path) }[0] ) {
502 my $match = $result->[1];
503 my @snippets = @{ $result->[2] };
505 qq/Requested action is "$path" and matched "$match"/)
508 'Snippets are "' . join( ' ', @snippets ) . '"' )
509 if ( $c->debug && @snippets );
510 $c->req->action($match);
511 $c->req->snippets( \@snippets );
515 $c->req->action($path);
516 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
519 $c->req->match($path);
522 unshift @args, pop @path;
525 unless ( $c->req->action ) {
526 $c->req->action('default');
530 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
531 if ( $c->debug && @args );
534 =item $c->prepare_body
536 Prepare message body.
542 =item $c->prepare_connection
548 sub prepare_connection { }
550 =item $c->prepare_cookies
556 sub prepare_cookies {
559 if ( my $header = $c->request->header('Cookie') ) {
560 $c->req->cookies( { CGI::Cookie->parse($header) } );
564 =item $c->prepare_headers
570 sub prepare_headers { }
572 =item $c->prepare_parameters
578 sub prepare_parameters { }
580 =item $c->prepare_path
582 Prepare path and base.
588 =item $c->prepare_request
590 Prepare the engine request.
594 sub prepare_request { }
596 =item $c->prepare_uploads
602 sub prepare_uploads { }
604 =item $c->retrieve_components
610 sub retrieve_components {
613 my $class = ref $self || $self;
616 import Module::Pluggable::Fast
617 name => '_components',
619 '$class\::Controller', '$class\::C',
620 '$class\::Model', '$class\::M',
621 '$class\::View', '$class\::V'
625 if ( my $error = $@ ) {
627 die qq/Couldn't load components "$error"/;
630 return $self->_components;
645 Returns a C<Catalyst::Request> object.
653 Returns a C<Catalyst::Response> object.
667 $self->setup_components;
668 if ( $self->debug ) {
669 my $name = $self->config->{name} || 'Application';
670 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
674 =item $class->setup_components
680 sub setup_components {
684 my $class = ref $self || $self;
687 import Module::Pluggable::Fast
688 name => '_components',
690 '$class\::Controller', '$class\::C',
691 '$class\::Model', '$class\::M',
692 '$class\::View', '$class\::V'
695 if ( my $error = $@ ) {
697 die qq/Couldn't load components "$error"/;
700 $self->components( {} );
702 for my $comp ( $self->_components($self) ) {
703 $self->components->{ ref $comp } = $comp;
707 my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
708 $t->setCols('Class');
709 $t->setColWidth( 'Class', 75, 1 );
710 $t->addRow($_) for sort keys %{ $self->components };
711 $self->log->debug( 'Loaded components', $t->draw )
712 if ( @{ $t->{tbl_rows} } && $self->debug );
714 $self->setup_actions( [ $self, @comps ] );
719 Contains the return value of the last executed action.
723 Returns a hashref containing all your data.
725 $c->stash->{foo} ||= 'yada';
726 print $c->stash->{foo};
733 my $stash = @_ > 1 ? {@_} : $_[0];
734 while ( my ( $key, $val ) = each %$stash ) {
735 $self->{stash}->{$key} = $val;
738 return $self->{stash};
745 Sebastian Riedel, C<sri@cpan.org>
749 This program is free software, you can redistribute it and/or modify it under
750 the same terms as Perl itself.