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/request response state/);
29 # For backwards compatibility
30 *finalize_output = \&finalize_body;
38 Catalyst::Engine - The Catalyst Engine
50 =item $c->benchmark($coderef)
52 Takes a coderef with arguments and returns elapsed time as float.
54 my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
55 $c->log->info( sprintf "Processing took %f seconds", $elapsed );
62 my $time = [gettimeofday];
63 my @return = &$code(@_);
64 my $elapsed = tv_interval $time;
65 return wantarray ? ( $elapsed, @return ) : $elapsed;
70 =item $c->component($name)
72 Get a component object by name.
74 $c->comp('MyApp::Model::MyModel')->do_stuff;
76 Regex search for a component.
78 $c->comp('mymodel')->do_stuff;
83 my ( $c, $name ) = @_;
85 if ( my $component = $c->components->{$name} ) {
90 for my $component ( keys %{ $c->components } ) {
91 return $c->components->{$component} if $component =~ /$name/i;
99 =item $c->error($error, ...)
101 =item $c->error($arrayref)
103 Returns an arrayref containing error messages.
105 my @error = @{ $c->error };
109 $c->error('Something bad happened');
115 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
116 push @{ $c->{error} }, @$error;
120 =item $c->execute($class, $coderef)
122 Execute a coderef in given class and catch exceptions.
123 Errors are available via $c->error.
128 my ( $c, $class, $code ) = @_;
129 $class = $c->components->{$class} || $class;
131 my $callsub = ( caller(1) )[3];
136 my $action = $c->actions->{reverse}->{"$code"};
137 $action = "/$action" unless $action =~ /\-\>/;
138 $action = "-> $action" if $callsub =~ /forward$/;
139 my ( $elapsed, @state ) =
140 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
141 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
144 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
147 if ( my $error = $@ ) {
149 unless ( ref $error ) {
151 $error = qq/Caught exception "$error"/;
154 $c->log->error($error);
170 $c->finalize_cookies;
172 if ( my $location = $c->response->redirect ) {
173 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
174 $c->response->header( Location => $location );
175 $c->response->status(302) if $c->response->status !~ /^3\d\d$/;
178 if ( $#{ $c->error } >= 0 ) {
182 if ( !$c->response->body && $c->response->status !~ /^(1|3)\d\d$/ ) {
186 if ( $c->response->body && !$c->response->content_length ) {
187 use bytes; # play safe with a utf8 aware perl
188 $c->response->content_length( length $c->response->body );
191 my $status = $c->finalize_headers;
196 =item $c->finalize_output
198 alias to finalize_body
200 =item $c->finalize_body
206 sub finalize_body { }
208 =item $c->finalize_cookies
214 sub finalize_cookies {
217 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
218 my $cookie = CGI::Cookie->new(
220 -value => $cookie->{value},
221 -expires => $cookie->{expires},
222 -domain => $cookie->{domain},
223 -path => $cookie->{path},
224 -secure => $cookie->{secure} || 0
227 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
231 =item $c->finalize_error
240 $c->res->headers->content_type('text/html');
241 my $name = $c->config->{name} || 'Catalyst Application';
243 my ( $title, $error, $infos );
245 $error = join '<br/>', @{ $c->error };
246 $error ||= 'No output';
247 $title = $name = "$name on Catalyst $Catalyst::VERSION";
248 my $req = encode_entities Dumper $c->req;
249 my $res = encode_entities Dumper $c->res;
250 my $stash = encode_entities Dumper $c->stash;
253 <b><u>Request</u></b><br/>
255 <b><u>Response</u></b><br/>
257 <b><u>Stash</u></b><br/>
266 (en) Please come back later
267 (de) Bitte versuchen sie es spaeter nocheinmal
268 (nl) Gelieve te komen later terug
269 (no) Vennligst prov igjen senere
270 (fr) Veuillez revenir plus tard
271 (es) Vuelto por favor mas adelante
272 (pt) Voltado por favor mais tarde
273 (it) Ritornato prego piĆ¹ successivamente
278 $c->res->body( <<"" );
281 <title>$title</title>
282 <style type="text/css">
284 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
285 Tahoma, Arial, helvetica, sans-serif;
287 background-color: #eee;
292 background-color: #ccc;
293 border: 1px solid #aaa;
296 -moz-border-radius: 10px;
299 background-color: #977;
300 border: 1px solid #755;
304 -moz-border-radius: 10px;
307 background-color: #797;
308 border: 1px solid #575;
312 -moz-border-radius: 10px;
315 background-color: #779;
316 border: 1px solid #557;
319 -moz-border-radius: 10px;
325 <div class="error">$error</div>
326 <div class="infos">$infos</div>
327 <div class="name">$name</div>
334 =item $c->finalize_headers
340 sub finalize_headers { }
342 =item $c->handler( $class, $engine )
349 my ( $class, $engine ) = @_;
351 # Always expect worst case!
357 my $c = $class->prepare($engine);
358 $c->{stats} = \@stats;
363 if ( $class->debug ) {
365 ( $elapsed, $status ) = $class->benchmark($handler);
366 $elapsed = sprintf '%f', $elapsed;
367 my $av = sprintf '%.3f', ( $elapsed == 0 ? '??' : (1 / $elapsed) );
368 my $t = Text::ASCIITable->new;
369 $t->setCols( 'Action', 'Time' );
370 $t->setColWidth( 'Action', 64, 1 );
371 $t->setColWidth( 'Time', 9, 1 );
373 for my $stat (@stats) { $t->addRow( $stat->[0], $stat->[1] ) }
374 $class->log->info( "Request took $elapsed" . "s ($av/s)",
377 else { $status = &$handler }
381 if ( my $error = $@ ) {
383 $class->log->error(qq/Caught exception in engine "$error"/);
390 =item $c->prepare($engine)
392 Turns the engine-specific request( Apache, CGI ... )
393 into a Catalyst context .
398 my ( $class, $engine ) = @_;
401 request => Catalyst::Request->new(
405 headers => HTTP::Headers->new,
412 response => Catalyst::Response->new(
416 headers => HTTP::Headers->new,
425 my $secs = time - $START || 1;
426 my $av = sprintf '%.3f', $COUNT / $secs;
427 $c->log->debug('**********************************');
428 $c->log->debug("* Request $COUNT ($av/s) [$$]");
429 $c->log->debug('**********************************');
430 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
433 $c->prepare_request($engine);
434 $c->prepare_connection;
440 my $method = $c->req->method || '';
441 my $path = $c->req->path || '';
442 my $hostname = $c->req->hostname || '';
443 my $address = $c->req->address || '';
445 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
448 if ( $c->request->method eq 'POST' and $c->request->content_length ) {
450 if ( $c->req->content_type eq 'application/x-www-form-urlencoded' ) {
451 $c->prepare_parameters;
453 elsif ( $c->req->content_type eq 'multipart/form-data' ) {
454 $c->prepare_parameters;
462 if ( $c->request->method eq 'GET' ) {
463 $c->prepare_parameters;
466 if ( $c->debug && keys %{ $c->req->params } ) {
467 my $t = Text::ASCIITable->new;
468 $t->setCols( 'Key', 'Value' );
469 $t->setColWidth( 'Key', 37, 1 );
470 $t->setColWidth( 'Value', 36, 1 );
471 for my $key ( sort keys %{ $c->req->params } ) {
472 my $param = $c->req->params->{$key};
473 my $value = defined($param) ? $param : '';
474 $t->addRow( $key, $value );
476 $c->log->debug( 'Parameters are', $t->draw );
482 =item $c->prepare_action
490 my $path = $c->req->path;
491 my @path = split /\//, $c->req->path;
492 $c->req->args( \my @args );
495 $path = join '/', @path;
496 if ( my $result = ${ $c->get_action($path) }[0] ) {
500 my $match = $result->[1];
501 my @snippets = @{ $result->[2] };
503 qq/Requested action is "$path" and matched "$match"/)
506 'Snippets are "' . join( ' ', @snippets ) . '"' )
507 if ( $c->debug && @snippets );
508 $c->req->action($match);
509 $c->req->snippets( \@snippets );
513 $c->req->action($path);
514 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
517 $c->req->match($path);
520 unshift @args, pop @path;
523 unless ( $c->req->action ) {
524 $c->req->action('default');
528 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
529 if ( $c->debug && @args );
532 =item $c->prepare_body
534 Prepare message body.
540 =item $c->prepare_connection
546 sub prepare_connection { }
548 =item $c->prepare_cookies
554 sub prepare_cookies {
557 if ( my $header = $c->request->header('Cookie') ) {
558 $c->req->cookies( { CGI::Cookie->parse($header) } );
562 =item $c->prepare_headers
568 sub prepare_headers { }
570 =item $c->prepare_parameters
576 sub prepare_parameters { }
578 =item $c->prepare_path
580 Prepare path and base.
586 =item $c->prepare_request
588 Prepare the engine request.
592 sub prepare_request { }
594 =item $c->prepare_uploads
600 sub prepare_uploads { }
614 Returns a C<Catalyst::Request> object.
622 Returns a C<Catalyst::Response> object.
636 $self->setup_components;
637 if ( $self->debug ) {
638 my $name = $self->config->{name} || 'Application';
639 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
643 =item $class->setup_components
649 sub setup_components {
653 my $class = ref $self || $self;
656 import Module::Pluggable::Fast
657 name => '_components',
659 '$class\::Controller', '$class\::C',
660 '$class\::Model', '$class\::M',
661 '$class\::View', '$class\::V'
664 if ( my $error = $@ ) {
666 die qq/Couldn't load components "$error"/;
669 $self->components( {} );
671 for my $comp ( $self->_components($self) ) {
672 $self->components->{ ref $comp } = $comp;
676 my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
677 $t->setCols('Class');
678 $t->setColWidth( 'Class', 75, 1 );
679 $t->addRow($_) for keys %{ $self->components };
680 $self->log->debug( 'Loaded components', $t->draw )
681 if ( @{ $t->{tbl_rows} } && $self->debug );
683 $self->setup_actions( [ $self, @comps ] );
688 Contains the return value of the last executed action.
692 Returns a hashref containing all your data.
694 $c->stash->{foo} ||= 'yada';
695 print $c->stash->{foo};
702 my $stash = $_[1] ? {@_} : $_[0];
703 while ( my ( $key, $val ) = each %$stash ) {
704 $self->{stash}->{$key} = $val;
707 return $self->{stash};
714 Sebastian Riedel, C<sri@cpan.org>
718 This program is free software, you can redistribute it and/or modify it under
719 the same terms as Perl itself.