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::Exception;
14 use Catalyst::Request;
15 use Catalyst::Request::Upload;
16 use Catalyst::Response;
20 $Data::Dumper::Terse = 1;
22 __PACKAGE__->mk_classdata('components');
23 __PACKAGE__->mk_accessors(qw/counter depth request response state/);
29 # For backwards compatibility
30 *finalize_output = \&finalize_body;
35 our $RECURSION = 1000;
36 our $DETACH = "catalyst_detach\n";
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 Returns the actual forward depth.
116 =item $c->error($error, ...)
118 =item $c->error($arrayref)
120 Returns an arrayref containing error messages.
122 my @error = @{ $c->error };
126 $c->error('Something bad happened');
132 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
133 push @{ $c->{error} }, @$error;
137 =item $c->execute($class, $coderef)
139 Execute a coderef in given class and catch exceptions.
140 Errors are available via $c->error.
145 my ( $c, $class, $code ) = @_;
146 $class = $c->components->{$class} || $class;
148 my $callsub = ( caller(1) )[3];
152 $action = $c->actions->{reverse}->{"$code"};
153 $action = "/$action" unless $action =~ /\-\>/;
154 $c->counter->{"$code"}++;
156 if ( $c->counter->{"$code"} > $RECURSION ) {
157 my $error = qq/Deep recursion detected in "$action"/;
158 $c->log->error($error);
164 $action = "-> $action" if $callsub =~ /forward$/;
171 my ( $elapsed, @state ) =
172 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
173 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
176 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) }
180 if ( my $error = $@ ) {
182 if ( $error eq $DETACH ) { die $DETACH if $c->{depth} > 1 }
184 unless ( ref $error ) {
186 $error = qq/Caught exception "$error"/;
189 $c->log->error($error);
206 $c->finalize_cookies;
208 if ( my $location = $c->response->redirect ) {
209 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
210 $c->response->header( Location => $location );
211 $c->response->status(302) if $c->response->status !~ /^3\d\d$/;
214 if ( $#{ $c->error } >= 0 ) {
218 if ( !$c->response->body && $c->response->status == 200 ) {
222 if ( $c->response->body && !$c->response->content_length ) {
223 $c->response->content_length( bytes::length( $c->response->body ) );
226 if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
227 $c->response->headers->remove_header("Content-Length");
228 $c->response->body('');
231 if ( $c->request->method eq 'HEAD' ) {
232 $c->response->body('');
235 my $status = $c->finalize_headers;
240 =item $c->finalize_output
242 <obsolete>, see finalize_body
244 =item $c->finalize_body
250 sub finalize_body { }
252 =item $c->finalize_cookies
258 sub finalize_cookies {
261 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
262 my $cookie = CGI::Cookie->new(
264 -value => $cookie->{value},
265 -expires => $cookie->{expires},
266 -domain => $cookie->{domain},
267 -path => $cookie->{path},
268 -secure => $cookie->{secure} || 0
271 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
275 =item $c->finalize_error
284 $c->res->headers->content_type('text/html');
285 my $name = $c->config->{name} || 'Catalyst Application';
287 my ( $title, $error, $infos );
289 $error = join '', map { '<code class="error">' . encode_entities($_) . '</code>' } @{ $c->error };
290 $error ||= 'No output';
291 $title = $name = "$name on Catalyst $Catalyst::VERSION";
292 my $req = encode_entities Dumper $c->req;
293 my $res = encode_entities Dumper $c->res;
294 my $stash = encode_entities Dumper $c->stash;
297 <b><u>Request</u></b><br/>
299 <b><u>Response</u></b><br/>
301 <b><u>Stash</u></b><br/>
310 (en) Please come back later
311 (de) Bitte versuchen sie es spaeter nocheinmal
312 (nl) Gelieve te komen later terug
313 (no) Vennligst prov igjen senere
314 (fr) Veuillez revenir plus tard
315 (es) Vuelto por favor mas adelante
316 (pt) Voltado por favor mais tarde
317 (it) Ritornato prego piĆ¹ successivamente
322 $c->res->body( <<"" );
325 <title>$title</title>
326 <style type="text/css">
328 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
329 Tahoma, Arial, helvetica, sans-serif;
331 background-color: #eee;
336 background-color: #ccc;
337 border: 1px solid #aaa;
340 -moz-border-radius: 10px;
343 background-color: #977;
344 border: 1px solid #755;
348 -moz-border-radius: 10px;
351 background-color: #797;
352 border: 1px solid #575;
356 -moz-border-radius: 10px;
359 background-color: #779;
360 border: 1px solid #557;
363 -moz-border-radius: 10px;
375 <div class="error">$error</div>
376 <div class="infos">$infos</div>
377 <div class="name">$name</div>
384 =item $c->finalize_headers
390 sub finalize_headers { }
392 =item $c->handler( $class, @arguments )
399 my ( $class, @arguments ) = @_;
401 # Always expect worst case!
407 my $c = $class->prepare(@arguments);
408 $c->{stats} = \@stats;
413 if ( $class->debug ) {
415 ( $elapsed, $status ) = $class->benchmark($handler);
416 $elapsed = sprintf '%f', $elapsed;
417 my $av = sprintf '%.3f',
418 ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
419 my $t = Text::ASCIITable->new;
420 $t->setCols( 'Action', 'Time' );
421 $t->setColWidth( 'Action', 64, 1 );
422 $t->setColWidth( 'Time', 9, 1 );
424 for my $stat (@stats) { $t->addRow( $stat->[0], $stat->[1] ) }
425 $class->log->info( "Request took ${elapsed}s ($av/s)\n" . $t->draw );
427 else { $status = &$handler }
431 if ( my $error = $@ ) {
433 $class->log->error(qq/Caught exception in engine "$error"/);
440 =item $c->prepare(@arguments)
442 Turns the engine-specific request( Apache, CGI ... )
443 into a Catalyst context .
448 my ( $class, @arguments ) = @_;
453 request => Catalyst::Request->new(
457 headers => HTTP::Headers->new,
464 response => Catalyst::Response->new(
468 headers => HTTP::Headers->new( 'Content-Length' => 0 ),
477 my $secs = time - $START || 1;
478 my $av = sprintf '%.3f', $COUNT / $secs;
479 $c->log->debug('**********************************');
480 $c->log->debug("* Request $COUNT ($av/s) [$$]");
481 $c->log->debug('**********************************');
482 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
485 $c->prepare_request(@arguments);
486 $c->prepare_connection;
492 my $method = $c->req->method || '';
493 my $path = $c->req->path || '';
494 my $address = $c->req->address || '';
496 $c->log->debug(qq/"$method" request for "$path" from $address/)
499 if ( $c->request->method eq 'POST' and $c->request->content_length ) {
501 if ( $c->req->content_type eq 'application/x-www-form-urlencoded' ) {
502 $c->prepare_parameters;
504 elsif ( $c->req->content_type eq 'multipart/form-data' ) {
505 $c->prepare_parameters;
513 if ( $c->request->method eq 'GET' ) {
514 $c->prepare_parameters;
517 if ( $c->debug && keys %{ $c->req->params } ) {
518 my $t = Text::ASCIITable->new;
519 $t->setCols( 'Key', 'Value' );
520 $t->setColWidth( 'Key', 37, 1 );
521 $t->setColWidth( 'Value', 36, 1 );
522 for my $key ( sort keys %{ $c->req->params } ) {
523 my $param = $c->req->params->{$key};
524 my $value = defined($param) ? $param : '';
525 $t->addRow( $key, $value );
527 $c->log->debug( "Parameters are:\n" . $t->draw );
533 =item $c->prepare_action
541 my $path = $c->req->path;
542 my @path = split /\//, $c->req->path;
543 $c->req->args( \my @args );
546 $path = join '/', @path;
547 if ( my $result = ${ $c->get_action($path) }[0] ) {
551 my $match = $result->[1];
552 my @snippets = @{ $result->[2] };
554 qq/Requested action is "$path" and matched "$match"/)
557 'Snippets are "' . join( ' ', @snippets ) . '"' )
558 if ( $c->debug && @snippets );
559 $c->req->action($match);
560 $c->req->snippets( \@snippets );
564 $c->req->action($path);
565 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
568 $c->req->match($path);
571 unshift @args, pop @path;
574 unless ( $c->req->action ) {
575 $c->req->action('default');
579 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
580 if ( $c->debug && @args );
583 =item $c->prepare_body
585 Prepare message body.
591 =item $c->prepare_connection
597 sub prepare_connection { }
599 =item $c->prepare_cookies
605 sub prepare_cookies {
608 if ( my $header = $c->request->header('Cookie') ) {
609 $c->req->cookies( { CGI::Cookie->parse($header) } );
613 =item $c->prepare_headers
619 sub prepare_headers { }
621 =item $c->prepare_parameters
627 sub prepare_parameters { }
629 =item $c->prepare_path
631 Prepare path and base.
637 =item $c->prepare_request
639 Prepare the engine request.
643 sub prepare_request { }
645 =item $c->prepare_uploads
651 sub prepare_uploads { }
665 Returns a C<Catalyst::Request> object.
673 Returns a C<Catalyst::Response> object.
679 Contains the return value of the last executed action.
683 Returns a hashref containing all your data.
685 $c->stash->{foo} ||= 'yada';
686 print $c->stash->{foo};
693 my $stash = @_ > 1 ? {@_} : $_[0];
694 while ( my ( $key, $val ) = each %$stash ) {
695 $self->{stash}->{$key} = $val;
698 return $self->{stash};
705 Sebastian Riedel, C<sri@cpan.org>
709 This program is free software, you can redistribute it and/or modify it under
710 the same terms as Perl itself.