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_length && $c->response->status !~ /^(1|3)\d\d$/ ) {
186 if ( $c->response->body_length && !$c->response->content_length ) {
187 $c->response->content_length( $c->response->body_length );
190 my $status = $c->finalize_headers;
195 =item $c->finalize_output
197 alias to finalize_body
199 =item $c->finalize_body
205 sub finalize_body { }
207 =item $c->finalize_cookies
213 sub finalize_cookies {
216 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
217 my $cookie = CGI::Cookie->new(
219 -value => $cookie->{value},
220 -expires => $cookie->{expires},
221 -domain => $cookie->{domain},
222 -path => $cookie->{path},
223 -secure => $cookie->{secure} || 0
226 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
230 =item $c->finalize_error
239 $c->res->headers->content_type('text/html');
240 my $name = $c->config->{name} || 'Catalyst Application';
242 my ( $title, $error, $infos );
244 $error = join '<br/>', @{ $c->error };
245 $error ||= 'No output';
246 $title = $name = "$name on Catalyst $Catalyst::VERSION";
247 my $req = encode_entities Dumper $c->req;
248 my $res = encode_entities Dumper $c->res;
249 my $stash = encode_entities Dumper $c->stash;
252 <b><u>Request</u></b><br/>
254 <b><u>Response</u></b><br/>
256 <b><u>Stash</u></b><br/>
265 (en) Please come back later
266 (de) Bitte versuchen sie es spaeter nocheinmal
267 (nl) Gelieve te komen later terug
268 (no) Vennligst prov igjen senere
269 (fr) Veuillez revenir plus tard
270 (es) Vuelto por favor mas adelante
271 (pt) Voltado por favor mais tarde
272 (it) Ritornato prego piĆ¹ successivamente
277 $c->res->body( <<"" );
280 <title>$title</title>
281 <style type="text/css">
283 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
284 Tahoma, Arial, helvetica, sans-serif;
286 background-color: #eee;
291 background-color: #ccc;
292 border: 1px solid #aaa;
295 -moz-border-radius: 10px;
298 background-color: #977;
299 border: 1px solid #755;
303 -moz-border-radius: 10px;
306 background-color: #797;
307 border: 1px solid #575;
311 -moz-border-radius: 10px;
314 background-color: #779;
315 border: 1px solid #557;
318 -moz-border-radius: 10px;
324 <div class="error">$error</div>
325 <div class="infos">$infos</div>
326 <div class="name">$name</div>
333 =item $c->finalize_headers
339 sub finalize_headers { }
341 =item $c->handler( $class, $engine )
348 my ( $class, $engine ) = @_;
350 # Always expect worst case!
356 my $c = $class->prepare($engine);
357 $c->{stats} = \@stats;
362 if ( $class->debug ) {
364 ( $elapsed, $status ) = $class->benchmark($handler);
365 $elapsed = sprintf '%f', $elapsed;
366 my $av = sprintf '%.3f', ( $elapsed == 0 ? '??' : (1 / $elapsed) );
367 my $t = Text::ASCIITable->new;
368 $t->setCols( 'Action', 'Time' );
369 $t->setColWidth( 'Action', 64, 1 );
370 $t->setColWidth( 'Time', 9, 1 );
372 for my $stat (@stats) { $t->addRow( $stat->[0], $stat->[1] ) }
373 $class->log->info( "Request took $elapsed" . "s ($av/s)",
376 else { $status = &$handler }
380 if ( my $error = $@ ) {
382 $class->log->error(qq/Caught exception in engine "$error"/);
389 =item $c->prepare($engine)
391 Turns the engine-specific request( Apache, CGI ... )
392 into a Catalyst context .
397 my ( $class, $engine ) = @_;
400 request => Catalyst::Request->new(
405 headers => HTTP::Headers->new,
411 response => Catalyst::Response->new(
415 headers => HTTP::Headers->new,
424 my $secs = time - $START || 1;
425 my $av = sprintf '%.3f', $COUNT / $secs;
426 $c->log->debug('**********************************');
427 $c->log->debug("* Request $COUNT ($av/s) [$$]");
428 $c->log->debug('**********************************');
429 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
432 $c->prepare_request($engine);
433 $c->prepare_connection;
439 my $method = $c->req->method || '';
440 my $path = $c->req->path || '';
441 my $hostname = $c->req->hostname || '';
442 my $address = $c->req->address || '';
444 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
447 if ( $c->request->method eq 'POST' and $c->request->content_length ) {
449 if ( $c->req->content_type eq 'application/x-www-form-urlencoded' ) {
450 $c->prepare_parameters;
452 elsif ( $c->req->content_type eq 'multipart/form-data' ) {
453 $c->prepare_parameters;
461 if ( $c->request->method eq 'GET' ) {
462 $c->prepare_parameters;
465 if ( $c->debug && keys %{ $c->req->params } ) {
466 my $t = Text::ASCIITable->new;
467 $t->setCols( 'Key', 'Value' );
468 $t->setColWidth( 'Key', 37, 1 );
469 $t->setColWidth( 'Value', 36, 1 );
470 for my $key ( sort keys %{ $c->req->params } ) {
471 my $param = $c->req->params->{$key};
472 my $value = defined($param) ? $param : '';
473 $t->addRow( $key, $value );
475 $c->log->debug( 'Parameters are', $t->draw );
481 =item $c->prepare_action
489 my $path = $c->req->path;
490 my @path = split /\//, $c->req->path;
491 $c->req->args( \my @args );
494 $path = join '/', @path;
495 if ( my $result = ${ $c->get_action($path) }[0] ) {
499 my $match = $result->[1];
500 my @snippets = @{ $result->[2] };
502 qq/Requested action is "$path" and matched "$match"/)
505 'Snippets are "' . join( ' ', @snippets ) . '"' )
506 if ( $c->debug && @snippets );
507 $c->req->action($match);
508 $c->req->snippets( \@snippets );
512 $c->req->action($path);
513 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
516 $c->req->match($path);
519 unshift @args, pop @path;
522 unless ( $c->req->action ) {
523 $c->req->action('default');
527 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
528 if ( $c->debug && @args );
531 =item $c->prepare_body
533 Prepare message body.
539 =item $c->prepare_connection
545 sub prepare_connection { }
547 =item $c->prepare_cookies
553 sub prepare_cookies {
556 if ( my $header = $c->request->header('Cookie') ) {
557 $c->req->cookies( { CGI::Cookie->parse($header) } );
561 =item $c->prepare_headers
567 sub prepare_headers { }
569 =item $c->prepare_parameters
575 sub prepare_parameters { }
577 =item $c->prepare_path
579 Prepare path and base.
585 =item $c->prepare_request
587 Prepare the engine request.
591 sub prepare_request { }
593 =item $c->prepare_uploads
599 sub prepare_uploads { }
613 Returns a C<Catalyst::Request> object.
621 Returns a C<Catalyst::Response> object.
635 $self->setup_components;
636 if ( $self->debug ) {
637 my $name = $self->config->{name} || 'Application';
638 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
642 =item $class->setup_components
648 sub setup_components {
652 my $class = ref $self || $self;
655 import Module::Pluggable::Fast
656 name => '_components',
658 '$class\::Controller', '$class\::C',
659 '$class\::Model', '$class\::M',
660 '$class\::View', '$class\::V'
663 if ( my $error = $@ ) {
665 die qq/Couldn't load components "$error"/;
668 $self->components( {} );
670 for my $comp ( $self->_components($self) ) {
671 $self->components->{ ref $comp } = $comp;
675 my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
676 $t->setCols('Class');
677 $t->setColWidth( 'Class', 75, 1 );
678 $t->addRow($_) for keys %{ $self->components };
679 $self->log->debug( 'Loaded components', $t->draw )
680 if ( @{ $t->{tbl_rows} } && $self->debug );
682 $self->setup_actions( [ $self, @comps ] );
687 Contains the return value of the last executed action.
691 Returns a hashref containing all your data.
693 $c->stash->{foo} ||= 'yada';
694 print $c->stash->{foo};
701 my $stash = $_[1] ? {@_} : $_[0];
702 while ( my ( $key, $val ) = each %$stash ) {
703 $self->{stash}->{$key} = $val;
706 return $self->{stash};
713 Sebastian Riedel, C<sri@cpan.org>
717 This program is free software, you can redistribute it and/or modify it under
718 the same terms as Perl itself.