1 package Catalyst::Engine;
5 qw/Class::Data::Inheritable Class::Accessor::Fast Catalyst::Dispatcher/;
6 use UNIVERSAL::require;
11 use Time::HiRes qw/gettimeofday tv_interval/;
13 use Text::ASCIITable::Wrap 'wrap';
14 use Catalyst::Request;
15 use Catalyst::Request::Upload;
16 use Catalyst::Response;
18 require Module::Pluggable::Fast;
20 $Data::Dumper::Terse = 1;
22 __PACKAGE__->mk_classdata('components');
23 __PACKAGE__->mk_accessors(qw/request response state/);
34 Catalyst::Engine - The Catalyst Engine
46 =item $c->benchmark($coderef)
48 Takes a coderef with arguments and returns elapsed time as float.
50 my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
51 $c->log->info( sprintf "Processing took %f seconds", $elapsed );
58 my $time = [gettimeofday];
59 my @return = &$code(@_);
60 my $elapsed = tv_interval $time;
61 return wantarray ? ( $elapsed, @return ) : $elapsed;
66 =item $c->component($name)
68 Get a component object by name.
70 $c->comp('MyApp::Model::MyModel')->do_stuff;
72 Regex search for a component.
74 $c->comp('mymodel')->do_stuff;
79 my ( $c, $name ) = @_;
80 if ( my $component = $c->components->{$name} ) {
84 for my $component ( keys %{ $c->components } ) {
85 return $c->components->{$component} if $component =~ /$name/i;
92 =item $c->error($error, ...)
94 =item $c->error($arrayref)
96 Returns an arrayref containing error messages.
98 my @error = @{ $c->error };
102 $c->error('Something bad happened');
108 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
109 push @{ $c->{error} }, @$error;
113 =item $c->execute($class, $coderef)
115 Execute a coderef in given class and catch exceptions.
116 Errors are available via $c->error.
121 my ( $c, $class, $code ) = @_;
122 $class = $c->comp($class) || $class;
124 my $callsub = ( caller(1) )[3];
128 my $action = $c->actions->{reverse}->{"$code"};
129 $action = "/$action" unless $action =~ /\-\>/;
130 $action = "-> $action" if $callsub =~ /forward$/;
131 my ( $elapsed, @state ) =
132 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
133 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
136 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
138 if ( my $error = $@ ) {
140 unless ( ref $error ) {
142 $error = qq/Caught exception "$error"/;
145 $c->log->error($error);
161 $c->finalize_cookies;
163 if ( my $location = $c->response->redirect ) {
164 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
165 $c->response->header( Location => $location );
166 $c->response->status(302) if $c->response->status !~ /^3\d\d$/;
169 if ( $#{ $c->error } >= 0 ) {
173 if ( !$c->response->output && $c->response->status !~ /^(1|3)\d\d$/ ) {
177 if ( $c->response->output && !$c->response->content_length ) {
178 use bytes; # play safe with a utf8 aware perl
179 $c->response->content_length( length $c->response->output );
182 my $status = $c->finalize_headers;
187 =item $c->finalize_cookies
193 sub finalize_cookies {
196 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
197 my $cookie = CGI::Cookie->new(
199 -value => $cookie->{value},
200 -expires => $cookie->{expires},
201 -domain => $cookie->{domain},
202 -path => $cookie->{path},
203 -secure => $cookie->{secure} || 0
206 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
210 =item $c->finalize_error
219 $c->res->headers->content_type('text/html');
220 my $name = $c->config->{name} || 'Catalyst Application';
222 my ( $title, $error, $infos );
224 $error = join '<br/>', @{ $c->error };
225 $error ||= 'No output';
226 $title = $name = "$name on Catalyst $Catalyst::VERSION";
227 my $req = encode_entities Dumper $c->req;
228 my $res = encode_entities Dumper $c->res;
229 my $stash = encode_entities Dumper $c->stash;
232 <b><u>Request</u></b><br/>
234 <b><u>Response</u></b><br/>
236 <b><u>Stash</u></b><br/>
245 (en) Please come back later
246 (de) Bitte versuchen sie es spaeter nocheinmal
247 (nl) Gelieve te komen later terug
248 (no) Vennligst prov igjen senere
249 (fr) Veuillez revenir plus tard
250 (es) Vuelto por favor mas adelante
251 (pt) Voltado por favor mais tarde
252 (it) Ritornato prego piĆ¹ successivamente
257 $c->res->output( <<"" );
260 <title>$title</title>
261 <style type="text/css">
263 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
264 Tahoma, Arial, helvetica, sans-serif;
266 background-color: #eee;
271 background-color: #ccc;
272 border: 1px solid #aaa;
275 -moz-border-radius: 10px;
278 background-color: #977;
279 border: 1px solid #755;
283 -moz-border-radius: 10px;
286 background-color: #797;
287 border: 1px solid #575;
291 -moz-border-radius: 10px;
294 background-color: #779;
295 border: 1px solid #557;
298 -moz-border-radius: 10px;
304 <div class="error">$error</div>
305 <div class="infos">$infos</div>
306 <div class="name">$name</div>
313 =item $c->finalize_headers
319 sub finalize_headers { }
321 =item $c->finalize_output
327 sub finalize_output { }
329 =item $c->handler( $class, $r )
336 my ( $class, $engine ) = @_;
338 # Always expect worst case!
343 my $c = $class->prepare($engine);
344 $c->{stats} = \@stats;
348 if ( $class->debug ) {
350 ( $elapsed, $status ) = $class->benchmark($handler);
351 $elapsed = sprintf '%f', $elapsed;
352 my $av = sprintf '%.3f', 1 / $elapsed;
353 my $t = Text::ASCIITable->new;
354 $t->setCols( 'Action', 'Time' );
355 $t->setColWidth( 'Action', 64, 1 );
356 $t->setColWidth( 'Time', 9, 1 );
358 for my $stat (@stats) {
359 $t->addRow( wrap( $stat->[0], 64 ), wrap( $stat->[1], 9 ) );
361 $class->log->info( "Request took $elapsed" . "s ($av/s)",
364 else { $status = &$handler }
366 if ( my $error = $@ ) {
368 $class->log->error(qq/Caught exception in engine "$error"/);
374 =item $c->prepare($r)
376 Turns the engine-specific request( Apache, CGI ... )
377 into a Catalyst context .
382 my ( $class, $r ) = @_;
384 request => Catalyst::Request->new(
388 headers => HTTP::Headers->new,
394 response => Catalyst::Response->new(
395 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
401 my $secs = time - $START || 1;
402 my $av = sprintf '%.3f', $COUNT / $secs;
403 $c->log->debug('**********************************');
404 $c->log->debug("* Request $COUNT ($av/s) [$$]");
405 $c->log->debug('**********************************');
406 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
408 $c->prepare_request($r);
412 $c->prepare_connection;
413 my $method = $c->req->method || '';
414 my $path = $c->req->path || '';
415 my $hostname = $c->req->hostname || '';
416 my $address = $c->req->address || '';
417 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
420 $c->prepare_parameters;
422 if ( $c->debug && keys %{ $c->req->params } ) {
423 my $t = Text::ASCIITable->new;
424 $t->setCols( 'Key', 'Value' );
425 $t->setColWidth( 'Key', 37, 1 );
426 $t->setColWidth( 'Value', 36, 1 );
427 for my $key ( keys %{ $c->req->params } ) {
428 my $value = $c->req->params->{$key} || '';
429 $t->addRow( wrap( $key, 37 ), wrap( $value, 36 ) );
431 $c->log->debug( 'Parameters are', $t->draw );
437 =item $c->prepare_action
445 my $path = $c->req->path;
446 my @path = split /\//, $c->req->path;
447 $c->req->args( \my @args );
449 $path = join '/', @path;
450 if ( my $result = ${ $c->get_action($path) }[0] ) {
454 my $match = $result->[1];
455 my @snippets = @{ $result->[2] };
457 qq/Requested action is "$path" and matched "$match"/)
460 'Snippets are "' . join( ' ', @snippets ) . '"' )
461 if ( $c->debug && @snippets );
462 $c->req->action($match);
463 $c->req->snippets( \@snippets );
466 $c->req->action($path);
467 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
469 $c->req->match($path);
472 unshift @args, pop @path;
474 unless ( $c->req->action ) {
475 $c->req->action('default');
478 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
479 if ( $c->debug && @args );
482 =item $c->prepare_connection
488 sub prepare_connection { }
490 =item $c->prepare_cookies
496 sub prepare_cookies {
499 if ( my $header = $c->request->header('Cookie') ) {
500 $c->req->cookies( { CGI::Cookie->parse($header) } );
504 =item $c->prepare_headers
510 sub prepare_headers { }
512 =item $c->prepare_parameters
518 sub prepare_parameters { }
520 =item $c->prepare_path
522 Prepare path and base.
528 =item $c->prepare_request
530 Prepare the engine request.
534 sub prepare_request { }
536 =item $c->prepare_uploads
542 sub prepare_uploads { }
556 Returns a C<Catalyst::Request> object.
564 Returns a C<Catalyst::Response> object.
578 $self->setup_components;
579 if ( $self->debug ) {
580 my $name = $self->config->{name} || 'Application';
581 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
585 =item $class->setup_components
591 sub setup_components {
595 my $class = ref $self || $self;
598 import Module::Pluggable::Fast
599 name => '_components',
601 '$class\::Controller', '$class\::C',
602 '$class\::Model', '$class\::M',
603 '$class\::View', '$class\::V'
606 if ( my $error = $@ ) {
609 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
611 $self->components( {} );
613 for my $comp ( $self->_components($self) ) {
614 $self->components->{ ref $comp } = $comp;
617 $self->setup_actions( [ $self, @comps ] );
622 Contains the return value of the last executed action.
626 Returns a hashref containing all your data.
628 $c->stash->{foo} ||= 'yada';
629 print $c->stash->{foo};
636 my $stash = $_[1] ? {@_} : $_[0];
637 while ( my ( $key, $val ) = each %$stash ) {
638 $self->{stash}->{$key} = $val;
641 return $self->{stash};
648 Sebastian Riedel, C<sri@cpan.org>
652 This program is free software, you can redistribute it and/or modify it under
653 the same terms as Perl itself.