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;
19 require Module::Pluggable::Fast;
22 $Data::Dumper::Terse = 1;
24 __PACKAGE__->mk_classdata('components');
25 __PACKAGE__->mk_accessors(qw/counter depth request response state/);
31 # For backwards compatibility
32 *finalize_output = \&finalize_body;
37 our $RECURSION = 1000;
38 our $DETACH = "catalyst_detach\n";
42 Catalyst::Engine - The Catalyst Engine
54 =item $c->benchmark($coderef)
56 Takes a coderef with arguments and returns elapsed time as float.
58 my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
59 $c->log->info( sprintf "Processing took %f seconds", $elapsed );
66 my $time = [gettimeofday];
67 my @return = &$code(@_);
68 my $elapsed = tv_interval $time;
69 return wantarray ? ( $elapsed, @return ) : $elapsed;
74 =item $c->component($name)
76 Get a component object by name.
78 $c->comp('MyApp::Model::MyModel')->do_stuff;
80 Regex search for a component.
82 $c->comp('mymodel')->do_stuff;
93 if ( my $component = $c->components->{$name} ) {
98 for my $component ( keys %{ $c->components } ) {
99 return $c->components->{$component} if $component =~ /$name/i;
104 return sort keys %{ $c->components };
109 Returns a hashref containing coderefs and execution counts.
110 (Needed for deep recursion detection)
114 Returns the actual forward depth.
118 =item $c->error($error, ...)
120 =item $c->error($arrayref)
122 Returns an arrayref containing error messages.
124 my @error = @{ $c->error };
128 $c->error('Something bad happened');
134 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
135 push @{ $c->{error} }, @$error;
139 =item $c->execute($class, $coderef)
141 Execute a coderef in given class and catch exceptions.
142 Errors are available via $c->error.
147 my ( $c, $class, $code ) = @_;
148 $class = $c->components->{$class} || $class;
150 my $callsub = ( caller(1) )[3];
154 $action = $c->actions->{reverse}->{"$code"};
155 $action = "/$action" unless $action =~ /\-\>/;
156 $c->counter->{"$code"}++;
158 if ( $c->counter->{"$code"} > $RECURSION ) {
159 my $error = qq/Deep recursion detected in "$action"/;
160 $c->log->error($error);
166 $action = "-> $action" if $callsub =~ /forward$/;
173 my ( $elapsed, @state ) =
174 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
175 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
178 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) }
182 if ( my $error = $@ ) {
184 if ( $error eq $DETACH ) { die $DETACH if $c->{depth} > 1 }
186 unless ( ref $error ) {
188 $error = qq/Caught exception "$error"/;
191 $c->log->error($error);
208 $c->finalize_cookies;
210 if ( my $location = $c->response->redirect ) {
211 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
212 $c->response->header( Location => $location );
213 $c->response->status(302) if $c->response->status !~ /^3\d\d$/;
216 if ( $#{ $c->error } >= 0 ) {
220 if ( !$c->response->body && $c->response->status == 200 ) {
224 if ( $c->response->body && !$c->response->content_length ) {
225 $c->response->content_length( bytes::length( $c->response->body ) );
228 if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
229 $c->response->headers->remove_header("Content-Length");
230 $c->response->body('');
233 if ( $c->request->method eq 'HEAD' ) {
234 $c->response->body('');
237 my $status = $c->finalize_headers;
242 =item $c->finalize_output
244 <obsolete>, see finalize_body
246 =item $c->finalize_body
252 sub finalize_body { }
254 =item $c->finalize_cookies
260 sub finalize_cookies {
263 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
264 my $cookie = CGI::Cookie->new(
266 -value => $cookie->{value},
267 -expires => $cookie->{expires},
268 -domain => $cookie->{domain},
269 -path => $cookie->{path},
270 -secure => $cookie->{secure} || 0
273 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
277 =item $c->finalize_error
286 $c->res->headers->content_type('text/html');
287 my $name = $c->config->{name} || 'Catalyst Application';
289 my ( $title, $error, $infos );
291 $error = join '<br/>', @{ $c->error };
292 $error ||= 'No output';
293 $title = $name = "$name on Catalyst $Catalyst::VERSION";
294 my $req = encode_entities Dumper $c->req;
295 my $res = encode_entities Dumper $c->res;
296 my $stash = encode_entities Dumper $c->stash;
299 <b><u>Request</u></b><br/>
301 <b><u>Response</u></b><br/>
303 <b><u>Stash</u></b><br/>
312 (en) Please come back later
313 (de) Bitte versuchen sie es spaeter nocheinmal
314 (nl) Gelieve te komen later terug
315 (no) Vennligst prov igjen senere
316 (fr) Veuillez revenir plus tard
317 (es) Vuelto por favor mas adelante
318 (pt) Voltado por favor mais tarde
319 (it) Ritornato prego piĆ¹ successivamente
324 $c->res->body( <<"" );
327 <title>$title</title>
328 <style type="text/css">
330 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
331 Tahoma, Arial, helvetica, sans-serif;
333 background-color: #eee;
338 background-color: #ccc;
339 border: 1px solid #aaa;
342 -moz-border-radius: 10px;
345 background-color: #977;
346 border: 1px solid #755;
350 -moz-border-radius: 10px;
353 background-color: #797;
354 border: 1px solid #575;
358 -moz-border-radius: 10px;
361 background-color: #779;
362 border: 1px solid #557;
365 -moz-border-radius: 10px;
371 <div class="error">$error</div>
372 <div class="infos">$infos</div>
373 <div class="name">$name</div>
380 =item $c->finalize_headers
386 sub finalize_headers { }
388 =item $c->handler( $class, @arguments )
395 my ( $class, @arguments ) = @_;
397 # Always expect worst case!
403 my $c = $class->prepare(@arguments);
404 $c->{stats} = \@stats;
409 if ( $class->debug ) {
411 ( $elapsed, $status ) = $class->benchmark($handler);
412 $elapsed = sprintf '%f', $elapsed;
413 my $av = sprintf '%.3f',
414 ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
415 my $t = Text::ASCIITable->new;
416 $t->setCols( 'Action', 'Time' );
417 $t->setColWidth( 'Action', 64, 1 );
418 $t->setColWidth( 'Time', 9, 1 );
420 for my $stat (@stats) { $t->addRow( $stat->[0], $stat->[1] ) }
421 $class->log->info( "Request took ${elapsed}s ($av/s)\n" . $t->draw );
423 else { $status = &$handler }
427 if ( my $error = $@ ) {
429 $class->log->error(qq/Caught exception in engine "$error"/);
436 =item $c->prepare(@arguments)
438 Turns the engine-specific request( Apache, CGI ... )
439 into a Catalyst context .
444 my ( $class, @arguments ) = @_;
449 request => Catalyst::Request->new(
453 headers => HTTP::Headers->new,
460 response => Catalyst::Response->new(
464 headers => HTTP::Headers->new( 'Content-Length' => 0 ),
473 my $secs = time - $START || 1;
474 my $av = sprintf '%.3f', $COUNT / $secs;
475 $c->log->debug('**********************************');
476 $c->log->debug("* Request $COUNT ($av/s) [$$]");
477 $c->log->debug('**********************************');
478 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
481 $c->prepare_request(@arguments);
482 $c->prepare_connection;
488 my $method = $c->req->method || '';
489 my $path = $c->req->path || '';
490 my $address = $c->req->address || '';
492 $c->log->debug(qq/"$method" request for "$path" from $address/)
495 if ( $c->request->method eq 'POST' and $c->request->content_length ) {
497 if ( $c->req->content_type eq 'application/x-www-form-urlencoded' ) {
498 $c->prepare_parameters;
500 elsif ( $c->req->content_type eq 'multipart/form-data' ) {
501 $c->prepare_parameters;
509 if ( $c->request->method eq 'GET' ) {
510 $c->prepare_parameters;
513 if ( $c->debug && keys %{ $c->req->params } ) {
514 my $t = Text::ASCIITable->new;
515 $t->setCols( 'Key', 'Value' );
516 $t->setColWidth( 'Key', 37, 1 );
517 $t->setColWidth( 'Value', 36, 1 );
518 for my $key ( sort keys %{ $c->req->params } ) {
519 my $param = $c->req->params->{$key};
520 my $value = defined($param) ? $param : '';
521 $t->addRow( $key, $value );
523 $c->log->debug( "Parameters are:\n" . $t->draw );
529 =item $c->prepare_action
537 my $path = $c->req->path;
538 my @path = split /\//, $c->req->path;
539 $c->req->args( \my @args );
542 $path = join '/', @path;
543 if ( my $result = ${ $c->get_action($path) }[0] ) {
547 my $match = $result->[1];
548 my @snippets = @{ $result->[2] };
550 qq/Requested action is "$path" and matched "$match"/)
553 'Snippets are "' . join( ' ', @snippets ) . '"' )
554 if ( $c->debug && @snippets );
555 $c->req->action($match);
556 $c->req->snippets( \@snippets );
560 $c->req->action($path);
561 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
564 $c->req->match($path);
567 unshift @args, pop @path;
570 unless ( $c->req->action ) {
571 $c->req->action('default');
575 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
576 if ( $c->debug && @args );
579 =item $c->prepare_body
581 Prepare message body.
587 =item $c->prepare_connection
593 sub prepare_connection { }
595 =item $c->prepare_cookies
601 sub prepare_cookies {
604 if ( my $header = $c->request->header('Cookie') ) {
605 $c->req->cookies( { CGI::Cookie->parse($header) } );
609 =item $c->prepare_headers
615 sub prepare_headers { }
617 =item $c->prepare_parameters
623 sub prepare_parameters { }
625 =item $c->prepare_path
627 Prepare path and base.
633 =item $c->prepare_request
635 Prepare the engine request.
639 sub prepare_request { }
641 =item $c->prepare_uploads
647 sub prepare_uploads { }
661 Returns a C<Catalyst::Request> object.
669 Returns a C<Catalyst::Response> object.
675 Contains the return value of the last executed action.
679 Returns a hashref containing all your data.
681 $c->stash->{foo} ||= 'yada';
682 print $c->stash->{foo};
689 my $stash = @_ > 1 ? {@_} : $_[0];
690 while ( my ( $key, $val ) = each %$stash ) {
691 $self->{stash}->{$key} = $val;
694 return $self->{stash};
701 Sebastian Riedel, C<sri@cpan.org>
705 This program is free software, you can redistribute it and/or modify it under
706 the same terms as Perl itself.