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 Text::ASCIITable::Wrap 'wrap';
15 use Tree::Simple::Visitor::FindByPath;
16 use Catalyst::Request;
17 use Catalyst::Response;
19 require Module::Pluggable::Fast;
21 $Data::Dumper::Terse = 1;
23 __PACKAGE__->mk_classdata($_) for qw/actions components tree/;
24 __PACKAGE__->mk_accessors(qw/request response state/);
27 { plain => {}, private => {}, regex => {}, compiled => [], reverse => {} }
29 __PACKAGE__->tree( Tree::Simple->new( 0, Tree::Simple->ROOT ) );
38 memoize('_class2prefix');
42 Catalyst::Engine - The Catalyst Engine
54 =item $c->benchmark($coderef)
56 Takes a coderef with arguments and returns elapsed time as float.
58 my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
59 $c->log->info( sprintf "Processing took %f seconds", $elapsed );
66 my $time = [gettimeofday];
67 my @return = &$code(@_);
68 my $elapsed = tv_interval $time;
69 return wantarray ? ( $elapsed, @return ) : $elapsed;
74 =item $c->component($name)
76 Get a component object by name.
78 $c->comp('MyApp::Model::MyModel')->do_stuff;
80 Regex search for a component.
82 $c->comp('mymodel')->do_stuff;
87 my ( $c, $name ) = @_;
88 if ( my $component = $c->components->{$name} ) {
92 for my $component ( keys %{ $c->components } ) {
93 return $c->components->{$component} if $component =~ /$name/i;
100 Dispatch request to actions.
106 my $action = $c->req->action;
108 $namespace = ( join( '/', @{ $c->req->args } ) || '/' )
109 if $action eq 'default';
110 unless ($namespace) {
111 if ( my $result = $c->get_action($action) ) {
112 $namespace = _class2prefix( $result->[0]->[0]->[0] );
115 my $default = $action eq 'default' ? $namespace : undef;
116 my $results = $c->get_action( $action, $default );
122 if ( my $begin = @{ $c->get_action( 'begin', $namespace ) }[-1] ) {
123 $c->execute( @{ $begin->[0] } );
126 # Execute the auto chain
127 for my $auto ( @{ $c->get_action( 'auto', $namespace ) } ) {
128 $c->execute( @{ $auto->[0] } );
129 last unless $c->state;
132 # Execute the action or last default
133 if ( ( my $action = $c->req->action ) && $c->state ) {
134 if ( my $result = @{ $c->get_action( $action, $default ) }[-1] ) {
135 $c->execute( @{ $result->[0] } );
140 if ( my $end = @{ $c->get_action( 'end', $namespace ) }[-1] ) {
141 $c->execute( @{ $end->[0] } );
145 my $path = $c->req->path;
147 ? qq/Unknown resource "$path"/
148 : "No default action defined";
149 $c->log->error($error) if $c->debug;
156 =item $c->error($error, ...)
158 =item $c->error($arrayref)
160 Returns an arrayref containing error messages.
162 my @error = @{ $c->error };
166 $c->error('Something bad happened');
172 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
173 push @{ $c->{error} }, @$error;
177 =item $c->execute($class, $coderef)
179 Execute a coderef in given class and catch exceptions.
180 Errors are available via $c->error.
185 my ( $c, $class, $code ) = @_;
186 $class = $c->comp($class) || $class;
188 my $callsub = ( caller(1) )[3];
192 my $action = $c->actions->{reverse}->{"$code"};
193 $action = "/$action" unless $action =~ /\-\>/;
194 $action = "-> $action" if $callsub =~ /forward$/;
195 my ( $elapsed, @state ) =
196 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
197 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
200 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
202 if ( my $error = $@ ) {
204 $error = qq/Caught exception "$error"/;
205 $c->log->error($error);
206 $c->error($error) if $c->debug;
221 $c->finalize_cookies;
223 if ( my $location = $c->response->redirect ) {
224 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
225 $c->response->header( Location => $location );
226 $c->response->status(302) if $c->response->status !~ /3\d\d$/;
229 if ( $#{ $c->error } >= 0 ) {
233 if ( !$c->response->output && $c->response->status !~ /^(1|3)\d\d$/ ) {
237 if ( $c->response->output && !$c->response->content_length ) {
238 use bytes; # play safe with a utf8 aware perl
239 $c->response->content_length( length $c->response->output );
242 my $status = $c->finalize_headers;
247 =item $c->finalize_cookies
253 sub finalize_cookies {
256 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
257 my $cookie = CGI::Cookie->new(
259 -value => $cookie->{value},
260 -expires => $cookie->{expires},
261 -domain => $cookie->{domain},
262 -path => $cookie->{path},
263 -secure => $cookie->{secure} || 0
266 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
270 =item $c->finalize_error
279 $c->res->headers->content_type('text/html');
280 my $name = $c->config->{name} || 'Catalyst Application';
282 my ( $title, $error, $infos );
284 $error = join '<br/>', @{ $c->error };
285 $error ||= 'No output';
286 $title = $name = "$name on Catalyst $Catalyst::VERSION";
287 my $req = encode_entities Dumper $c->req;
288 my $res = encode_entities Dumper $c->res;
289 my $stash = encode_entities Dumper $c->stash;
292 <b><u>Request</u></b><br/>
294 <b><u>Response</u></b><br/>
296 <b><u>Stash</u></b><br/>
305 (en) Please come back later
306 (de) Bitte versuchen sie es spaeter nocheinmal
307 (nl) Gelieve te komen later terug
308 (no) Vennligst prov igjen senere
309 (fr) Veuillez revenir plus tard
310 (es) Vuelto por favor mas adelante
311 (pt) Voltado por favor mais tarde
312 (it) Ritornato prego piĆ¹ successivamente
317 $c->res->output( <<"" );
320 <title>$title</title>
321 <style type="text/css">
323 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
324 Tahoma, Arial, helvetica, sans-serif;
326 background-color: #eee;
331 background-color: #ccc;
332 border: 1px solid #aaa;
335 -moz-border-radius: 10px;
338 background-color: #977;
339 border: 1px solid #755;
343 -moz-border-radius: 10px;
346 background-color: #797;
347 border: 1px solid #575;
351 -moz-border-radius: 10px;
354 background-color: #779;
355 border: 1px solid #557;
358 -moz-border-radius: 10px;
364 <div class="error">$error</div>
365 <div class="infos">$infos</div>
366 <div class="name">$name</div>
373 =item $c->finalize_headers
379 sub finalize_headers { }
381 =item $c->finalize_output
387 sub finalize_output { }
389 =item $c->forward($command)
391 Forward processing to a private action or a method from a class.
392 If you define a class without method it will default to process().
395 $c->forward('index');
396 $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
397 $c->forward('MyApp::View::TT');
405 $c->log->debug('Nothing to forward to') if $c->debug;
408 my $caller = caller(0);
410 if ( $command =~ /^\// ) {
411 $command =~ /^(.*)\/(\w+)$/;
412 $namespace = $1 || '/';
415 else { $namespace = _class2prefix($caller) || '/' }
416 my $results = $c->get_action( $command, $namespace );
417 unless ( @{$results} ) {
418 my $class = $command;
419 if ( $class =~ /[^\w\:]/ ) {
420 $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
423 my $method = shift || 'process';
424 if ( my $code = $class->can($method) ) {
425 $c->actions->{reverse}->{"$code"} = "$class->$method";
426 $results = [ [ [ $class, $code ] ] ];
429 $c->log->debug(qq/Couldn't forward to "$class->$method"/)
434 for my $result ( @{$results} ) {
435 $c->execute( @{ $result->[0] } );
440 =item $c->get_action( $action, $namespace )
442 Get an action in a given namespace.
447 my ( $c, $action, $namespace ) = @_;
448 return [] unless $action;
451 $namespace = '' if $namespace eq '/';
452 my $parent = $c->tree;
454 my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
455 push @results, [$result] if $result;
456 my $visitor = Tree::Simple::Visitor::FindByPath->new;
457 for my $part ( split '/', $namespace ) {
458 $visitor->setSearchPath($part);
459 $parent->accept($visitor);
460 my $child = $visitor->getResult;
461 my $uid = $child->getUID if $child;
462 my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
463 push @results, [$match] if $match;
464 $parent = $child if $child;
468 elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
469 elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
471 for my $i ( 0 .. $#{ $c->actions->{compiled} } ) {
472 my $name = $c->actions->{compiled}->[$i]->[0];
473 my $regex = $c->actions->{compiled}->[$i]->[1];
474 if ( $action =~ $regex ) {
476 for my $i ( 1 .. 9 ) {
479 push @snippets, ${$i};
481 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
488 =item $c->handler( $class, $r )
495 my ( $class, $engine ) = @_;
497 # Always expect worst case!
502 my $c = $class->prepare($engine);
503 $c->{stats} = \@stats;
507 if ( $class->debug ) {
509 ( $elapsed, $status ) = $class->benchmark($handler);
510 $elapsed = sprintf '%f', $elapsed;
511 my $av = sprintf '%.3f', 1 / $elapsed;
512 my $t = Text::ASCIITable->new;
513 $t->setCols( 'Action', 'Time' );
514 $t->setColWidth( 'Action', 64, 1 );
515 $t->setColWidth( 'Time', 9, 1 );
517 for my $stat (@stats) {
518 $t->addRow( wrap( $stat->[0], 64 ), wrap( $stat->[1], 9 ) );
520 $class->log->info( "Request took $elapsed" . "s ($av/s)",
523 else { $status = &$handler }
525 if ( my $error = $@ ) {
527 $class->log->error(qq/Caught exception in engine "$error"/);
533 =item $c->prepare($r)
535 Turns the engine-specific request( Apache, CGI ... )
536 into a Catalyst context .
541 my ( $class, $r ) = @_;
543 request => Catalyst::Request->new(
547 headers => HTTP::Headers->new,
553 response => Catalyst::Response->new(
554 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
560 my $secs = time - $START || 1;
561 my $av = sprintf '%.3f', $COUNT / $secs;
562 $c->log->debug('**********************************');
563 $c->log->debug("* Request $COUNT ($av/s) [$$]");
564 $c->log->debug('**********************************');
565 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
567 $c->prepare_request($r);
571 $c->prepare_connection;
572 my $method = $c->req->method || '';
573 my $path = $c->req->path || '';
574 my $hostname = $c->req->hostname || '';
575 my $address = $c->req->address || '';
576 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
579 $c->prepare_parameters;
581 if ( $c->debug && keys %{ $c->req->params } ) {
582 my $t = Text::ASCIITable->new;
583 $t->setCols( 'Key', 'Value' );
584 $t->setColWidth( 'Key', 37, 1 );
585 $t->setColWidth( 'Value', 36, 1 );
586 for my $key ( keys %{ $c->req->params } ) {
587 my $value = $c->req->params->{$key} || '';
588 $t->addRow( wrap( $key, 37 ), wrap( $value, 36 ) );
590 $c->log->debug( 'Parameters are', $t->draw );
596 =item $c->prepare_action
604 my $path = $c->req->path;
605 my @path = split /\//, $c->req->path;
606 $c->req->args( \my @args );
608 $path = join '/', @path;
609 if ( my $result = ${ $c->get_action($path) }[0] ) {
613 my $match = $result->[1];
614 my @snippets = @{ $result->[2] };
616 qq/Requested action is "$path" and matched "$match"/)
619 'Snippets are "' . join( ' ', @snippets ) . '"' )
620 if ( $c->debug && @snippets );
621 $c->req->action($match);
622 $c->req->snippets( \@snippets );
625 $c->req->action($path);
626 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
628 $c->req->match($path);
631 unshift @args, pop @path;
633 unless ( $c->req->action ) {
634 $c->req->action('default');
637 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
638 if ( $c->debug && @args );
641 =item $c->prepare_connection
647 sub prepare_connection { }
649 =item $c->prepare_cookies
655 sub prepare_cookies {
658 if ( my $header = $c->request->header('Cookie') ) {
659 $c->req->cookies( { CGI::Cookie->parse($header) } );
663 =item $c->prepare_headers
669 sub prepare_headers { }
671 =item $c->prepare_parameters
677 sub prepare_parameters { }
679 =item $c->prepare_path
681 Prepare path and base.
687 =item $c->prepare_request
689 Prepare the engine request.
693 sub prepare_request { }
695 =item $c->prepare_uploads
701 sub prepare_uploads { }
715 Returns a C<Catalyst::Request> object.
723 Returns a C<Catalyst::Response> object.
727 =item $c->set_action( $action, $code, $namespace, $attrs )
729 Set an action in a given namespace.
734 my ( $c, $method, $code, $namespace, $attrs ) = @_;
736 my $prefix = _class2prefix($namespace) || '';
739 for my $attr ( @{$attrs} ) {
740 if ( $attr =~ /^(Local|Relative)$/ ) { $flags{local}++ }
741 elsif ( $attr =~ /^(Global|Absolute)$/ ) { $flags{global}++ }
742 elsif ( $attr =~ /^Path\((.+)\)$/i ) { $flags{path} = $1 }
743 elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
744 elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
747 return unless keys %flags;
749 my $parent = $c->tree;
750 my $visitor = Tree::Simple::Visitor::FindByPath->new;
751 for my $part ( split '/', $prefix ) {
752 $visitor->setSearchPath($part);
753 $parent->accept($visitor);
754 my $child = $visitor->getResult;
756 $child = $parent->addChild( Tree::Simple->new($part) );
757 $visitor->setSearchPath($part);
758 $parent->accept($visitor);
759 $child = $visitor->getResult;
763 my $uid = $parent->getUID;
764 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
765 my $forward = $prefix ? "$prefix/$method" : $method;
767 if ( $flags{path} ) {
768 $flags{path} =~ s/^\w+//;
769 $flags{path} =~ s/\w+$//;
770 if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
771 if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
773 if ( $flags{regex} ) {
774 $flags{regex} =~ s/^\w+//;
775 $flags{regex} =~ s/\w+$//;
776 if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
777 if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
780 my $reverse = $prefix ? "$prefix/$method" : $method;
782 if ( $flags{local} || $flags{global} || $flags{path} ) {
783 my $path = $flags{path} || $method;
785 if ( $path =~ /^\/(.+)/ ) {
789 $absolute = 1 if $flags{global};
790 my $name = $absolute ? $path : $prefix ? "$prefix/$path" : $path;
791 $c->actions->{plain}->{$name} = [ $namespace, $code ];
793 if ( my $regex = $flags{regex} ) {
794 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
795 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
798 $c->actions->{reverse}->{"$code"} = $reverse;
811 $self->setup_components;
812 if ( $self->debug ) {
813 my $name = $self->config->{name} || 'Application';
814 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
818 =item $class->setup_actions($component)
820 Setup actions for a component.
825 my ( $self, $comp ) = @_;
826 $comp = ref $comp || $comp;
827 for my $action ( @{ $comp->_cache } ) {
828 my ( $code, $attrs ) = @{$action};
831 my @cache = ( $comp, @{"$comp\::ISA"} );
833 while ( my $namespace = shift @cache ) {
834 $namespaces{$namespace}++;
835 for my $isa ( @{"$comp\::ISA"} ) {
836 next if $namespaces{$isa};
841 for my $namespace ( keys %namespaces ) {
842 for my $sym ( values %{ $namespace . '::' } ) {
843 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
844 $name = *{$sym}{NAME};
845 $self->set_action( $name, $code, $comp, $attrs );
853 =item $class->setup_components
859 sub setup_components {
863 my $class = ref $self || $self;
866 import Module::Pluggable::Fast
867 name => '_components',
869 '$class\::Controller', '$class\::C',
870 '$class\::Model', '$class\::M',
871 '$class\::View', '$class\::V'
874 if ( my $error = $@ ) {
877 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
879 $self->setup_actions($self);
880 $self->components( {} );
881 for my $comp ( $self->_components($self) ) {
882 $self->components->{ ref $comp } = $comp;
883 $self->setup_actions($comp);
885 my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
886 $t->setCols('Class');
887 $t->setColWidth( 'Class', 75, 1 );
888 $t->addRow( wrap( $_, 75 ) ) for keys %{ $self->components };
889 $self->log->debug( 'Loaded components', $t->draw )
890 if ( @{ $t->{tbl_rows} } && $self->debug );
891 my $actions = $self->actions;
892 my $privates = Text::ASCIITable->new;
893 $privates->setCols( 'Private', 'Class', 'Code' );
894 $privates->setColWidth( 'Private', 28, 1 );
895 $privates->setColWidth( 'Class', 28, 1 );
896 $privates->setColWidth( 'Code', 14, 1 );
898 my ( $walker, $parent, $prefix ) = @_;
899 $prefix .= $parent->getNodeValue || '';
900 $prefix .= '/' unless $prefix =~ /\/$/;
901 my $uid = $parent->getUID;
902 for my $action ( keys %{ $actions->{private}->{$uid} } ) {
903 my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
905 wrap( "$prefix$action", 28 ),
910 $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
912 $walker->( $walker, $self->tree, '' );
913 $self->log->debug( 'Loaded private actions', $privates->draw )
914 if ( @{ $privates->{tbl_rows} } && $self->debug );
915 my $publics = Text::ASCIITable->new;
916 $publics->setCols( 'Public', 'Private' );
917 $publics->setColWidth( 'Public', 37, 1 );
918 $publics->setColWidth( 'Private', 36, 1 );
920 for my $plain ( sort keys %{ $actions->{plain} } ) {
921 my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
922 $publics->addRow( wrap( "/$plain", 37 ),
923 wrap( $self->actions->{reverse}->{$code} || $code, 36 ) );
925 $self->log->debug( 'Loaded public actions', $publics->draw )
926 if ( @{ $publics->{tbl_rows} } && $self->debug );
927 my $regexes = Text::ASCIITable->new;
928 $regexes->setCols( 'Regex', 'Private' );
929 $regexes->setColWidth( 'Regex', 37, 1 );
930 $regexes->setColWidth( 'Private', 36, 1 );
931 for my $regex ( sort keys %{ $actions->{regex} } ) {
932 my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
933 $regexes->addRow( wrap( $regex, 37 ),
934 wrap( $self->actions->{reverse}->{$class} || $class, 36 ) );
936 $self->log->debug( 'Loaded regex actions', $regexes->draw )
937 if ( @{ $regexes->{tbl_rows} } && $self->debug );
942 Contains the return value of the last executed action.
946 Returns a hashref containing all your data.
948 $c->stash->{foo} ||= 'yada';
949 print $c->stash->{foo};
956 my $stash = $_[1] ? {@_} : $_[0];
957 while ( my ( $key, $val ) = each %$stash ) {
958 $self->{stash}->{$key} = $val;
961 return $self->{stash};
965 my ( $class, $name ) = @_;
966 my $prefix = _class2prefix($class);
967 $name = "$prefix/$name" if $prefix;
972 my $class = shift || '';
974 if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
976 $prefix =~ s/\:\:/\//g;
985 Sebastian Riedel, C<sri@cpan.org>
989 This program is free software, you can redistribute it and/or modify it under
990 the same terms as Perl itself.