1 package Catalyst::Engine;
4 use base qw/Class::Data::Inheritable Class::Accessor::Fast/;
5 use UNIVERSAL::require;
11 use Time::HiRes qw/gettimeofday tv_interval/;
13 use Tree::Simple::Visitor::FindByPath;
14 use Catalyst::Request;
15 use Catalyst::Response;
17 require Module::Pluggable::Fast;
19 $Data::Dumper::Terse = 1;
21 __PACKAGE__->mk_classdata($_) for qw/actions components tree/;
22 __PACKAGE__->mk_accessors(qw/request response state/);
25 { plain => {}, private => {}, regex => {}, compiled => [], reverse => {} }
27 __PACKAGE__->tree( Tree::Simple->new( 0, Tree::Simple->ROOT ) );
36 memoize('_class2prefix');
40 Catalyst::Engine - The Catalyst Engine
52 =item $c->benchmark($coderef)
54 Takes a coderef with arguments and returns elapsed time as float.
56 my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
57 $c->log->info( sprintf "Processing took %f seconds", $elapsed );
64 my $time = [gettimeofday];
65 my @return = &$code(@_);
66 my $elapsed = tv_interval $time;
67 return wantarray ? ( $elapsed, @return ) : $elapsed;
72 =item $c->component($name)
74 Get a component object by name.
76 $c->comp('MyApp::Model::MyModel')->do_stuff;
78 Regex search for a component.
80 $c->comp('mymodel')->do_stuff;
85 my ( $c, $name ) = @_;
86 if ( my $component = $c->components->{$name} ) {
90 for my $component ( keys %{ $c->components } ) {
91 return $c->components->{$component} if $component =~ /$name/i;
98 =item $c->error($error, ...)
100 =item $c->error($arrayref)
102 Returns an arrayref containing error messages.
104 my @error = @{ $c->error };
108 $c->error('Something bad happened');
114 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
115 push @{ $c->{error} }, @$error;
119 =item $c->execute($class, $coderef)
121 Execute a coderef in given class and catch exceptions.
122 Errors are available via $c->error.
127 my ( $c, $class, $code ) = @_;
128 $class = $c->comp($class) || $class;
130 my $callsub = ( caller(1) )[3];
134 my $action = $c->actions->{reverse}->{"$code"};
135 $action = "/$action" unless $action =~ /\-\>/;
136 $action = " $action" if $callsub =~ /forward$/;
137 my ( $elapsed, @state ) =
138 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
139 push @{ $c->{stats} },
140 _prettify( $action, sprintf( '%fs', $elapsed ), '' );
143 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
145 if ( my $error = $@ ) {
147 $error = qq/Caught exception "$error"/;
148 $c->log->error($error);
149 $c->error($error) if $c->debug;
164 $c->finalize_cookies;
166 if ( my $location = $c->response->redirect ) {
167 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
168 $c->response->header( Location => $location );
169 $c->response->status(302) if $c->response->status !~ /3\d\d$/;
172 if ( $#{ $c->error } >= 0 ) {
176 if ( !$c->response->output && $c->response->status !~ /^(1|3)\d\d$/ ) {
180 if ( $c->response->output && !$c->response->content_length ) {
181 use bytes; # play safe with a utf8 aware perl
182 $c->response->content_length( length $c->response->output );
185 my $status = $c->finalize_headers;
190 =item $c->finalize_cookies
196 sub finalize_cookies {
199 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
200 my $cookie = CGI::Cookie->new(
202 -value => $cookie->{value},
203 -expires => $cookie->{expires},
204 -domain => $cookie->{domain},
205 -path => $cookie->{path},
206 -secure => $cookie->{secure} || 0
209 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
213 =item $c->finalize_error
222 $c->res->headers->content_type('text/html');
223 my $name = $c->config->{name} || 'Catalyst Application';
225 my ( $title, $error, $infos );
227 $error = join '<br/>', @{ $c->error };
228 $error ||= 'No output';
229 $title = $name = "$name on Catalyst $Catalyst::VERSION";
230 my $req = encode_entities Dumper $c->req;
231 my $res = encode_entities Dumper $c->res;
232 my $stash = encode_entities Dumper $c->stash;
235 <b><u>Request</u></b><br/>
237 <b><u>Response</u></b><br/>
239 <b><u>Stash</u></b><br/>
248 (en) Please come back later
249 (de) Bitte versuchen sie es spaeter nocheinmal
250 (nl) Gelieve te komen later terug
251 (no) Vennligst prov igjen senere
252 (fr) Veuillez revenir plus tard
253 (es) Vuelto por favor mas adelante
254 (pt) Voltado por favor mais tarde
255 (it) Ritornato prego piĆ¹ successivamente
260 $c->res->output( <<"" );
263 <title>$title</title>
264 <style type="text/css">
266 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
267 Tahoma, Arial, helvetica, sans-serif;
269 background-color: #eee;
274 background-color: #ccc;
275 border: 1px solid #aaa;
278 -moz-border-radius: 10px;
281 background-color: #977;
282 border: 1px solid #755;
286 -moz-border-radius: 10px;
289 background-color: #797;
290 border: 1px solid #575;
294 -moz-border-radius: 10px;
297 background-color: #779;
298 border: 1px solid #557;
301 -moz-border-radius: 10px;
307 <div class="error">$error</div>
308 <div class="infos">$infos</div>
309 <div class="name">$name</div>
316 =item $c->finalize_headers
322 sub finalize_headers { }
324 =item $c->finalize_output
330 sub finalize_output { }
332 =item $c->forward($command)
334 Forward processing to a private action or a method from a class.
335 If you define a class without method it will default to process().
338 $c->forward('index');
339 $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
340 $c->forward('MyApp::View::TT');
348 $c->log->debug('Nothing to forward to') if $c->debug;
351 my $caller = caller(0);
353 if ( $command =~ /^\// ) {
354 $command =~ /^(.*)\/(\w+)$/;
355 $namespace = $1 || '/';
358 else { $namespace = _class2prefix($caller) || '/' }
359 my $results = $c->get_action( $command, $namespace );
360 unless ( @{$results} ) {
361 my $class = $command;
362 if ( $class =~ /[^\w\:]/ ) {
363 $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
366 my $method = shift || 'process';
367 if ( my $code = $class->can($method) ) {
368 $c->actions->{reverse}->{"$code"} = "$class->$method";
369 $results = [ [ [ $class, $code ] ] ];
372 $c->log->debug(qq/Couldn't forward to "$class->$method"/)
377 for my $result ( @{$results} ) {
378 $c->state( $c->execute( @{ $result->[0] } ) );
383 =item $c->get_action( $action, $namespace )
385 Get an action in a given namespace.
390 my ( $c, $action, $namespace ) = @_;
393 $namespace = '' if $namespace eq '/';
394 my $parent = $c->tree;
396 my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
397 push @results, [$result] if $result;
398 my $visitor = Tree::Simple::Visitor::FindByPath->new;
399 for my $part ( split '/', $namespace ) {
400 $visitor->setSearchPath($part);
401 $parent->accept($visitor);
402 my $child = $visitor->getResult;
403 my $uid = $child->getUID if $child;
404 my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
405 push @results, [$match] if $match;
406 $parent = $child if $child;
410 elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
411 elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
413 for my $i ( 0 .. $#{ $c->actions->{compiled} } ) {
414 my $name = $c->actions->{compiled}->[$i]->[0];
415 my $regex = $c->actions->{compiled}->[$i]->[1];
416 if ( $action =~ $regex ) {
418 for my $i ( 1 .. 9 ) {
421 push @snippets, ${$i};
423 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
430 =item $c->handler( $class, $r )
437 my ( $class, $engine ) = @_;
439 # Always expect worst case!
444 my $c = $class->prepare($engine);
445 $c->{stats} = \@stats;
446 my $action = $c->req->action;
448 $namespace = ( join( '/', @{ $c->req->args } ) || '/' )
449 if $action eq 'default';
450 unless ($namespace) {
451 if ( my $result = $c->get_action($action) ) {
452 $namespace = _class2prefix( $result->[0]->[0]->[0] );
455 my $default = $action eq 'default' ? $namespace : undef;
456 my $results = $c->get_action( $action, $default );
459 for my $begin ( @{ $c->get_action( 'begin', $namespace ) } ) {
460 $c->state( $c->execute( @{ $begin->[0] } ) );
462 for my $result ( @{ $c->get_action( $action, $default ) }[-1] )
464 $c->state( $c->execute( @{ $result->[0] } ) );
465 last unless $default;
467 for my $end ( reverse @{ $c->get_action( 'end', $namespace ) } )
469 $c->state( $c->execute( @{ $end->[0] } ) );
473 my $path = $c->req->path;
475 ? qq/Unknown resource "$path"/
476 : "No default action defined";
477 $c->log->error($error) if $c->debug;
482 if ( $class->debug ) {
484 ( $elapsed, $status ) = $class->benchmark($handler);
485 $elapsed = sprintf '%f', $elapsed;
486 my $av = sprintf '%.3f', 1 / $elapsed;
487 $class->log->info( "Request took $elapsed" . "s ($av/s)", @stats );
489 else { $status = &$handler }
491 if ( my $error = $@ ) {
493 $class->log->error(qq/Caught exception in engine "$error"/);
499 =item $c->prepare($r)
501 Turns the engine-specific request( Apache, CGI ... )
502 into a Catalyst context .
507 my ( $class, $r ) = @_;
509 request => Catalyst::Request->new(
513 headers => HTTP::Headers->new,
519 response => Catalyst::Response->new(
520 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
526 my $secs = time - $START || 1;
527 my $av = sprintf '%.3f', $COUNT / $secs;
528 $c->log->debug('********************************');
529 $c->log->debug("* Request $COUNT ($av/s) [$$]");
530 $c->log->debug('********************************');
531 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
533 $c->prepare_request($r);
537 $c->prepare_connection;
538 my $method = $c->req->method || '';
539 my $path = $c->req->path || '';
540 my $hostname = $c->req->hostname || '';
541 my $address = $c->req->address || '';
542 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
545 $c->prepare_parameters;
547 if ( $c->debug && keys %{ $c->req->params } ) {
549 for my $key ( keys %{ $c->req->params } ) {
550 my $value = $c->req->params->{$key} || '';
551 push @params, " $key=$value";
553 $c->log->debug( 'Parameters are', @params );
559 =item $c->prepare_action
567 my $path = $c->req->path;
568 my @path = split /\//, $c->req->path;
569 $c->req->args( \my @args );
571 $path = join '/', @path;
572 if ( my $result = ${ $c->get_action($path) }[0] ) {
576 my $match = $result->[1];
577 my @snippets = @{ $result->[2] };
578 $c->log->debug(qq/Requested action "$path" matched "$match"/)
581 'Snippets are "' . join( ' ', @snippets ) . '"' )
582 if ( $c->debug && @snippets );
583 $c->req->action($match);
584 $c->req->snippets( \@snippets );
587 $c->req->action($path);
588 $c->log->debug(qq/Requested action "$path"/) if $c->debug;
590 $c->req->match($path);
593 unshift @args, pop @path;
595 unless ( $c->req->action ) {
596 $c->req->action('default');
599 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
600 if ( $c->debug && @args );
603 =item $c->prepare_connection
609 sub prepare_connection { }
611 =item $c->prepare_cookies
617 sub prepare_cookies {
620 if ( my $header = $c->request->header('Cookie') ) {
621 $c->req->cookies( { CGI::Cookie->parse($header) } );
625 =item $c->prepare_headers
631 sub prepare_headers { }
633 =item $c->prepare_parameters
639 sub prepare_parameters { }
641 =item $c->prepare_path
643 Prepare path and base.
649 =item $c->prepare_request
651 Prepare the engine request.
655 sub prepare_request { }
657 =item $c->prepare_uploads
663 sub prepare_uploads { }
677 Returns a C<Catalyst::Request> object.
685 Returns a C<Catalyst::Response> object.
689 =item $c->set_action( $action, $code, $namespace, $attrs )
691 Set an action in a given namespace.
696 my ( $c, $method, $code, $namespace, $attrs ) = @_;
698 my $prefix = _class2prefix($namespace) || '';
701 for my $attr ( @{$attrs} ) {
702 if ( $attr =~ /^(Local|Relative)$/ ) { $flags{local}++ }
703 elsif ( $attr =~ /^(Global|Absolute)$/ ) { $flags{global}++ }
704 elsif ( $attr =~ /^Path\((.+)\)$/i ) { $flags{path} = $1 }
705 elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
706 elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
709 return unless keys %flags;
711 my $parent = $c->tree;
712 my $visitor = Tree::Simple::Visitor::FindByPath->new;
713 for my $part ( split '/', $prefix ) {
714 $visitor->setSearchPath($part);
715 $parent->accept($visitor);
716 my $child = $visitor->getResult;
718 $child = $parent->addChild( Tree::Simple->new($part) );
719 $visitor->setSearchPath($part);
720 $parent->accept($visitor);
721 $child = $visitor->getResult;
725 my $uid = $parent->getUID;
726 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
727 my $forward = $prefix ? "$prefix/$method" : $method;
729 if ( $flags{path} ) {
730 $flags{path} =~ s/^\w+//;
731 $flags{path} =~ s/\w+$//;
732 if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
733 if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
735 if ( $flags{regex} ) {
736 $flags{regex} =~ s/^\w+//;
737 $flags{regex} =~ s/\w+$//;
738 if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
739 if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
742 my $reverse = $prefix ? "$prefix/$method" : $method;
744 if ( $flags{local} || $flags{global} || $flags{path} ) {
745 my $path = $flags{path} || $method;
747 if ( $path =~ /^\/(.+)/ ) {
751 $absolute = 1 if $flags{global};
752 my $name = $absolute ? $path : "$prefix/$path";
753 $c->actions->{plain}->{$name} = [ $namespace, $code ];
755 if ( my $regex = $flags{regex} ) {
756 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
757 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
760 $c->actions->{reverse}->{"$code"} = $reverse;
773 $self->setup_components;
774 if ( $self->debug ) {
775 my $name = $self->config->{name} || 'Application';
776 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
780 =item $class->setup_actions($component)
782 Setup actions for a component.
787 my ( $self, $comp ) = @_;
788 $comp = ref $comp || $comp;
789 for my $action ( @{ $comp->_cache } ) {
790 my ( $code, $attrs ) = @{$action};
793 my @cache = ( $comp, @{"$comp\::ISA"} );
795 while ( my $namespace = shift @cache ) {
796 $namespaces{$namespace}++;
797 for my $isa ( @{"$comp\::ISA"} ) {
798 next if $namespaces{$isa};
803 for my $namespace ( keys %namespaces ) {
804 for my $sym ( values %{ $namespace . '::' } ) {
805 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
806 $name = *{$sym}{NAME};
807 $self->set_action( $name, $code, $comp, $attrs );
815 =item $class->setup_components
821 sub setup_components {
825 my $class = ref $self || $self;
828 import Module::Pluggable::Fast
829 name => '_components',
831 '$class\::Controller', '$class\::C',
832 '$class\::Model', '$class\::M',
833 '$class\::View', '$class\::V'
836 if ( my $error = $@ ) {
839 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
841 $self->setup_actions($self);
842 $self->components( {} );
843 for my $comp ( $self->_components($self) ) {
844 $self->components->{ ref $comp } = $comp;
845 $self->setup_actions($comp);
848 push @comps, " $_" for keys %{ $self->components };
849 $self->log->debug( 'Loaded components', @comps )
850 if ( @comps && $self->debug );
851 my $actions = $self->actions;
852 my @messages = ('Loaded private actions');
854 my ( $walker, $parent, $messages, $prefix ) = @_;
855 $prefix .= $parent->getNodeValue || '';
856 $prefix .= '/' unless $prefix =~ /\/$/;
857 my $uid = $parent->getUID;
858 for my $action ( keys %{ $actions->{private}->{$uid} } ) {
859 my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
860 push @$messages, _prettify( "$prefix$action", $class, $code );
862 $walker->( $walker, $_, $messages, $prefix )
863 for $parent->getAllChildren;
865 $walker->( $walker, $self->tree, \@messages, '' );
866 $self->log->debug(@messages) if ( $#messages && $self->debug );
867 @messages = ('Loaded plain actions');
868 for my $plain ( sort keys %{ $actions->{plain} } ) {
869 my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
870 push @messages, _prettify( "/$plain", $class, $code );
872 $self->log->debug(@messages) if ( $#messages && $self->debug );
873 @messages = ('Loaded regex actions');
874 for my $regex ( sort keys %{ $actions->{regex} } ) {
875 my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
876 push @messages, _prettify( $regex, $class, $code );
878 $self->log->debug(@messages) if ( $#messages && $self->debug );
883 Returns a hashref containing all your data.
885 $c->stash->{foo} ||= 'yada';
886 print $c->stash->{foo};
893 my $stash = $_[1] ? {@_} : $_[0];
894 while ( my ( $key, $val ) = each %$stash ) {
895 $self->{stash}->{$key} = $val;
898 return $self->{stash};
902 my ( $class, $name ) = @_;
903 my $prefix = _class2prefix($class);
904 $name = "$prefix/$name" if $prefix;
909 my $class = shift || '';
911 if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
913 $prefix =~ s/\:\:/\//g;
919 my ( $val1, $val2, $val3 ) = @_;
921 ' @<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<< @>>>>>>>>>>>>>> ',
932 Sebastian Riedel, C<sri@cpan.org>
936 This program is free software, you can redistribute it and/or modify it under
937 the same terms as Perl itself.