1 package Catalyst::Engine;
4 use base qw/Class::Data::Inheritable Class::Accessor::Fast/;
5 use UNIVERSAL::require;
10 use Time::HiRes qw/gettimeofday tv_interval/;
12 use Catalyst::Request;
13 use Catalyst::Request::Upload;
14 use Catalyst::Response;
16 require Module::Pluggable::Fast;
19 $Data::Dumper::Terse = 1;
21 __PACKAGE__->mk_classdata('components');
22 __PACKAGE__->mk_accessors(qw/request response state/);
34 Catalyst::Engine - The Catalyst Engine
46 =item $c->benchmark($coderef)
48 Takes a coderef with arguments and returns elapsed time as float.
50 my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
51 $c->log->info( sprintf "Processing took %f seconds", $elapsed );
58 my $time = [gettimeofday];
59 my @return = &$code(@_);
60 my $elapsed = tv_interval $time;
61 return wantarray ? ( $elapsed, @return ) : $elapsed;
66 =item $c->component($name)
68 Get a component object by name.
70 $c->comp('MyApp::Model::MyModel')->do_stuff;
72 Regex search for a component.
74 $c->comp('mymodel')->do_stuff;
79 my ( $c, $name ) = @_;
81 if ( my $component = $c->components->{$name} ) {
86 for my $component ( keys %{ $c->components } ) {
87 return $c->components->{$component} if $component =~ /$name/i;
95 =item $c->error($error, ...)
97 =item $c->error($arrayref)
99 Returns an arrayref containing error messages.
101 my @error = @{ $c->error };
105 $c->error('Something bad happened');
111 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
112 push @{ $c->{error} }, @$error;
116 =item $c->execute($class, $coderef)
118 Execute a coderef in given class and catch exceptions.
119 Errors are available via $c->error.
124 my ( $c, $class, $code ) = @_;
125 $class = $c->comp($class) || $class;
127 my $callsub = ( caller(1) )[3];
132 my $action = $c->actions->{reverse}->{"$code"};
133 $action = "/$action" unless $action =~ /\-\>/;
134 $action = "-> $action" if $callsub =~ /forward$/;
135 my ( $elapsed, @state ) =
136 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
137 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
140 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
143 if ( my $error = $@ ) {
145 unless ( ref $error ) {
147 $error = qq/Caught exception "$error"/;
150 $c->log->error($error);
166 $c->finalize_cookies;
168 if ( my $location = $c->response->redirect ) {
169 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
170 $c->response->header( Location => $location );
171 $c->response->status(302) if $c->response->status !~ /^3\d\d$/;
174 if ( $#{ $c->error } >= 0 ) {
178 if ( !$c->response->output && $c->response->status !~ /^(1|3)\d\d$/ ) {
182 if ( $c->response->output && !$c->response->content_length ) {
183 use bytes; # play safe with a utf8 aware perl
184 $c->response->content_length( length $c->response->output );
187 my $status = $c->finalize_headers;
192 =item $c->finalize_cookies
198 sub finalize_cookies {
201 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
202 my $cookie = CGI::Cookie->new(
204 -value => $cookie->{value},
205 -expires => $cookie->{expires},
206 -domain => $cookie->{domain},
207 -path => $cookie->{path},
208 -secure => $cookie->{secure} || 0
211 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
215 =item $c->finalize_error
224 $c->res->headers->content_type('text/html');
225 my $name = $c->config->{name} || 'Catalyst Application';
227 my ( $title, $error, $infos );
229 $error = join '<br/>', @{ $c->error };
230 $error ||= 'No output';
231 $title = $name = "$name on Catalyst $Catalyst::VERSION";
232 my $req = encode_entities Dumper $c->req;
233 my $res = encode_entities Dumper $c->res;
234 my $stash = encode_entities Dumper $c->stash;
237 <b><u>Request</u></b><br/>
239 <b><u>Response</u></b><br/>
241 <b><u>Stash</u></b><br/>
250 (en) Please come back later
251 (de) Bitte versuchen sie es spaeter nocheinmal
252 (nl) Gelieve te komen later terug
253 (no) Vennligst prov igjen senere
254 (fr) Veuillez revenir plus tard
255 (es) Vuelto por favor mas adelante
256 (pt) Voltado por favor mais tarde
257 (it) Ritornato prego piĆ¹ successivamente
262 $c->res->output( <<"" );
265 <title>$title</title>
266 <style type="text/css">
268 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
269 Tahoma, Arial, helvetica, sans-serif;
271 background-color: #eee;
276 background-color: #ccc;
277 border: 1px solid #aaa;
280 -moz-border-radius: 10px;
283 background-color: #977;
284 border: 1px solid #755;
288 -moz-border-radius: 10px;
291 background-color: #797;
292 border: 1px solid #575;
296 -moz-border-radius: 10px;
299 background-color: #779;
300 border: 1px solid #557;
303 -moz-border-radius: 10px;
309 <div class="error">$error</div>
310 <div class="infos">$infos</div>
311 <div class="name">$name</div>
318 =item $c->finalize_headers
324 sub finalize_headers { }
326 =item $c->finalize_output
332 sub finalize_output { }
334 =item $c->handler( $class, $r )
341 my ( $class, $engine ) = @_;
343 # Always expect worst case!
349 my $c = $class->prepare($engine);
350 $c->{stats} = \@stats;
355 if ( $class->debug ) {
357 ( $elapsed, $status ) = $class->benchmark($handler);
358 $elapsed = sprintf '%f', $elapsed;
359 my $av = sprintf '%.3f', 1 / $elapsed;
360 my $t = Text::ASCIITable->new;
361 $t->setCols( 'Action', 'Time' );
362 $t->setColWidth( 'Action', 64, 1 );
363 $t->setColWidth( 'Time', 9, 1 );
365 for my $stat (@stats) { $t->addRow( $stat->[0], $stat->[1] ) }
366 $class->log->info( "Request took $elapsed" . "s ($av/s)",
369 else { $status = &$handler }
373 if ( my $error = $@ ) {
375 $class->log->error(qq/Caught exception in engine "$error"/);
382 =item $c->prepare($r)
384 Turns the engine-specific request( Apache, CGI ... )
385 into a Catalyst context .
390 my ( $class, $r ) = @_;
393 request => Catalyst::Request->new(
397 headers => HTTP::Headers->new,
403 response => Catalyst::Response->new(
404 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
411 my $secs = time - $START || 1;
412 my $av = sprintf '%.3f', $COUNT / $secs;
413 $c->log->debug('**********************************');
414 $c->log->debug("* Request $COUNT ($av/s) [$$]");
415 $c->log->debug('**********************************');
416 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
419 $c->prepare_request($r);
423 $c->prepare_connection;
425 my $method = $c->req->method || '';
426 my $path = $c->req->path || '';
427 my $hostname = $c->req->hostname || '';
428 my $address = $c->req->address || '';
429 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
433 $c->prepare_parameters;
435 if ( $c->debug && keys %{ $c->req->params } ) {
436 my $t = Text::ASCIITable->new;
437 $t->setCols( 'Key', 'Value' );
438 $t->setColWidth( 'Key', 37, 1 );
439 $t->setColWidth( 'Value', 36, 1 );
440 for my $key ( keys %{ $c->req->params } ) {
441 my $value = $c->req->params->{$key} || '';
442 $t->addRow( $key, $value );
444 $c->log->debug( 'Parameters are', $t->draw );
451 =item $c->prepare_action
459 my $path = $c->req->path;
460 my @path = split /\//, $c->req->path;
461 $c->req->args( \my @args );
464 $path = join '/', @path;
465 if ( my $result = ${ $c->get_action($path) }[0] ) {
469 my $match = $result->[1];
470 my @snippets = @{ $result->[2] };
472 qq/Requested action is "$path" and matched "$match"/)
475 'Snippets are "' . join( ' ', @snippets ) . '"' )
476 if ( $c->debug && @snippets );
477 $c->req->action($match);
478 $c->req->snippets( \@snippets );
482 $c->req->action($path);
483 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
486 $c->req->match($path);
489 unshift @args, pop @path;
492 unless ( $c->req->action ) {
493 $c->req->action('default');
497 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
498 if ( $c->debug && @args );
501 =item $c->prepare_connection
507 sub prepare_connection { }
509 =item $c->prepare_cookies
515 sub prepare_cookies {
518 if ( my $header = $c->request->header('Cookie') ) {
519 $c->req->cookies( { CGI::Cookie->parse($header) } );
523 =item $c->prepare_headers
529 sub prepare_headers { }
531 =item $c->prepare_parameters
537 sub prepare_parameters { }
539 =item $c->prepare_path
541 Prepare path and base.
547 =item $c->prepare_request
549 Prepare the engine request.
553 sub prepare_request { }
555 =item $c->prepare_uploads
561 sub prepare_uploads { }
575 Returns a C<Catalyst::Request> object.
583 Returns a C<Catalyst::Response> object.
597 $self->setup_components;
598 if ( $self->debug ) {
599 my $name = $self->config->{name} || 'Application';
600 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
604 =item $class->setup_components
610 sub setup_components {
614 my $class = ref $self || $self;
617 import Module::Pluggable::Fast
618 name => '_components',
620 '$class\::Controller', '$class\::C',
621 '$class\::Model', '$class\::M',
622 '$class\::View', '$class\::V'
625 if ( my $error = $@ ) {
627 die qq/Couldn't load components "$error"/;
630 $self->components( {} );
632 for my $comp ( $self->_components($self) ) {
633 $self->components->{ ref $comp } = $comp;
637 my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
638 $t->setCols('Class');
639 $t->setColWidth( 'Class', 75, 1 );
640 $t->addRow($_) for keys %{ $self->components };
641 $self->log->debug( 'Loaded components', $t->draw )
642 if ( @{ $t->{tbl_rows} } && $self->debug );
644 $self->setup_actions( [ $self, @comps ] );
649 Contains the return value of the last executed action.
653 Returns a hashref containing all your data.
655 $c->stash->{foo} ||= 'yada';
656 print $c->stash->{foo};
663 my $stash = $_[1] ? {@_} : $_[0];
664 while ( my ( $key, $val ) = each %$stash ) {
665 $self->{stash}->{$key} = $val;
668 return $self->{stash};
675 Sebastian Riedel, C<sri@cpan.org>
679 This program is free software, you can redistribute it and/or modify it under
680 the same terms as Perl itself.