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 Text::ASCIITable::Wrap 'wrap';
13 use Catalyst::Request;
14 use Catalyst::Request::Upload;
15 use Catalyst::Response;
17 require Module::Pluggable::Fast;
19 $Data::Dumper::Terse = 1;
21 __PACKAGE__->mk_classdata('components');
22 __PACKAGE__->mk_accessors(qw/request response state/);
33 Catalyst::Engine - The Catalyst Engine
45 =item $c->benchmark($coderef)
47 Takes a coderef with arguments and returns elapsed time as float.
49 my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
50 $c->log->info( sprintf "Processing took %f seconds", $elapsed );
57 my $time = [gettimeofday];
58 my @return = &$code(@_);
59 my $elapsed = tv_interval $time;
60 return wantarray ? ( $elapsed, @return ) : $elapsed;
65 =item $c->component($name)
67 Get a component object by name.
69 $c->comp('MyApp::Model::MyModel')->do_stuff;
71 Regex search for a component.
73 $c->comp('mymodel')->do_stuff;
78 my ( $c, $name ) = @_;
79 if ( my $component = $c->components->{$name} ) {
83 for my $component ( keys %{ $c->components } ) {
84 return $c->components->{$component} if $component =~ /$name/i;
91 =item $c->error($error, ...)
93 =item $c->error($arrayref)
95 Returns an arrayref containing error messages.
97 my @error = @{ $c->error };
101 $c->error('Something bad happened');
107 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
108 push @{ $c->{error} }, @$error;
112 =item $c->execute($class, $coderef)
114 Execute a coderef in given class and catch exceptions.
115 Errors are available via $c->error.
120 my ( $c, $class, $code ) = @_;
121 $class = $c->comp($class) || $class;
123 my $callsub = ( caller(1) )[3];
127 my $action = $c->actions->{reverse}->{"$code"};
128 $action = "/$action" unless $action =~ /\-\>/;
129 $action = "-> $action" if $callsub =~ /forward$/;
130 my ( $elapsed, @state ) =
131 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
132 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
135 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
137 if ( my $error = $@ ) {
139 unless ( ref $error ) {
141 $error = qq/Caught exception "$error"/;
144 $c->log->error($error);
160 $c->finalize_cookies;
162 if ( my $location = $c->response->redirect ) {
163 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
164 $c->response->header( Location => $location );
165 $c->response->status(302) if $c->response->status !~ /^3\d\d$/;
168 if ( $#{ $c->error } >= 0 ) {
172 if ( !$c->response->output && $c->response->status !~ /^(1|3)\d\d$/ ) {
176 if ( $c->response->output && !$c->response->content_length ) {
177 use bytes; # play safe with a utf8 aware perl
178 $c->response->content_length( length $c->response->output );
181 my $status = $c->finalize_headers;
186 =item $c->finalize_cookies
192 sub finalize_cookies {
195 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
196 my $cookie = CGI::Cookie->new(
198 -value => $cookie->{value},
199 -expires => $cookie->{expires},
200 -domain => $cookie->{domain},
201 -path => $cookie->{path},
202 -secure => $cookie->{secure} || 0
205 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
209 =item $c->finalize_error
218 $c->res->headers->content_type('text/html');
219 my $name = $c->config->{name} || 'Catalyst Application';
221 my ( $title, $error, $infos );
223 $error = join '<br/>', @{ $c->error };
224 $error ||= 'No output';
225 $title = $name = "$name on Catalyst $Catalyst::VERSION";
226 my $req = encode_entities Dumper $c->req;
227 my $res = encode_entities Dumper $c->res;
228 my $stash = encode_entities Dumper $c->stash;
231 <b><u>Request</u></b><br/>
233 <b><u>Response</u></b><br/>
235 <b><u>Stash</u></b><br/>
244 (en) Please come back later
245 (de) Bitte versuchen sie es spaeter nocheinmal
246 (nl) Gelieve te komen later terug
247 (no) Vennligst prov igjen senere
248 (fr) Veuillez revenir plus tard
249 (es) Vuelto por favor mas adelante
250 (pt) Voltado por favor mais tarde
251 (it) Ritornato prego piĆ¹ successivamente
256 $c->res->output( <<"" );
259 <title>$title</title>
260 <style type="text/css">
262 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
263 Tahoma, Arial, helvetica, sans-serif;
265 background-color: #eee;
270 background-color: #ccc;
271 border: 1px solid #aaa;
274 -moz-border-radius: 10px;
277 background-color: #977;
278 border: 1px solid #755;
282 -moz-border-radius: 10px;
285 background-color: #797;
286 border: 1px solid #575;
290 -moz-border-radius: 10px;
293 background-color: #779;
294 border: 1px solid #557;
297 -moz-border-radius: 10px;
303 <div class="error">$error</div>
304 <div class="infos">$infos</div>
305 <div class="name">$name</div>
312 =item $c->finalize_headers
318 sub finalize_headers { }
320 =item $c->finalize_output
326 sub finalize_output { }
328 =item $c->handler( $class, $r )
335 my ( $class, $engine ) = @_;
337 # Always expect worst case!
342 my $c = $class->prepare($engine);
343 $c->{stats} = \@stats;
347 if ( $class->debug ) {
349 ( $elapsed, $status ) = $class->benchmark($handler);
350 $elapsed = sprintf '%f', $elapsed;
351 my $av = sprintf '%.3f', 1 / $elapsed;
352 my $t = Text::ASCIITable->new;
353 $t->setCols( 'Action', 'Time' );
354 $t->setColWidth( 'Action', 64, 1 );
355 $t->setColWidth( 'Time', 9, 1 );
357 for my $stat (@stats) {
358 $t->addRow( wrap( $stat->[0], 64 ), wrap( $stat->[1], 9 ) );
360 $class->log->info( "Request took $elapsed" . "s ($av/s)",
363 else { $status = &$handler }
365 if ( my $error = $@ ) {
367 $class->log->error(qq/Caught exception in engine "$error"/);
373 =item $c->prepare($r)
375 Turns the engine-specific request( Apache, CGI ... )
376 into a Catalyst context .
381 my ( $class, $r ) = @_;
383 request => Catalyst::Request->new(
387 headers => HTTP::Headers->new,
393 response => Catalyst::Response->new(
394 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
400 my $secs = time - $START || 1;
401 my $av = sprintf '%.3f', $COUNT / $secs;
402 $c->log->debug('**********************************');
403 $c->log->debug("* Request $COUNT ($av/s) [$$]");
404 $c->log->debug('**********************************');
405 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
407 $c->prepare_request($r);
411 $c->prepare_connection;
412 my $method = $c->req->method || '';
413 my $path = $c->req->path || '';
414 my $hostname = $c->req->hostname || '';
415 my $address = $c->req->address || '';
416 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
419 $c->prepare_parameters;
421 if ( $c->debug && keys %{ $c->req->params } ) {
422 my $t = Text::ASCIITable->new;
423 $t->setCols( 'Key', 'Value' );
424 $t->setColWidth( 'Key', 37, 1 );
425 $t->setColWidth( 'Value', 36, 1 );
426 for my $key ( keys %{ $c->req->params } ) {
427 my $value = $c->req->params->{$key} || '';
428 $t->addRow( wrap( $key, 37 ), wrap( $value, 36 ) );
430 $c->log->debug( 'Parameters are', $t->draw );
436 =item $c->prepare_action
444 my $path = $c->req->path;
445 my @path = split /\//, $c->req->path;
446 $c->req->args( \my @args );
448 $path = join '/', @path;
449 if ( my $result = ${ $c->get_action($path) }[0] ) {
453 my $match = $result->[1];
454 my @snippets = @{ $result->[2] };
456 qq/Requested action is "$path" and matched "$match"/)
459 'Snippets are "' . join( ' ', @snippets ) . '"' )
460 if ( $c->debug && @snippets );
461 $c->req->action($match);
462 $c->req->snippets( \@snippets );
465 $c->req->action($path);
466 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
468 $c->req->match($path);
471 unshift @args, pop @path;
473 unless ( $c->req->action ) {
474 $c->req->action('default');
477 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
478 if ( $c->debug && @args );
481 =item $c->prepare_connection
487 sub prepare_connection { }
489 =item $c->prepare_cookies
495 sub prepare_cookies {
498 if ( my $header = $c->request->header('Cookie') ) {
499 $c->req->cookies( { CGI::Cookie->parse($header) } );
503 =item $c->prepare_headers
509 sub prepare_headers { }
511 =item $c->prepare_parameters
517 sub prepare_parameters { }
519 =item $c->prepare_path
521 Prepare path and base.
527 =item $c->prepare_request
529 Prepare the engine request.
533 sub prepare_request { }
535 =item $c->prepare_uploads
541 sub prepare_uploads { }
555 Returns a C<Catalyst::Request> object.
563 Returns a C<Catalyst::Response> object.
577 $self->setup_components;
578 if ( $self->debug ) {
579 my $name = $self->config->{name} || 'Application';
580 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
584 =item $class->setup_components
590 sub setup_components {
594 my $class = ref $self || $self;
597 import Module::Pluggable::Fast
598 name => '_components',
600 '$class\::Controller', '$class\::C',
601 '$class\::Model', '$class\::M',
602 '$class\::View', '$class\::V'
605 if ( my $error = $@ ) {
608 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
610 $self->components( {} );
612 for my $comp ( $self->_components($self) ) {
613 $self->components->{ ref $comp } = $comp;
616 my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
617 $t->setCols('Class');
618 $t->setColWidth( 'Class', 75, 1 );
619 $t->addRow( wrap( $_, 75 ) ) for keys %{ $self->components };
620 $self->log->debug( 'Loaded components', $t->draw )
621 if ( @{ $t->{tbl_rows} } && $self->debug );
622 $self->setup_actions( [ $self, @comps ] );
627 Contains the return value of the last executed action.
631 Returns a hashref containing all your data.
633 $c->stash->{foo} ||= 'yada';
634 print $c->stash->{foo};
641 my $stash = $_[1] ? {@_} : $_[0];
642 while ( my ( $key, $val ) = each %$stash ) {
643 $self->{stash}->{$key} = $val;
646 return $self->{stash};
653 Sebastian Riedel, C<sri@cpan.org>
657 This program is free software, you can redistribute it and/or modify it under
658 the same terms as Perl itself.