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/);
35 Catalyst::Engine - The Catalyst Engine
47 =item $c->benchmark($coderef)
49 Takes a coderef with arguments and returns elapsed time as float.
51 my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
52 $c->log->info( sprintf "Processing took %f seconds", $elapsed );
59 my $time = [gettimeofday];
60 my @return = &$code(@_);
61 my $elapsed = tv_interval $time;
62 return wantarray ? ( $elapsed, @return ) : $elapsed;
67 =item $c->component($name)
69 Get a component object by name.
71 $c->comp('MyApp::Model::MyModel')->do_stuff;
73 Regex search for a component.
75 $c->comp('mymodel')->do_stuff;
80 my ( $c, $name ) = @_;
82 if ( my $component = $c->components->{$name} ) {
87 for my $component ( keys %{ $c->components } ) {
88 return $c->components->{$component} if $component =~ /$name/i;
96 =item $c->error($error, ...)
98 =item $c->error($arrayref)
100 Returns an arrayref containing error messages.
102 my @error = @{ $c->error };
106 $c->error('Something bad happened');
112 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
113 push @{ $c->{error} }, @$error;
117 =item $c->execute($class, $coderef)
119 Execute a coderef in given class and catch exceptions.
120 Errors are available via $c->error.
125 my ( $c, $class, $code ) = @_;
126 $class = $c->comp($class) || $class;
128 my $callsub = ( caller(1) )[3];
133 my $action = $c->actions->{reverse}->{"$code"};
134 $action = "/$action" unless $action =~ /\-\>/;
135 $action = "-> $action" if $callsub =~ /forward$/;
136 my ( $elapsed, @state ) =
137 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
138 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
141 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
144 if ( my $error = $@ ) {
146 unless ( ref $error ) {
148 $error = qq/Caught exception "$error"/;
151 $c->log->error($error);
167 $c->finalize_cookies;
169 if ( my $location = $c->response->redirect ) {
170 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
171 $c->response->header( Location => $location );
172 $c->response->status(302) if $c->response->status !~ /^3\d\d$/;
175 if ( $#{ $c->error } >= 0 ) {
179 if ( !$c->response->output && $c->response->status !~ /^(1|3)\d\d$/ ) {
183 if ( $c->response->output && !$c->response->content_length ) {
184 use bytes; # play safe with a utf8 aware perl
185 $c->response->content_length( length $c->response->output );
188 my $status = $c->finalize_headers;
193 =item $c->finalize_cookies
199 sub finalize_cookies {
202 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
203 my $cookie = CGI::Cookie->new(
205 -value => $cookie->{value},
206 -expires => $cookie->{expires},
207 -domain => $cookie->{domain},
208 -path => $cookie->{path},
209 -secure => $cookie->{secure} || 0
212 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
216 =item $c->finalize_error
225 $c->res->headers->content_type('text/html');
226 my $name = $c->config->{name} || 'Catalyst Application';
228 my ( $title, $error, $infos );
230 $error = join '<br/>', @{ $c->error };
231 $error ||= 'No output';
232 $title = $name = "$name on Catalyst $Catalyst::VERSION";
233 my $req = encode_entities Dumper $c->req;
234 my $res = encode_entities Dumper $c->res;
235 my $stash = encode_entities Dumper $c->stash;
238 <b><u>Request</u></b><br/>
240 <b><u>Response</u></b><br/>
242 <b><u>Stash</u></b><br/>
251 (en) Please come back later
252 (de) Bitte versuchen sie es spaeter nocheinmal
253 (nl) Gelieve te komen later terug
254 (no) Vennligst prov igjen senere
255 (fr) Veuillez revenir plus tard
256 (es) Vuelto por favor mas adelante
257 (pt) Voltado por favor mais tarde
258 (it) Ritornato prego piĆ¹ successivamente
263 $c->res->output( <<"" );
266 <title>$title</title>
267 <style type="text/css">
269 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
270 Tahoma, Arial, helvetica, sans-serif;
272 background-color: #eee;
277 background-color: #ccc;
278 border: 1px solid #aaa;
281 -moz-border-radius: 10px;
284 background-color: #977;
285 border: 1px solid #755;
289 -moz-border-radius: 10px;
292 background-color: #797;
293 border: 1px solid #575;
297 -moz-border-radius: 10px;
300 background-color: #779;
301 border: 1px solid #557;
304 -moz-border-radius: 10px;
310 <div class="error">$error</div>
311 <div class="infos">$infos</div>
312 <div class="name">$name</div>
319 =item $c->finalize_headers
325 sub finalize_headers { }
327 =item $c->finalize_output
333 sub finalize_output { }
335 =item $c->handler( $class, $r )
342 my ( $class, $engine ) = @_;
344 # Always expect worst case!
350 my $c = $class->prepare($engine);
351 $c->{stats} = \@stats;
356 if ( $class->debug ) {
358 ( $elapsed, $status ) = $class->benchmark($handler);
359 $elapsed = sprintf '%f', $elapsed;
360 my $av = sprintf '%.3f', 1 / $elapsed;
361 my $t = Text::ASCIITable->new;
362 $t->setCols( 'Action', 'Time' );
363 $t->setColWidth( 'Action', 64, 1 );
364 $t->setColWidth( 'Time', 9, 1 );
366 for my $stat (@stats) { $t->addRow( $stat->[0], $stat->[1] ) }
367 $class->log->info( "Request took $elapsed" . "s ($av/s)",
370 else { $status = &$handler }
374 if ( my $error = $@ ) {
376 $class->log->error(qq/Caught exception in engine "$error"/);
383 =item $c->prepare($r)
385 Turns the engine-specific request( Apache, CGI ... )
386 into a Catalyst context .
391 my ( $class, $r ) = @_;
394 request => Catalyst::Request->new(
398 headers => HTTP::Headers->new,
404 response => Catalyst::Response->new(
405 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
412 my $secs = time - $START || 1;
413 my $av = sprintf '%.3f', $COUNT / $secs;
414 $c->log->debug('**********************************');
415 $c->log->debug("* Request $COUNT ($av/s) [$$]");
416 $c->log->debug('**********************************');
417 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
420 $c->prepare_request($r);
424 $c->prepare_connection;
426 my $method = $c->req->method || '';
427 my $path = $c->req->path || '';
428 my $hostname = $c->req->hostname || '';
429 my $address = $c->req->address || '';
430 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
434 $c->prepare_parameters;
436 if ( $c->debug && keys %{ $c->req->params } ) {
437 my $t = Text::ASCIITable->new;
438 $t->setCols( 'Key', 'Value' );
439 $t->setColWidth( 'Key', 37, 1 );
440 $t->setColWidth( 'Value', 36, 1 );
441 for my $key ( keys %{ $c->req->params } ) {
442 my $value = $c->req->params->{$key} || '';
443 $t->addRow( $key, $value );
445 $c->log->debug( 'Parameters are', $t->draw );
452 =item $c->prepare_action
460 my $path = $c->req->path;
461 my @path = split /\//, $c->req->path;
462 $c->req->args( \my @args );
465 $path = join '/', @path;
466 if ( my $result = ${ $c->get_action($path) }[0] ) {
470 my $match = $result->[1];
471 my @snippets = @{ $result->[2] };
473 qq/Requested action is "$path" and matched "$match"/)
476 'Snippets are "' . join( ' ', @snippets ) . '"' )
477 if ( $c->debug && @snippets );
478 $c->req->action($match);
479 $c->req->snippets( \@snippets );
483 $c->req->action($path);
484 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
487 $c->req->match($path);
490 unshift @args, pop @path;
493 unless ( $c->req->action ) {
494 $c->req->action('default');
498 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
499 if ( $c->debug && @args );
502 =item $c->prepare_connection
508 sub prepare_connection { }
510 =item $c->prepare_cookies
516 sub prepare_cookies {
519 if ( my $header = $c->request->header('Cookie') ) {
520 $c->req->cookies( { CGI::Cookie->parse($header) } );
524 =item $c->prepare_headers
530 sub prepare_headers { }
532 =item $c->prepare_parameters
538 sub prepare_parameters { }
540 =item $c->prepare_path
542 Prepare path and base.
548 =item $c->prepare_request
550 Prepare the engine request.
554 sub prepare_request { }
556 =item $c->prepare_uploads
562 sub prepare_uploads { }
576 Returns a C<Catalyst::Request> object.
584 Returns a C<Catalyst::Response> object.
598 $self->setup_components;
599 if ( $self->debug ) {
600 my $name = $self->config->{name} || 'Application';
601 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
605 =item $class->setup_components
611 sub setup_components {
615 my $class = ref $self || $self;
618 import Module::Pluggable::Fast
619 name => '_components',
621 '$class\::Controller', '$class\::C',
622 '$class\::Model', '$class\::M',
623 '$class\::View', '$class\::V'
626 if ( my $error = $@ ) {
628 die qq/Couldn't load components "$error"/;
631 $self->components( {} );
633 for my $comp ( $self->_components($self) ) {
634 $self->components->{ ref $comp } = $comp;
638 my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
639 $t->setCols('Class');
640 $t->setColWidth( 'Class', 75, 1 );
641 $t->addRow($_) for keys %{ $self->components };
642 $self->log->debug( 'Loaded components', $t->draw )
643 if ( @{ $t->{tbl_rows} } && $self->debug );
645 $self->setup_actions( [ $self, @comps ] );
650 Contains the return value of the last executed action.
654 Returns a hashref containing all your data.
656 $c->stash->{foo} ||= 'yada';
657 print $c->stash->{foo};
664 my $stash = $_[1] ? {@_} : $_[0];
665 while ( my ( $key, $val ) = each %$stash ) {
666 $self->{stash}->{$key} = $val;
669 return $self->{stash};
672 # Takes a coderef and returns an arrayref containing attributes
673 sub _get_attrs { attributes::get( $_[0] ) || [] }
679 Sebastian Riedel, C<sri@cpan.org>
683 This program is free software, you can redistribute it and/or modify it under
684 the same terms as Perl itself.