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->error($error, ...)
125 =item $c->error($arrayref)
127 Returns an arrayref containing error messages.
129 my @error = @{ $c->error };
133 $c->error('Something bad happened');
139 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
140 push @{ $c->{error} }, @$error;
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->error } >= 0 ) {
160 $c->res->headers->content_type('text/html');
161 my $name = $c->config->{name} || 'Catalyst Application';
162 my ( $title, $error, $infos );
164 $error = join '<br/>', @{ $c->error };
165 $error ||= '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="error">$error</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 unless ( $command =~ /^\!/ ) {
305 $results = [ pop @{$results} ];
306 if ( $results->[0]->[2] ) {
307 $c->log->debug(qq/Couldn't forward "$command" to regex action/)
314 my $class = $command;
315 if ( $class =~ /[^\w\:]/ ) {
316 $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
319 my $method = shift || 'process';
320 if ( my $code = $class->can($method) ) {
321 $c->actions->{reverse}->{"$code"} = "$class->$method";
322 $results = [ [ [ $class, $code ] ] ];
325 $c->log->debug(qq/Couldn't forward to "$class->$method"/)
330 for my $result ( @{$results} ) {
331 $c->state( $c->process( @{ $result->[0] } ) );
336 =item $c->get_action( $action, $namespace )
338 Get an action in a given namespace.
343 my ( $c, $action, $namespace ) = @_;
345 if ( $action =~ /^\!(.*)/ ) {
347 my $parent = $c->tree;
349 my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
350 push @results, [$result] if $result;
351 my $visitor = Tree::Simple::Visitor::FindByPath->new;
353 for my $part ( split '/', $namespace ) {
355 $visitor->setSearchPath($part);
356 $parent->accept($visitor);
357 my $child = $visitor->getResult;
358 my $uid = $child->getUID if $child;
359 my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
360 return [ [$match] ] if ( $match && $match =~ /^?.*/ );
361 $local = $c->actions->{private}->{$uid}->{"?$action"} if $uid;
362 push @results, [$match] if $match;
363 $parent = $child if $child;
365 return [ [$local] ] if $local;
368 elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
369 elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
371 for my $regex ( keys %{ $c->actions->{compiled} } ) {
372 my $name = $c->actions->{compiled}->{$regex};
373 if ( $action =~ $regex ) {
375 for my $i ( 1 .. 9 ) {
378 push @snippets, ${$i};
380 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
387 =item $c->handler( $class, $r )
394 my ( $class, $r ) = @_;
396 # Always expect worst case!
400 my $c = $class->prepare($r);
401 my $action = $c->req->action;
403 $namespace = join '/', @{ $c->req->args } if $action eq '!default';
404 unless ($namespace) {
405 if ( my $result = $c->get_action($action) ) {
406 $namespace = _class2prefix( $result->[0]->[0]->[0] );
409 my $results = $c->get_action( $action, $namespace );
411 for my $begin ( @{ $c->get_action( '!begin', $namespace ) } ) {
412 $c->state( $c->process( @{ $begin->[0] } ) );
414 for my $result ( @{ $c->get_action( $action, $namespace ) } ) {
415 $c->state( $c->process( @{ $result->[0] } ) );
416 last unless $action =~ /^\!.*/;
418 for my $end ( @{ $c->get_action( '!end', $namespace ) } ) {
419 $c->state( $c->process( @{ $end->[0] } ) );
423 my $path = $c->req->path;
425 ? qq/Unknown resource "$path"/
426 : "No default action defined";
427 $c->log->error($error) if $c->debug;
432 if ( $class->debug ) {
434 ( $elapsed, $status ) = $class->benchmark($handler);
435 $elapsed = sprintf '%f', $elapsed;
436 my $av = sprintf '%.3f', 1 / $elapsed;
437 $class->log->info( "Request took $elapsed" . "s ($av/s)" );
439 else { $status = &$handler }
441 if ( my $error = $@ ) {
443 $class->log->error(qq/Caught exception in engine "$error"/);
449 =item $c->prepare($r)
451 Turns the engine-specific request( Apache, CGI ... )
452 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->error.
617 my ( $c, $class, $code ) = @_;
618 $class = $c->comp($class) || $class;
623 my $action = $c->actions->{reverse}->{"$code"} || "$code";
624 my ( $elapsed, @state ) =
625 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
626 $c->log->info( sprintf qq/Processing "$action" took %fs/, $elapsed )
630 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
632 if ( my $error = $@ ) {
634 $error = qq/Caught exception "$error"/;
635 $c->log->error($error);
636 $c->error($error) if $c->debug;
654 Returns a C<Catalyst::Request> object.
662 Returns a C<Catalyst::Response> object.
666 =item $c->set_action( $action, $code, $namespace )
668 Set an action in a given namespace.
673 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 elsif ( $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";
707 else { $c->actions->{plain}->{$action} = [ $namespace, $code ] }
708 my $reverse = $prefix ? "$action ($prefix)" : $action;
709 $c->actions->{reverse}->{"$code"} = $reverse;
710 $c->log->debug(qq/"$namespace" defined "$action" as "$code"/)
724 $self->setup_components;
725 if ( $self->debug ) {
726 my $name = $self->config->{name} || 'Application';
727 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
731 =item $class->setup_components
737 sub setup_components {
741 my $class = ref $self || $self;
744 import Module::Pluggable::Fast
745 name => '_components',
747 '$class\::Controller', '$class\::C',
748 '$class\::Model', '$class\::M',
749 '$class\::View', '$class\::V'
752 if ( my $error = $@ ) {
755 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
757 $self->components( {} );
758 for my $component ( $self->_components($self) ) {
759 $self->components->{ ref $component } = $component;
761 $self->log->debug( 'Initialized components "'
762 . join( ' ', keys %{ $self->components } )
769 Returns a hashref containing all your data.
771 $c->stash->{foo} ||= 'yada';
772 print $c->stash->{foo};
779 my $stash = $_[1] ? {@_} : $_[0];
780 while ( my ( $key, $val ) = each %$stash ) {
781 $self->{stash}->{$key} = $val;
784 return $self->{stash};
788 my ( $class, $name ) = @_;
789 my $prefix = _class2prefix($class);
790 warn "$class - $name - $prefix";
791 $name = "$prefix/$name" if $prefix;
796 my $class = shift || '';
797 $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/;
798 my $prefix = lc $2 || '';
799 $prefix =~ s/\:\:/\//g;
807 Sebastian Riedel, C<sri@cpan.org>
811 This program is free software, you can redistribute it and/or modify it under
812 the same terms as Perl itself.