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::Request;
14 use Catalyst::Request::Upload;
15 use Catalyst::Response;
17 require Module::Pluggable::Fast;
20 $Data::Dumper::Terse = 1;
22 __PACKAGE__->mk_classdata('components');
23 __PACKAGE__->mk_accessors(qw/counter request response state/);
29 # For backwards compatibility
30 *finalize_output = \&finalize_body;
35 our $RECURSION = 1000;
39 Catalyst::Engine - The Catalyst Engine
51 =item $c->benchmark($coderef)
53 Takes a coderef with arguments and returns elapsed time as float.
55 my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
56 $c->log->info( sprintf "Processing took %f seconds", $elapsed );
63 my $time = [gettimeofday];
64 my @return = &$code(@_);
65 my $elapsed = tv_interval $time;
66 return wantarray ? ( $elapsed, @return ) : $elapsed;
71 =item $c->component($name)
73 Get a component object by name.
75 $c->comp('MyApp::Model::MyModel')->do_stuff;
77 Regex search for a component.
79 $c->comp('mymodel')->do_stuff;
90 if ( my $component = $c->components->{$name} ) {
95 for my $component ( keys %{ $c->components } ) {
96 return $c->components->{$component} if $component =~ /$name/i;
101 return sort keys %{ $c->components };
106 Returns a hashref containing coderefs and execution counts.
107 (Needed for deep recursion detection)
111 =item $c->error($error, ...)
113 =item $c->error($arrayref)
115 Returns an arrayref containing error messages.
117 my @error = @{ $c->error };
121 $c->error('Something bad happened');
127 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
128 push @{ $c->{error} }, @$error;
132 =item $c->execute($class, $coderef)
134 Execute a coderef in given class and catch exceptions.
135 Errors are available via $c->error.
140 my ( $c, $class, $code ) = @_;
141 $class = $c->components->{$class} || $class;
143 my $callsub = ( caller(1) )[3];
147 $action = $c->actions->{reverse}->{"$code"};
148 $action = "/$action" unless $action =~ /\-\>/;
149 $c->counter->{"$code"}++;
151 if ( $c->counter->{"$code"} > $RECURSION ) {
152 my $error = qq/Deep recursion detected in "$action"/;
153 $c->log->error($error);
159 $action = "-> $action" if $callsub =~ /forward$/;
165 my ( $elapsed, @state ) =
166 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
167 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
170 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
173 if ( my $error = $@ ) {
175 unless ( ref $error ) {
177 $error = qq/Caught exception "$error"/;
180 $c->log->error($error);
196 $c->finalize_cookies;
198 if ( my $location = $c->response->redirect ) {
199 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
200 $c->response->header( Location => $location );
201 $c->response->status(302) if $c->response->status !~ /^3\d\d$/;
204 if ( $#{ $c->error } >= 0 ) {
208 if ( !$c->response->body && $c->response->status !~ /^(1|3)\d\d$/ ) {
212 if ( $c->response->body && !$c->response->content_length ) {
213 use bytes; # play safe with a utf8 aware perl
214 $c->response->content_length( length $c->response->body );
217 my $status = $c->finalize_headers;
222 =item $c->finalize_body
228 sub finalize_body { }
230 =item $c->finalize_cookies
236 sub finalize_cookies {
239 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
240 my $cookie = CGI::Cookie->new(
242 -value => $cookie->{value},
243 -expires => $cookie->{expires},
244 -domain => $cookie->{domain},
245 -path => $cookie->{path},
246 -secure => $cookie->{secure} || 0
249 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
253 =item $c->finalize_error
262 $c->res->headers->content_type('text/html');
263 my $name = $c->config->{name} || 'Catalyst Application';
265 my ( $title, $error, $infos );
267 $error = join '<br/>', @{ $c->error };
268 $error ||= 'No output';
269 $title = $name = "$name on Catalyst $Catalyst::VERSION";
270 my $req = encode_entities Dumper $c->req;
271 my $res = encode_entities Dumper $c->res;
272 my $stash = encode_entities Dumper $c->stash;
275 <b><u>Request</u></b><br/>
277 <b><u>Response</u></b><br/>
279 <b><u>Stash</u></b><br/>
288 (en) Please come back later
289 (de) Bitte versuchen sie es spaeter nocheinmal
290 (nl) Gelieve te komen later terug
291 (no) Vennligst prov igjen senere
292 (fr) Veuillez revenir plus tard
293 (es) Vuelto por favor mas adelante
294 (pt) Voltado por favor mais tarde
295 (it) Ritornato prego piĆ¹ successivamente
300 $c->res->body( <<"" );
303 <title>$title</title>
304 <style type="text/css">
306 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
307 Tahoma, Arial, helvetica, sans-serif;
309 background-color: #eee;
314 background-color: #ccc;
315 border: 1px solid #aaa;
318 -moz-border-radius: 10px;
321 background-color: #977;
322 border: 1px solid #755;
326 -moz-border-radius: 10px;
329 background-color: #797;
330 border: 1px solid #575;
334 -moz-border-radius: 10px;
337 background-color: #779;
338 border: 1px solid #557;
341 -moz-border-radius: 10px;
347 <div class="error">$error</div>
348 <div class="infos">$infos</div>
349 <div class="name">$name</div>
356 =item $c->finalize_headers
362 sub finalize_headers { }
364 =item $c->handler( $class, $engine )
371 my ( $class, $engine ) = @_;
373 # Always expect worst case!
379 my $c = $class->prepare($engine);
380 $c->{stats} = \@stats;
385 if ( $class->debug ) {
387 ( $elapsed, $status ) = $class->benchmark($handler);
388 $elapsed = sprintf '%f', $elapsed;
389 my $av = sprintf '%.3f',
390 ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
391 my $t = Text::ASCIITable->new;
392 $t->setCols( 'Action', 'Time' );
393 $t->setColWidth( 'Action', 64, 1 );
394 $t->setColWidth( 'Time', 9, 1 );
396 for my $stat (@stats) { $t->addRow( $stat->[0], $stat->[1] ) }
397 $class->log->info( "Request took $elapsed" . "s ($av/s)",
400 else { $status = &$handler }
404 if ( my $error = $@ ) {
406 $class->log->error(qq/Caught exception in engine "$error"/);
413 =item $c->prepare($engine)
415 Turns the engine-specific request( Apache, CGI ... )
416 into a Catalyst context .
421 my ( $class, $engine ) = @_;
425 request => Catalyst::Request->new(
429 headers => HTTP::Headers->new,
436 response => Catalyst::Response->new(
440 headers => HTTP::Headers->new,
449 my $secs = time - $START || 1;
450 my $av = sprintf '%.3f', $COUNT / $secs;
451 $c->log->debug('**********************************');
452 $c->log->debug("* Request $COUNT ($av/s) [$$]");
453 $c->log->debug('**********************************');
454 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
457 $c->prepare_request($engine);
458 $c->prepare_connection;
464 my $method = $c->req->method || '';
465 my $path = $c->req->path || '';
466 my $hostname = $c->req->hostname || '';
467 my $address = $c->req->address || '';
469 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
472 if ( $c->request->method eq 'POST' and $c->request->content_length ) {
474 if ( $c->req->content_type eq 'application/x-www-form-urlencoded' ) {
475 $c->prepare_parameters;
477 elsif ( $c->req->content_type eq 'multipart/form-data' ) {
478 $c->prepare_parameters;
486 if ( $c->request->method eq 'GET' ) {
487 $c->prepare_parameters;
490 if ( $c->debug && keys %{ $c->req->params } ) {
491 my $t = Text::ASCIITable->new;
492 $t->setCols( 'Key', 'Value' );
493 $t->setColWidth( 'Key', 37, 1 );
494 $t->setColWidth( 'Value', 36, 1 );
495 for my $key ( sort keys %{ $c->req->params } ) {
496 my $param = $c->req->params->{$key};
497 my $value = defined($param) ? $param : '';
498 $t->addRow( $key, $value );
500 $c->log->debug( 'Parameters are', $t->draw );
506 =item $c->prepare_action
514 my $path = $c->req->path;
515 my @path = split /\//, $c->req->path;
516 $c->req->args( \my @args );
519 $path = join '/', @path;
520 if ( my $result = ${ $c->get_action($path) }[0] ) {
524 my $match = $result->[1];
525 my @snippets = @{ $result->[2] };
527 qq/Requested action is "$path" and matched "$match"/)
530 'Snippets are "' . join( ' ', @snippets ) . '"' )
531 if ( $c->debug && @snippets );
532 $c->req->action($match);
533 $c->req->snippets( \@snippets );
537 $c->req->action($path);
538 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
541 $c->req->match($path);
544 unshift @args, pop @path;
547 unless ( $c->req->action ) {
548 $c->req->action('default');
552 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
553 if ( $c->debug && @args );
556 =item $c->prepare_body
558 Prepare message body.
564 =item $c->prepare_connection
570 sub prepare_connection { }
572 =item $c->prepare_cookies
578 sub prepare_cookies {
581 if ( my $header = $c->request->header('Cookie') ) {
582 $c->req->cookies( { CGI::Cookie->parse($header) } );
586 =item $c->prepare_headers
592 sub prepare_headers { }
594 =item $c->prepare_parameters
600 sub prepare_parameters { }
602 =item $c->prepare_path
604 Prepare path and base.
610 =item $c->prepare_request
612 Prepare the engine request.
616 sub prepare_request { }
618 =item $c->prepare_uploads
624 sub prepare_uploads { }
626 =item $c->retrieve_components
632 sub retrieve_components {
635 my $class = ref $self || $self;
638 import Module::Pluggable::Fast
639 name => '_components',
641 '$class\::Controller', '$class\::C',
642 '$class\::Model', '$class\::M',
643 '$class\::View', '$class\::V'
647 if ( my $error = $@ ) {
649 die qq/Couldn't load components "$error"/;
652 return $self->_components;
667 Returns a C<Catalyst::Request> object.
675 Returns a C<Catalyst::Response> object.
689 $self->setup_components;
690 if ( $self->debug ) {
691 my $name = $self->config->{name} || 'Application';
692 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
696 =item $class->setup_components
702 sub setup_components {
706 my $class = ref $self || $self;
709 import Module::Pluggable::Fast
710 name => '_components',
712 '$class\::Controller', '$class\::C',
713 '$class\::Model', '$class\::M',
714 '$class\::View', '$class\::V'
717 if ( my $error = $@ ) {
719 die qq/Couldn't load components "$error"/;
722 $self->components( {} );
724 for my $comp ( $self->_components($self) ) {
725 $self->components->{ ref $comp } = $comp;
729 my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
730 $t->setCols('Class');
731 $t->setColWidth( 'Class', 75, 1 );
732 $t->addRow($_) for sort keys %{ $self->components };
733 $self->log->debug( 'Loaded components', $t->draw )
734 if ( @{ $t->{tbl_rows} } && $self->debug );
736 $self->setup_actions( [ $self, @comps ] );
741 Contains the return value of the last executed action.
745 Returns a hashref containing all your data.
747 $c->stash->{foo} ||= 'yada';
748 print $c->stash->{foo};
755 my $stash = @_ > 1 ? {@_} : $_[0];
756 while ( my ( $key, $val ) = each %$stash ) {
757 $self->{stash}->{$key} = $val;
760 return $self->{stash};
767 Sebastian Riedel, C<sri@cpan.org>
771 This program is free software, you can redistribute it and/or modify it under
772 the same terms as Perl itself.