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->benchmark($coderef)
53 Takes a coderef with arguments and returns elapsed time as float.
55 my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
56 $c->log->info( sprintf "Processing took %f seconds", $elapsed );
63 my $time = [gettimeofday];
64 my @return = &$code(@_);
65 my $elapsed = tv_interval $time;
66 return wantarray ? ( $elapsed, @return ) : $elapsed;
71 =item $c->component($name)
73 Get a component object by name.
75 $c->comp('MyApp::Model::MyModel')->do_stuff;
77 Regex search for a component.
79 $c->comp('mymodel')->do_stuff;
84 my ( $c, $name ) = @_;
85 if ( my $component = $c->components->{$name} ) {
89 for my $component ( keys %{ $c->components } ) {
90 return $c->components->{$component} if $component =~ /$name/i;
97 =item $c->error($error, ...)
99 =item $c->error($arrayref)
101 Returns an arrayref containing error messages.
103 my @error = @{ $c->error };
107 $c->error('Something bad happened');
113 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
114 push @{ $c->{error} }, @$error;
127 if ( my $location = $c->res->redirect ) {
128 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
129 $c->res->headers->header( Location => $location );
130 $c->res->headers->remove_content_headers;
131 $c->res->status(302);
132 return $c->finalize_headers;
135 if ( !$c->res->output || $#{ $c->error } >= 0 ) {
136 $c->res->headers->content_type('text/html');
137 my $name = $c->config->{name} || 'Catalyst Application';
138 my ( $title, $error, $infos );
140 $error = join '<br/>', @{ $c->error };
141 $error ||= 'No output';
142 $title = $name = "$name on Catalyst $Catalyst::VERSION";
143 my $req = encode_entities Dumper $c->req;
144 my $res = encode_entities Dumper $c->res;
145 my $stash = encode_entities Dumper $c->stash;
148 <b><u>Request</u></b><br/>
150 <b><u>Response</u></b><br/>
152 <b><u>Stash</u></b><br/>
161 (en) Please come back later
162 (de) Bitte versuchen sie es spaeter nocheinmal
163 (nl) Gelieve te komen later terug
164 (no) Vennligst prov igjen senere
165 (fr) Veuillez revenir plus tard
166 (es) Vuelto por favor mas adelante
167 (pt) Voltado por favor mais tarde
168 (it) Ritornato prego piĆ¹ successivamente
173 $c->res->{output} = <<"";
176 <title>$title</title>
177 <style type="text/css">
179 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
180 Tahoma, Arial, helvetica, sans-serif;
182 background-color: #eee;
187 background-color: #ccc;
188 border: 1px solid #aaa;
191 -moz-border-radius: 10px;
194 background-color: #977;
195 border: 1px solid #755;
199 -moz-border-radius: 10px;
202 background-color: #797;
203 border: 1px solid #575;
207 -moz-border-radius: 10px;
210 background-color: #779;
211 border: 1px solid #557;
214 -moz-border-radius: 10px;
220 <div class="error">$error</div>
221 <div class="infos">$infos</div>
222 <div class="name">$name</div>
228 $c->res->headers->content_length( length $c->res->output );
229 my $status = $c->finalize_headers;
234 =item $c->finalize_headers
240 sub finalize_headers { }
242 =item $c->finalize_output
248 sub finalize_output { }
250 =item $c->forward($command)
252 Forward processing to a private action or a method from a class.
253 If you define a class without method it will default to process().
256 $c->forward('index');
257 $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
258 $c->forward('MyApp::View::TT');
266 $c->log->debug('Nothing to forward to') if $c->debug;
269 my $caller = caller(0);
271 if ( $command =~ /^\// ) {
272 $command =~ /^(.*)\/(\w+)$/;
273 $namespace = $1 || '/';
276 else { $namespace = _class2prefix($caller) || '/' }
277 my $results = $c->get_action( $command, $namespace );
278 unless ( @{$results} ) {
279 my $class = $command;
280 if ( $class =~ /[^\w\:]/ ) {
281 $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
284 my $method = shift || 'process';
285 if ( my $code = $class->can($method) ) {
286 $c->actions->{reverse}->{"$code"} = "$class->$method";
287 $results = [ [ [ $class, $code ] ] ];
290 $c->log->debug(qq/Couldn't forward to "$class->$method"/)
295 for my $result ( @{$results} ) {
296 $c->state( $c->execute( @{ $result->[0] } ) );
301 =item $c->get_action( $action, $namespace )
303 Get an action in a given namespace.
308 my ( $c, $action, $namespace ) = @_;
311 $namespace = '' if $namespace eq '/';
312 my $parent = $c->tree;
314 my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
315 push @results, [$result] if $result;
316 my $visitor = Tree::Simple::Visitor::FindByPath->new;
317 for my $part ( split '/', $namespace ) {
318 $visitor->setSearchPath($part);
319 $parent->accept($visitor);
320 my $child = $visitor->getResult;
321 my $uid = $child->getUID if $child;
322 my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
323 push @results, [$match] if $match;
324 $parent = $child if $child;
328 elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
329 elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
331 for my $i ( 0 .. $#{ $c->actions->{compiled} } ) {
332 my $name = $c->actions->{compiled}->[$i]->[0];
333 my $regex = $c->actions->{compiled}->[$i]->[1];
334 if ( $action =~ $regex ) {
336 for my $i ( 1 .. 9 ) {
339 push @snippets, ${$i};
341 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
348 =item $c->handler( $class, $r )
355 my ( $class, $r ) = @_;
357 # Always expect worst case!
361 my $c = $class->prepare($r);
363 my $action = $c->req->action;
365 $namespace = ( join( '/', @{ $c->req->args } ) || '/' )
366 if $action eq 'default';
367 unless ($namespace) {
368 if ( my $result = $c->get_action($action) ) {
369 $namespace = _class2prefix( $result->[0]->[0]->[0] );
372 my $default = $action eq 'default' ? $namespace : undef;
373 my $results = $c->get_action( $action, $default );
376 for my $begin ( @{ $c->get_action( 'begin', $namespace ) } ) {
377 $c->state( $c->execute( @{ $begin->[0] } ) );
379 for my $result ( @{ $c->get_action( $action, $default ) }[-1] )
381 $c->state( $c->execute( @{ $result->[0] } ) );
382 last unless $default;
384 for my $end ( reverse @{ $c->get_action( 'end', $namespace ) } )
386 $c->state( $c->execute( @{ $end->[0] } ) );
388 my @stats = @{ $c->{stats} };
389 $c->log->info( 'Processing took', @stats )
390 if ( @stats && $c->debug );
393 my $path = $c->req->path;
395 ? qq/Unknown resource "$path"/
396 : "No default action defined";
397 $c->log->error($error) if $c->debug;
402 if ( $class->debug ) {
404 ( $elapsed, $status ) = $class->benchmark($handler);
405 $elapsed = sprintf '%f', $elapsed;
406 my $av = sprintf '%.3f', 1 / $elapsed;
407 $class->log->info( "Request took $elapsed" . "s ($av/s)" );
409 else { $status = &$handler }
411 if ( my $error = $@ ) {
413 $class->log->error(qq/Caught exception in engine "$error"/);
419 =item $c->prepare($r)
421 Turns the engine-specific request( Apache, CGI ... )
422 into a Catalyst context .
427 my ( $class, $r ) = @_;
429 request => Catalyst::Request->new(
433 headers => HTTP::Headers->new,
439 response => Catalyst::Response->new(
440 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
446 my $secs = time - $START || 1;
447 my $av = sprintf '%.3f', $COUNT / $secs;
448 $c->log->debug('********************************');
449 $c->log->debug("* Request $COUNT ($av/s) [$$]");
450 $c->log->debug('********************************');
451 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
453 $c->prepare_request($r);
457 $c->prepare_connection;
458 my $method = $c->req->method || '';
459 my $path = $c->req->path || '';
460 my $hostname = $c->req->hostname || '';
461 my $address = $c->req->address || '';
462 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
465 $c->prepare_parameters;
467 if ( $c->debug && keys %{ $c->req->params } ) {
469 for my $key ( keys %{ $c->req->params } ) {
470 my $value = $c->req->params->{$key} || '';
471 push @params, " $key=$value";
473 $c->log->debug( 'Parameters are', @params );
479 =item $c->prepare_action
487 my $path = $c->req->path;
488 my @path = split /\//, $c->req->path;
489 $c->req->args( \my @args );
491 $path = join '/', @path;
492 if ( my $result = ${ $c->get_action($path) }[0] ) {
496 my $match = $result->[1];
497 my @snippets = @{ $result->[2] };
498 $c->log->debug(qq/Requested action "$path" matched "$match"/)
501 'Snippets are "' . join( ' ', @snippets ) . '"' )
502 if ( $c->debug && @snippets );
503 $c->req->action($match);
504 $c->req->snippets( \@snippets );
507 $c->req->action($path);
508 $c->log->debug(qq/Requested action "$path"/) if $c->debug;
510 $c->req->match($path);
513 unshift @args, pop @path;
515 unless ( $c->req->action ) {
516 $c->req->action('default');
519 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
520 if ( $c->debug && @args );
523 =item $c->prepare_connection
529 sub prepare_connection { }
531 =item $c->prepare_cookies
537 sub prepare_cookies { }
539 =item $c->prepare_headers
545 sub prepare_headers { }
547 =item $c->prepare_parameters
553 sub prepare_parameters { }
555 =item $c->prepare_path
557 Prepare path and base.
563 =item $c->prepare_request
565 Prepare the engine request.
569 sub prepare_request { }
571 =item $c->prepare_uploads
577 sub prepare_uploads { }
579 =item $c->execute($class, $coderef)
581 Execute a coderef in given class and catch exceptions.
582 Errors are available via $c->error.
587 my ( $c, $class, $code ) = @_;
588 $class = $c->comp($class) || $class;
593 my $action = $c->actions->{reverse}->{"$code"};
594 $action = "/$action" unless $action =~ /\-\>/;
595 my ( $elapsed, @state ) =
596 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
597 push @{ $c->{stats} },
598 _prettify( $action, '', sprintf( '%fs', $elapsed ) );
601 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
603 if ( my $error = $@ ) {
605 $error = qq/Caught exception "$error"/;
606 $c->log->error($error);
607 $c->error($error) if $c->debug;
625 Returns a C<Catalyst::Request> object.
633 Returns a C<Catalyst::Response> object.
637 =item $c->set_action( $action, $code, $namespace, $attrs )
639 Set an action in a given namespace.
644 my ( $c, $method, $code, $namespace, $attrs ) = @_;
646 my $prefix = _class2prefix($namespace) || '';
649 for my $attr ( @{$attrs} ) {
650 if ( $attr =~ /^(Local|Relative)$/ ) { $flags{local}++ }
651 elsif ( $attr =~ /^(Global|Absolute)$/ ) { $flags{global}++ }
652 elsif ( $attr =~ /^Path\((.+)\)$/i ) { $flags{path} = $1 }
653 elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
654 elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
657 return unless keys %flags;
659 my $parent = $c->tree;
660 my $visitor = Tree::Simple::Visitor::FindByPath->new;
661 for my $part ( split '/', $prefix ) {
662 $visitor->setSearchPath($part);
663 $parent->accept($visitor);
664 my $child = $visitor->getResult;
666 $child = $parent->addChild( Tree::Simple->new($part) );
667 $visitor->setSearchPath($part);
668 $parent->accept($visitor);
669 $child = $visitor->getResult;
673 my $uid = $parent->getUID;
674 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
675 my $forward = $prefix ? "$prefix/$method" : $method;
677 if ( $flags{path} ) {
678 $flags{path} =~ s/^\w+//;
679 $flags{path} =~ s/\w+$//;
680 if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
681 if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
683 if ( $flags{regex} ) {
684 $flags{regex} =~ s/^\w+//;
685 $flags{regex} =~ s/\w+$//;
686 if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
687 if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
690 my $reverse = $prefix ? "$prefix/$method" : $method;
692 if ( $flags{local} || $flags{global} || $flags{path} ) {
693 my $path = $flags{path} || $method;
695 if ( $path =~ /^\/(.+)/ ) {
699 $absolute = 1 if $flags{global};
700 my $name = $absolute ? $path : "$prefix/$path";
701 $c->actions->{plain}->{$name} = [ $namespace, $code ];
703 if ( my $regex = $flags{regex} ) {
704 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
705 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
708 $c->actions->{reverse}->{"$code"} = $reverse;
721 $self->setup_components;
722 if ( $self->debug ) {
723 my $name = $self->config->{name} || 'Application';
724 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
728 =item $class->setup_actions($component)
730 Setup actions for a component.
735 my ( $self, $comp ) = @_;
736 $comp = ref $comp || $comp;
737 for my $action ( @{ $comp->_cache } ) {
738 my ( $code, $attrs ) = @{$action};
741 my @cache = ( $comp, @{"$comp\::ISA"} );
743 while ( my $namespace = shift @cache ) {
744 $namespaces{$namespace}++;
745 for my $isa ( @{"$comp\::ISA"} ) {
746 next if $namespaces{$isa};
751 for my $namespace ( keys %namespaces ) {
752 for my $sym ( values %{ $namespace . '::' } ) {
753 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
754 $name = *{$sym}{NAME};
755 $self->set_action( $name, $code, $comp, $attrs );
763 =item $class->setup_components
769 sub setup_components {
773 my $class = ref $self || $self;
776 import Module::Pluggable::Fast
777 name => '_components',
779 '$class\::Controller', '$class\::C',
780 '$class\::Model', '$class\::M',
781 '$class\::View', '$class\::V'
784 if ( my $error = $@ ) {
787 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
789 $self->setup_actions($self);
790 $self->components( {} );
791 for my $comp ( $self->_components($self) ) {
792 $self->components->{ ref $comp } = $comp;
793 $self->setup_actions($comp);
796 push @comps, " $_" for keys %{ $self->components };
797 $self->log->debug( 'Loaded components', @comps )
798 if ( @comps && $self->debug );
799 my $actions = $self->actions;
800 my @messages = ('Loaded private actions');
802 my ( $walker, $parent, $messages, $prefix ) = @_;
803 $prefix .= $parent->getNodeValue || '';
804 $prefix .= '/' unless $prefix =~ /\/$/;
805 my $uid = $parent->getUID;
806 for my $action ( keys %{ $actions->{private}->{$uid} } ) {
807 my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
808 push @$messages, _prettify( "$prefix$action", $class, $code );
810 $walker->( $walker, $_, $messages, $prefix )
811 for $parent->getAllChildren;
813 $walker->( $walker, $self->tree, \@messages, '' );
814 $self->log->debug(@messages) if ( $#messages && $self->debug );
815 @messages = ('Loaded plain actions');
816 for my $plain ( sort keys %{ $actions->{plain} } ) {
817 my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
818 push @messages, _prettify( "/$plain", $class, $code );
820 $self->log->debug(@messages) if ( $#messages && $self->debug );
821 @messages = ('Loaded regex actions');
822 for my $regex ( sort keys %{ $actions->{regex} } ) {
823 my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
824 push @messages, _prettify( $regex, $class, $code );
826 $self->log->debug(@messages) if ( $#messages && $self->debug );
831 Returns a hashref containing all your data.
833 $c->stash->{foo} ||= 'yada';
834 print $c->stash->{foo};
841 my $stash = $_[1] ? {@_} : $_[0];
842 while ( my ( $key, $val ) = each %$stash ) {
843 $self->{stash}->{$key} = $val;
846 return $self->{stash};
850 my ( $class, $name ) = @_;
851 my $prefix = _class2prefix($class);
852 $name = "$prefix/$name" if $prefix;
857 my $class = shift || '';
859 if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
861 $prefix =~ s/\:\:/\//g;
867 my ( $val1, $val2, $val3 ) = @_;
869 ' @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<< @>>>>>>>>>>>>>> ',
880 Sebastian Riedel, C<sri@cpan.org>
884 This program is free software, you can redistribute it and/or modify it under
885 the same terms as Perl itself.