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);
362 my $action = $c->req->action;
364 $namespace = ( join( '/', @{ $c->req->args } ) || '/' )
365 if $action eq 'default';
366 unless ($namespace) {
367 if ( my $result = $c->get_action($action) ) {
368 $namespace = _class2prefix( $result->[0]->[0]->[0] );
371 my $default = $action eq 'default' ? $namespace : undef;
372 my $results = $c->get_action( $action, $default );
375 for my $begin ( @{ $c->get_action( 'begin', $namespace ) } ) {
376 $c->state( $c->execute( @{ $begin->[0] } ) );
378 for my $result ( @{ $c->get_action( $action, $default ) }[-1] )
380 $c->state( $c->execute( @{ $result->[0] } ) );
381 last unless $default;
383 for my $end ( reverse @{ $c->get_action( 'end', $namespace ) } )
385 $c->state( $c->execute( @{ $end->[0] } ) );
389 my $path = $c->req->path;
391 ? qq/Unknown resource "$path"/
392 : "No default action defined";
393 $c->log->error($error) if $c->debug;
398 if ( $class->debug ) {
400 ( $elapsed, $status ) = $class->benchmark($handler);
401 $elapsed = sprintf '%f', $elapsed;
402 my $av = sprintf '%.3f', 1 / $elapsed;
403 $class->log->info( "Request took $elapsed" . "s ($av/s)" );
405 else { $status = &$handler }
407 if ( my $error = $@ ) {
409 $class->log->error(qq/Caught exception in engine "$error"/);
415 =item $c->prepare($r)
417 Turns the engine-specific request( Apache, CGI ... )
418 into a Catalyst context .
423 my ( $class, $r ) = @_;
425 request => Catalyst::Request->new(
429 headers => HTTP::Headers->new,
435 response => Catalyst::Response->new(
436 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
442 my $secs = time - $START || 1;
443 my $av = sprintf '%.3f', $COUNT / $secs;
444 $c->log->debug('********************************');
445 $c->log->debug("* Request $COUNT ($av/s) [$$]");
446 $c->log->debug('********************************');
447 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
449 $c->prepare_request($r);
453 $c->prepare_connection;
454 my $method = $c->req->method || '';
455 my $path = $c->req->path || '';
456 my $hostname = $c->req->hostname || '';
457 my $address = $c->req->address || '';
458 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
461 $c->prepare_parameters;
463 if ( $c->debug && keys %{ $c->req->params } ) {
465 for my $key ( keys %{ $c->req->params } ) {
466 my $value = $c->req->params->{$key} || '';
467 push @params, " $key=$value";
469 $c->log->debug( 'Parameters', @params );
475 =item $c->prepare_action
483 my $path = $c->req->path;
484 my @path = split /\//, $c->req->path;
485 $c->req->args( \my @args );
487 $path = join '/', @path;
488 if ( my $result = ${ $c->get_action($path) }[0] ) {
492 my $match = $result->[1];
493 my @snippets = @{ $result->[2] };
494 $c->log->debug(qq/Requested action "$path" matched "$match"/)
497 'Snippets are "' . join( ' ', @snippets ) . '"' )
498 if ( $c->debug && @snippets );
499 $c->req->action($match);
500 $c->req->snippets( \@snippets );
503 $c->req->action($path);
504 $c->log->debug(qq/Requested action "$path"/) if $c->debug;
506 $c->req->match($path);
509 unshift @args, pop @path;
511 unless ( $c->req->action ) {
512 $c->req->action('default');
515 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
516 if ( $c->debug && @args );
519 =item $c->prepare_connection
525 sub prepare_connection { }
527 =item $c->prepare_cookies
533 sub prepare_cookies { }
535 =item $c->prepare_headers
541 sub prepare_headers { }
543 =item $c->prepare_parameters
549 sub prepare_parameters { }
551 =item $c->prepare_path
553 Prepare path and base.
559 =item $c->prepare_request
561 Prepare the engine request.
565 sub prepare_request { }
567 =item $c->prepare_uploads
573 sub prepare_uploads { }
575 =item $c->execute($class, $coderef)
577 Execute a coderef in given class and catch exceptions.
578 Errors are available via $c->error.
583 my ( $c, $class, $code ) = @_;
584 $class = $c->comp($class) || $class;
589 my $action = $c->actions->{reverse}->{"$code"} || "$code";
590 my ( $elapsed, @state ) =
591 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
592 $c->log->info( sprintf qq/Processing "$action" took %fs/, $elapsed )
596 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
598 if ( my $error = $@ ) {
600 $error = qq/Caught exception "$error"/;
601 $c->log->error($error);
602 $c->error($error) if $c->debug;
620 Returns a C<Catalyst::Request> object.
628 Returns a C<Catalyst::Response> object.
632 =item $c->set_action( $action, $code, $namespace, $attrs )
634 Set an action in a given namespace.
639 my ( $c, $method, $code, $namespace, $attrs ) = @_;
641 my $prefix = _class2prefix($namespace) || '';
644 for my $attr ( @{$attrs} ) {
645 if ( $attr =~ /^(Local|Relative)$/ ) { $flags{local}++ }
646 elsif ( $attr =~ /^(Global|Absolute)$/ ) { $flags{global}++ }
647 elsif ( $attr =~ /^Path\((.+)\)$/i ) { $flags{path} = $1 }
648 elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
649 elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
652 return unless keys %flags;
654 my $parent = $c->tree;
655 my $visitor = Tree::Simple::Visitor::FindByPath->new;
656 for my $part ( split '/', $prefix ) {
657 $visitor->setSearchPath($part);
658 $parent->accept($visitor);
659 my $child = $visitor->getResult;
661 $child = $parent->addChild( Tree::Simple->new($part) );
662 $visitor->setSearchPath($part);
663 $parent->accept($visitor);
664 $child = $visitor->getResult;
668 my $uid = $parent->getUID;
669 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
670 my $forward = $prefix ? "$prefix/$method" : $method;
672 if ( $flags{path} ) {
673 $flags{path} =~ s/^\w+//;
674 $flags{path} =~ s/\w+$//;
675 if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
676 if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
678 if ( $flags{regex} ) {
679 $flags{regex} =~ s/^\w+//;
680 $flags{regex} =~ s/\w+$//;
681 if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
682 if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
685 my $reverse = $prefix ? "$method ($prefix)" : $method;
687 if ( $flags{local} || $flags{global} || $flags{path} ) {
688 my $path = $flags{path} || $method;
690 if ( $path =~ /^\/(.+)/ ) {
694 $absolute = 1 if $flags{global};
695 my $name = $absolute ? $path : "$prefix/$path";
696 $c->actions->{plain}->{$name} = [ $namespace, $code ];
698 if ( my $regex = $flags{regex} ) {
699 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
700 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
703 $c->actions->{reverse}->{"$code"} = $reverse;
716 $self->setup_components;
717 if ( $self->debug ) {
718 my $name = $self->config->{name} || 'Application';
719 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
723 =item $class->setup_actions($component)
725 Setup actions for a component.
730 my ( $self, $comp ) = @_;
731 $comp = ref $comp || $comp;
732 for my $action ( @{ $comp->_cache } ) {
733 my ( $code, $attrs ) = @{$action};
736 my @cache = ( $comp, @{"$comp\::ISA"} );
738 while ( my $namespace = shift @cache ) {
739 $namespaces{$namespace}++;
740 for my $isa ( @{"$comp\::ISA"} ) {
741 next if $namespaces{$isa};
746 for my $namespace ( keys %namespaces ) {
747 for my $sym ( values %{ $namespace . '::' } ) {
748 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
749 $name = *{$sym}{NAME};
750 $self->set_action( $name, $code, $comp, $attrs );
758 =item $class->setup_components
764 sub setup_components {
768 my $class = ref $self || $self;
771 import Module::Pluggable::Fast
772 name => '_components',
774 '$class\::Controller', '$class\::C',
775 '$class\::Model', '$class\::M',
776 '$class\::View', '$class\::V'
779 if ( my $error = $@ ) {
782 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
784 $self->setup_actions($self);
785 $self->components( {} );
786 for my $comp ( $self->_components($self) ) {
787 $self->components->{ ref $comp } = $comp;
788 $self->setup_actions($comp);
791 push @comps, " $_" for keys %{ $self->components };
792 $self->log->debug( 'Loaded components', @comps )
793 if ( @comps && $self->debug );
794 my $actions = $self->actions;
795 my @messages = ('Loaded private actions');
797 my ( $walker, $parent, $messages, $prefix ) = @_;
798 $prefix .= $parent->getNodeValue || '';
799 $prefix .= '/' unless $prefix =~ /\/$/;
800 my $uid = $parent->getUID;
801 for my $action ( keys %{ $actions->{private}->{$uid} } ) {
802 my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
803 push @$messages, _prettify( "$prefix$action", $class, $code );
805 $walker->( $walker, $_, $messages, $prefix )
806 for $parent->getAllChildren;
808 $walker->( $walker, $self->tree, \@messages, '' );
809 $self->log->debug(@messages) if ( $#messages && $self->debug );
810 @messages = ('Loaded plain actions');
811 for my $plain ( sort keys %{ $actions->{plain} } ) {
812 my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
813 push @messages, _prettify( "/$plain", $class, $code );
815 $self->log->debug(@messages) if ( $#messages && $self->debug );
816 @messages = ('Loaded regex actions');
817 for my $regex ( sort keys %{ $actions->{regex} } ) {
818 my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
819 push @messages, _prettify( $regex, $class, $code );
821 $self->log->debug(@messages) if ( $#messages && $self->debug );
826 Returns a hashref containing all your data.
828 $c->stash->{foo} ||= 'yada';
829 print $c->stash->{foo};
836 my $stash = $_[1] ? {@_} : $_[0];
837 while ( my ( $key, $val ) = each %$stash ) {
838 $self->{stash}->{$key} = $val;
841 return $self->{stash};
845 my ( $class, $name ) = @_;
846 my $prefix = _class2prefix($class);
847 $name = "$prefix/$name" if $prefix;
852 my $class = shift || '';
854 if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
856 $prefix =~ s/\:\:/\//g;
862 my ( $action, $class, $code ) = @_;
864 ' @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @|||||||||||||| ',
865 $action, $class, $code;
875 Sebastian Riedel, C<sri@cpan.org>
879 This program is free software, you can redistribute it and/or modify it under
880 the same terms as Perl itself.