1 package Catalyst::Engine;
4 use base qw/Class::Data::Inheritable Class::Accessor::Fast/;
5 use UNIVERSAL::require;
10 use Time::HiRes qw/gettimeofday tv_interval/;
12 use Tree::Simple::Visitor::FindByPath;
13 use Catalyst::Request;
14 use Catalyst::Response;
16 require Module::Pluggable::Fast;
18 $Data::Dumper::Terse = 1;
20 __PACKAGE__->mk_classdata($_) for qw/actions components tree/;
21 __PACKAGE__->mk_accessors(qw/request response state/);
24 { plain => {}, private => {}, regex => {}, compiled => {}, reverse => {} }
26 __PACKAGE__->tree( Tree::Simple->new( 0, Tree::Simple->ROOT ) );
35 memoize('_class2prefix');
39 Catalyst::Engine - The Catalyst Engine
51 =item $c->action( $name => $coderef, ... )
53 Add one or more actions.
55 $c->action( '!foo' => sub { $_[1]->res->output('Foo!') } );
57 It also automatically calls setup() if needed.
59 See L<Catalyst::Manual::Intro> for more informations about actions.
65 $self->setup unless $self->components;
66 $self->actions( {} ) unless $self->actions;
68 $_[1] ? ( $action = {@_} ) : ( $action = shift );
69 if ( ref $action eq 'HASH' ) {
70 while ( my ( $name, $code ) = each %$action ) {
71 $self->set_action( $name, $code, caller(0) );
77 =item $c->benchmark($coderef)
79 Takes a coderef with arguments and returns elapsed time as float.
81 my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
82 $c->log->info( sprintf "Processing took %f seconds", $elapsed );
89 my $time = [gettimeofday];
90 my @return = &$code(@_);
91 my $elapsed = tv_interval $time;
92 return wantarray ? ( $elapsed, @return ) : $elapsed;
97 =item $c->component($name)
99 Get a component object by name.
101 $c->comp('MyApp::Model::MyModel')->do_stuff;
103 Regex search for a component.
105 $c->comp('mymodel')->do_stuff;
110 my ( $c, $name ) = @_;
111 if ( my $component = $c->components->{$name} ) {
115 for my $component ( keys %{ $c->components } ) {
116 return $c->components->{$component} if $component =~ /$name/i;
123 =item $c->errors($error, ...)
125 =item $c->errors($arrayref)
127 Returns an arrayref containing errors messages.
129 my @errors = @{ $c->errors };
133 $c->errors('Something bad happened');
139 my $errors = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
140 push @{ $c->{errors} }, @$errors;
153 if ( my $location = $c->res->redirect ) {
154 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
155 $c->res->headers->header( Location => $location );
156 $c->res->status(302);
159 if ( !$c->res->output || $#{ $c->errors } >= 0 ) {
160 $c->res->headers->content_type('text/html');
161 my $name = $c->config->{name} || 'Catalyst Application';
162 my ( $title, $errors, $infos );
164 $errors = join '<br/>', @{ $c->errors };
165 $errors ||= 'No output';
166 $title = $name = "$name on Catalyst $Catalyst::VERSION";
167 my $req = encode_entities Dumper $c->req;
168 my $res = encode_entities Dumper $c->res;
169 my $stash = encode_entities Dumper $c->stash;
172 <b><u>Request</u></b><br/>
174 <b><u>Response</u></b><br/>
176 <b><u>Stash</u></b><br/>
185 (en) Please come back later
186 (de) Bitte versuchen sie es spaeter nocheinmal
187 (nl) Gelieve te komen later terug
188 (no) Vennligst prov igjen senere
189 (fr) Veuillez revenir plus tard
190 (es) Vuelto por favor mas adelante
191 (pt) Voltado por favor mais tarde
192 (it) Ritornato prego piĆ¹ successivamente
197 $c->res->{output} = <<"";
200 <title>$title</title>
201 <style type="text/css">
203 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
204 Tahoma, Arial, helvetica, sans-serif;
206 background-color: #eee;
211 background-color: #ccc;
212 border: 1px solid #aaa;
215 -moz-border-radius: 10px;
218 background-color: #977;
219 border: 1px solid #755;
223 -moz-border-radius: 10px;
226 background-color: #797;
227 border: 1px solid #575;
231 -moz-border-radius: 10px;
234 background-color: #779;
235 border: 1px solid #557;
238 -moz-border-radius: 10px;
244 <div class="errors">$errors</div>
245 <div class="infos">$infos</div>
246 <div class="name">$name</div>
252 $c->res->headers->content_length( length $c->res->output );
253 my $status = $c->finalize_headers;
258 =item $c->finalize_headers
264 sub finalize_headers { }
266 =item $c->finalize_output
272 sub finalize_output { }
274 =item $c->forward($command)
276 Forward processing to a private/public action or a method from a class.
277 If you define a class without method it will default to process().
280 $c->forward('index.html');
281 $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
282 $c->forward('MyApp::View::TT');
290 $c->log->debug('Nothing to forward to') if $c->debug;
293 my $caller = caller(0);
294 if ( $command =~ /^\?(.*)$/ ) {
296 $command = _prefix( $caller, $command );
299 if ( $command =~ /^\!/ ) {
300 $namespace = _class2prefix($caller);
302 my $results = $c->get_action( $command, $namespace );
304 if ( $command =~ /^\!/ ) {
305 for my $result ( @{$results} ) {
306 my ( $class, $code ) = @{ $result->[0] };
307 $c->state( $c->process( $class, $code ) );
311 return 0 unless my $result = $results->[0];
312 if ( $result->[2] ) {
313 $c->log->debug(qq/Couldn't forward "$command" to regex action/)
317 my ( $class, $code ) = @{ $result->[0] };
318 $class = $c->components->{$class} || $class;
319 $c->state( $c->process( $class, $code ) );
323 my $class = $command;
324 if ( $class =~ /[^\w\:]/ ) {
325 $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
328 my $method = shift || 'process';
329 if ( my $code = $class->can($method) ) {
330 $c->actions->{reverse}->{"$code"} = "$class->$method";
331 $class = $c->comp($class) || $class;
332 $c->state( $c->process( $class, $code ) );
335 $c->log->debug(qq/Couldn't forward to "$class->$method"/)
343 =item $c->get_action( $action, $namespace )
345 Get an action in a given namespace.
350 my ( $c, $action, $namespace ) = @_;
352 if ( $action =~ /^\!(.*)/ ) {
354 my $parent = $c->tree;
356 my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
357 push @results, [$result] if $result;
358 my $visitor = Tree::Simple::Visitor::FindByPath->new;
359 for my $part ( split '/', $namespace ) {
360 $visitor->setSearchPath($part);
361 $parent->accept($visitor);
362 my $child = $visitor->getResult;
363 my $uid = $child->getUID if $child;
364 my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
365 push @results, [$match] if $match;
366 $parent = $child if $child;
370 elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
371 elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
373 for my $regex ( keys %{ $c->actions->{compiled} } ) {
374 my $name = $c->actions->{compiled}->{$regex};
375 if ( $action =~ $regex ) {
377 for my $i ( 1 .. 9 ) {
380 push @snippets, ${$i};
382 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
389 =item $c->handler( $class, $r )
396 my ( $class, $r ) = @_;
398 # Always expect worst case!
402 my $c = $class->prepare($r);
403 my $action = $c->req->action;
405 $namespace = join '/', @{ $c->req->args } if $action eq '!default';
406 unless ($namespace) {
407 if ( my $result = $c->get_action($action) ) {
408 $namespace = _class2prefix( $result->[0]->[0]->[0] );
411 my $results = $c->get_action( $action, $namespace );
413 for my $begin ( @{ $c->get_action( '!begin', $namespace ) } ) {
414 $c->state( $c->process( @{ $begin->[0] } ) );
416 for my $result ( @{ $c->get_action( $action, $namespace ) } ) {
417 $c->state( $c->process( @{ $result->[0] } ) );
419 for my $end ( @{ $c->get_action( '!end', $namespace ) } ) {
420 $c->state( $c->process( @{ $end->[0] } ) );
424 my $path = $c->req->path;
426 ? qq/Unknown resource "$path"/
427 : "No default action defined";
428 $c->log->error($error) if $c->debug;
433 if ( $class->debug ) {
435 ( $elapsed, $status ) = $class->benchmark($handler);
436 $elapsed = sprintf '%f', $elapsed;
437 my $av = sprintf '%.3f', 1 / $elapsed;
438 $class->log->info( "Request took $elapsed" . "s ($av/s)" );
440 else { $status = &$handler }
442 if ( my $error = $@ ) {
444 $class->log->error(qq/Caught exception in engine "$error"/);
450 =item $c->prepare($r)
452 Turns the engine-specific request (Apache, CGI...) into a Catalyst context.
457 my ( $class, $r ) = @_;
459 request => Catalyst::Request->new(
463 headers => HTTP::Headers->new,
469 response => Catalyst::Response->new(
470 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
476 my $secs = time - $START || 1;
477 my $av = sprintf '%.3f', $COUNT / $secs;
478 $c->log->debug('********************************');
479 $c->log->debug("* Request $COUNT ($av/s) [$$]");
480 $c->log->debug('********************************');
481 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
483 $c->prepare_request($r);
487 $c->prepare_connection;
488 my $method = $c->req->method || '';
489 my $path = $c->req->path || '';
490 my $hostname = $c->req->hostname || '';
491 my $address = $c->req->address || '';
492 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
495 $c->prepare_parameters;
497 if ( $c->debug && keys %{ $c->req->params } ) {
499 for my $key ( keys %{ $c->req->params } ) {
500 my $value = $c->req->params->{$key} || '';
501 push @params, "$key=$value";
503 $c->log->debug( 'Parameters are "' . join( ' ', @params ) . '"' );
509 =item $c->prepare_action
517 my $path = $c->req->path;
518 my @path = split /\//, $c->req->path;
519 $c->req->args( \my @args );
521 $path = join '/', @path;
522 if ( my $result = ${ $c->get_action($path) }[0] ) {
526 my $match = $result->[1];
527 my @snippets = @{ $result->[2] };
528 $c->log->debug(qq/Requested action "$path" matched "$match"/)
531 'Snippets are "' . join( ' ', @snippets ) . '"' )
532 if ( $c->debug && @snippets );
533 $c->req->action($match);
534 $c->req->snippets( \@snippets );
537 $c->req->action($path);
538 $c->log->debug(qq/Requested action "$path"/) if $c->debug;
540 $c->req->match($path);
543 unshift @args, pop @path;
545 unless ( $c->req->action ) {
546 $c->req->action('!default');
549 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
550 if ( $c->debug && @args );
553 =item $c->prepare_connection
559 sub prepare_connection { }
561 =item $c->prepare_cookies
567 sub prepare_cookies { }
569 =item $c->prepare_headers
575 sub prepare_headers { }
577 =item $c->prepare_parameters
583 sub prepare_parameters { }
585 =item $c->prepare_path
587 Prepare path and base.
593 =item $c->prepare_request
595 Prepare the engine request.
599 sub prepare_request { }
601 =item $c->prepare_uploads
607 sub prepare_uploads { }
609 =item $c->process($class, $coderef)
611 Process a coderef in given class and catch exceptions.
612 Errors are available via $c->errors.
617 my ( $c, $class, $code ) = @_;
622 my $action = $c->actions->{reverse}->{"$code"} || "$code";
624 ( $elapsed, $status ) =
625 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
626 $c->log->info( sprintf qq/Processing "$action" took %fs/, $elapsed )
629 else { $status = &$code( $class, $c, @{ $c->req->args } ) }
631 if ( my $error = $@ ) {
633 $error = qq/Caught exception "$error"/;
634 $c->log->error($error);
635 $c->errors($error) if $c->debug;
653 Returns a C<Catalyst::Request> object.
661 Returns a C<Catalyst::Response> object.
665 =item $c->set_action( $action, $code, $namespace )
667 Set an action in a given namespace.
672 my ( $c, $action, $code, $namespace ) = @_;
675 if ( $action =~ /^\?(.*)$/ ) {
676 my $prefix = $1 || '';
678 $action = $prefix . _prefix( $namespace, $action );
679 $c->actions->{plain}->{$action} = [ $namespace, $code ];
681 if ( $action =~ /^\/(.*)\/$/ ) {
683 $c->actions->{compiled}->{qr#$regex#} = $action;
684 $c->actions->{regex}->{$action} = [ $namespace, $code ];
686 elsif ( $action =~ /^\!(.*)$/ ) {
688 my $parent = $c->tree;
689 my $visitor = Tree::Simple::Visitor::FindByPath->new;
690 $prefix = _class2prefix($namespace);
691 for my $part ( split '/', $prefix ) {
692 $visitor->setSearchPath($part);
693 $parent->accept($visitor);
694 my $child = $visitor->getResult;
696 $child = $parent->addChild( Tree::Simple->new($part) );
697 $visitor->setSearchPath($part);
698 $parent->accept($visitor);
699 $child = $visitor->getResult;
703 my $uid = $parent->getUID;
704 $c->actions->{private}->{$uid}->{$action} = [ $namespace, $code ];
705 $action = "!$action";
708 $c->actions->{plain}->{$action} = [ $namespace, $code ];
711 my $reverse = $prefix ? "$action ($prefix)" : $action;
712 $c->actions->{reverse}->{"$code"} = $reverse;
714 $c->log->debug(qq/"$namespace" defined "$action" as "$code"/)
728 $self->setup_components;
729 if ( $self->debug ) {
730 my $name = $self->config->{name} || 'Application';
731 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
735 =item $class->setup_components
741 sub setup_components {
745 my $class = ref $self || $self;
748 import Module::Pluggable::Fast
749 name => '_components',
751 '$class\::Controller', '$class\::C',
752 '$class\::Model', '$class\::M',
753 '$class\::View', '$class\::V'
756 if ( my $error = $@ ) {
759 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
761 $self->components( {} );
762 for my $component ( $self->_components($self) ) {
763 $self->components->{ ref $component } = $component;
765 $self->log->debug( 'Initialized components "'
766 . join( ' ', keys %{ $self->components } )
773 Returns a hashref containing all your data.
775 $c->stash->{foo} ||= 'yada';
776 print $c->stash->{foo};
783 my $stash = $_[1] ? {@_} : $_[0];
784 while ( my ( $key, $val ) = each %$stash ) {
785 $self->{stash}->{$key} = $val;
788 return $self->{stash};
792 my ( $class, $name ) = @_;
793 my $prefix = _class2prefix($class);
794 $name = "$prefix/$name" if $prefix;
799 my $class = shift || '';
800 $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/;
801 my $prefix = lc $2 || '';
802 $prefix =~ s/\:\:/\//g;
810 Sebastian Riedel, C<sri@cpan.org>
814 This program is free software, you can redistribute it and/or modify it under
815 the same terms as Perl itself.