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 __PACKAGE__->mk_classdata('components');
20 __PACKAGE__->mk_accessors(qw/counter depth request response state/);
26 # For backwards compatibility
27 *finalize_output = \&finalize_body;
32 our $RECURSION = 1000;
33 our $DETACH = "catalyst_detach\n";
37 Catalyst::Engine - The Catalyst Engine
49 =item $c->benchmark($coderef)
51 Takes a coderef with arguments and returns elapsed time as float.
53 my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
54 $c->log->info( sprintf "Processing took %f seconds", $elapsed );
61 my $time = [gettimeofday];
62 my @return = &$code(@_);
63 my $elapsed = tv_interval $time;
64 return wantarray ? ( $elapsed, @return ) : $elapsed;
69 =item $c->component($name)
71 Get a component object by name.
73 $c->comp('MyApp::Model::MyModel')->do_stuff;
75 Regex search for a component.
77 $c->comp('mymodel')->do_stuff;
88 if ( my $component = $c->components->{$name} ) {
93 for my $component ( keys %{ $c->components } ) {
94 return $c->components->{$component} if $component =~ /$name/i;
99 return sort keys %{ $c->components };
104 Returns a hashref containing coderefs and execution counts.
105 (Needed for deep recursion detection)
109 Returns the actual forward depth.
113 =item $c->error($error, ...)
115 =item $c->error($arrayref)
117 Returns an arrayref containing error messages.
119 my @error = @{ $c->error };
123 $c->error('Something bad happened');
129 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
130 push @{ $c->{error} }, @$error;
134 =item $c->execute($class, $coderef)
136 Execute a coderef in given class and catch exceptions.
137 Errors are available via $c->error.
142 my ( $c, $class, $code ) = @_;
143 $class = $c->components->{$class} || $class;
145 my $callsub = ( caller(1) )[3];
149 $action = $c->actions->{reverse}->{"$code"};
150 $action = "/$action" unless $action =~ /\-\>/;
151 $c->counter->{"$code"}++;
153 if ( $c->counter->{"$code"} > $RECURSION ) {
154 my $error = qq/Deep recursion detected in "$action"/;
155 $c->log->error($error);
161 $action = "-> $action" if $callsub =~ /forward$/;
168 my ( $elapsed, @state ) =
169 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
170 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
173 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) }
177 if ( my $error = $@ ) {
179 if ( $error eq $DETACH ) { die $DETACH if $c->{depth} > 1 }
181 unless ( ref $error ) {
183 $error = qq/Caught exception "$error"/;
186 $c->log->error($error);
203 $c->finalize_cookies;
205 if ( my $location = $c->response->redirect ) {
206 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
207 $c->response->header( Location => $location );
208 $c->response->status(302) if $c->response->status !~ /^3\d\d$/;
211 if ( $#{ $c->error } >= 0 ) {
215 if ( !$c->response->body && $c->response->status == 200 ) {
219 if ( $c->response->body && !$c->response->content_length ) {
220 $c->response->content_length( bytes::length( $c->response->body ) );
223 if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
224 $c->response->headers->remove_header("Content-Length");
225 $c->response->body('');
228 if ( $c->request->method eq 'HEAD' ) {
229 $c->response->body('');
232 my $status = $c->finalize_headers;
237 =item $c->finalize_output
239 <obsolete>, see finalize_body
241 =item $c->finalize_body
247 sub finalize_body { }
249 =item $c->finalize_cookies
255 sub finalize_cookies {
258 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
259 my $cookie = CGI::Cookie->new(
261 -value => $cookie->{value},
262 -expires => $cookie->{expires},
263 -domain => $cookie->{domain},
264 -path => $cookie->{path},
265 -secure => $cookie->{secure} || 0
268 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
272 =item $c->finalize_error
281 $c->res->headers->content_type('text/html');
282 my $name = $c->config->{name} || 'Catalyst Application';
284 my ( $title, $error, $infos );
288 local $Data::Dumper::Terse = 1;
290 map { '<code class="error">' . encode_entities($_) . '</code>' }
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;
377 <div class="error">$error</div>
378 <div class="infos">$infos</div>
379 <div class="name">$name</div>
386 =item $c->finalize_headers
392 sub finalize_headers { }
394 =item $c->handler( $class, @arguments )
401 my ( $class, @arguments ) = @_;
403 # Always expect worst case!
409 my $c = $class->prepare(@arguments);
410 $c->{stats} = \@stats;
415 if ( $class->debug ) {
417 ( $elapsed, $status ) = $class->benchmark($handler);
418 $elapsed = sprintf '%f', $elapsed;
419 my $av = sprintf '%.3f',
420 ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
421 my $t = Text::ASCIITable->new;
422 $t->setCols( 'Action', 'Time' );
423 $t->setColWidth( 'Action', 64, 1 );
424 $t->setColWidth( 'Time', 9, 1 );
426 for my $stat (@stats) { $t->addRow( $stat->[0], $stat->[1] ) }
428 "Request took ${elapsed}s ($av/s)\n" . $t->draw );
430 else { $status = &$handler }
434 if ( my $error = $@ ) {
436 $class->log->error(qq/Caught exception in engine "$error"/);
443 =item $c->prepare(@arguments)
445 Turns the engine-specific request( Apache, CGI ... )
446 into a Catalyst context .
451 my ( $class, @arguments ) = @_;
456 request => Catalyst::Request->new(
460 headers => HTTP::Headers->new,
467 response => Catalyst::Response->new(
471 headers => HTTP::Headers->new( 'Content-Length' => 0 ),
480 my $secs = time - $START || 1;
481 my $av = sprintf '%.3f', $COUNT / $secs;
482 $c->log->debug('**********************************');
483 $c->log->debug("* Request $COUNT ($av/s) [$$]");
484 $c->log->debug('**********************************');
485 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
488 $c->prepare_request(@arguments);
489 $c->prepare_connection;
495 my $method = $c->req->method || '';
496 my $path = $c->req->path || '';
497 my $address = $c->req->address || '';
499 $c->log->debug(qq/"$method" request for "$path" from $address/)
502 if ( $c->request->method eq 'POST' and $c->request->content_length ) {
504 if ( $c->req->content_type eq 'application/x-www-form-urlencoded' ) {
505 $c->prepare_parameters;
507 elsif ( $c->req->content_type eq 'multipart/form-data' ) {
508 $c->prepare_parameters;
516 if ( $c->request->method eq 'GET' ) {
517 $c->prepare_parameters;
520 if ( $c->debug && keys %{ $c->req->params } ) {
521 my $t = Text::ASCIITable->new;
522 $t->setCols( 'Key', 'Value' );
523 $t->setColWidth( 'Key', 37, 1 );
524 $t->setColWidth( 'Value', 36, 1 );
525 for my $key ( sort keys %{ $c->req->params } ) {
526 my $param = $c->req->params->{$key};
527 my $value = defined($param) ? $param : '';
528 $t->addRow( $key, $value );
530 $c->log->debug( "Parameters are:\n" . $t->draw );
536 =item $c->prepare_action
544 my $path = $c->req->path;
545 my @path = split /\//, $c->req->path;
546 $c->req->args( \my @args );
549 $path = join '/', @path;
550 if ( my $result = ${ $c->get_action($path) }[0] ) {
554 my $match = $result->[1];
555 my @snippets = @{ $result->[2] };
557 qq/Requested action is "$path" and matched "$match"/)
560 'Snippets are "' . join( ' ', @snippets ) . '"' )
561 if ( $c->debug && @snippets );
562 $c->req->action($match);
563 $c->req->snippets( \@snippets );
567 $c->req->action($path);
568 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
571 $c->req->match($path);
574 unshift @args, pop @path;
577 unless ( $c->req->action ) {
578 $c->req->action('default');
582 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
583 if ( $c->debug && @args );
586 =item $c->prepare_body
588 Prepare message body.
594 =item $c->prepare_connection
600 sub prepare_connection { }
602 =item $c->prepare_cookies
608 sub prepare_cookies {
611 if ( my $header = $c->request->header('Cookie') ) {
612 $c->req->cookies( { CGI::Cookie->parse($header) } );
616 =item $c->prepare_headers
622 sub prepare_headers { }
624 =item $c->prepare_parameters
630 sub prepare_parameters { }
632 =item $c->prepare_path
634 Prepare path and base.
640 =item $c->prepare_request
642 Prepare the engine request.
646 sub prepare_request { }
648 =item $c->prepare_uploads
654 sub prepare_uploads { }
668 Returns a C<Catalyst::Request> object.
676 Returns a C<Catalyst::Response> object.
682 Contains the return value of the last executed action.
686 Returns a hashref containing all your data.
688 $c->stash->{foo} ||= 'yada';
689 print $c->stash->{foo};
696 my $stash = @_ > 1 ? {@_} : $_[0];
697 while ( my ( $key, $val ) = each %$stash ) {
698 $self->{stash}->{$key} = $val;
701 return $self->{stash};
708 Sebastian Riedel, C<sri@cpan.org>
712 This program is free software, you can redistribute it and/or modify it under
713 the same terms as Perl itself.