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] } );
124 return if scalar @{$c->error};
125 last unless $c->state;
128 # Execute the auto chain
129 for my $auto ( @{ $c->get_action( 'auto', $namespace ) } ) {
130 $c->execute( @{ $auto->[0] } );
131 return if scalar @{$c->error};
132 last unless $c->state;
135 # Execute the action or last default
136 if ( ( my $action = $c->req->action ) && $c->state ) {
137 if ( my $result = @{ $c->get_action( $action, $default ) }[-1] ) {
138 $c->execute( @{ $result->[0] } );
143 if ( my $end = @{ $c->get_action( 'end', $namespace ) }[-1] ) {
144 $c->execute( @{ $end->[0] } );
145 return if scalar @{$c->error};
146 last unless $c->state;
150 my $path = $c->req->path;
152 ? qq/Unknown resource "$path"/
153 : "No default action defined";
154 $c->log->error($error) if $c->debug;
161 =item $c->error($error, ...)
163 =item $c->error($arrayref)
165 Returns an arrayref containing error messages.
167 my @error = @{ $c->error };
171 $c->error('Something bad happened');
177 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
178 push @{ $c->{error} }, @$error;
182 =item $c->execute($class, $coderef)
184 Execute a coderef in given class and catch exceptions.
185 Errors are available via $c->error.
190 my ( $c, $class, $code ) = @_;
191 $class = $c->comp($class) || $class;
193 my $callsub = ( caller(1) )[3];
197 my $action = $c->actions->{reverse}->{"$code"};
198 $action = "/$action" unless $action =~ /\-\>/;
199 $action = "-> $action" if $callsub =~ /forward$/;
200 my ( $elapsed, @state ) =
201 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
202 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
205 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
207 if ( my $error = $@ ) {
209 $error = qq/Caught exception "$error"/;
210 $c->log->error($error);
226 $c->finalize_cookies;
228 if ( my $location = $c->response->redirect ) {
229 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
230 $c->response->header( Location => $location );
231 $c->response->status(302) if $c->response->status !~ /3\d\d$/;
234 if ( $#{ $c->error } >= 0 ) {
238 if ( !$c->response->output && $c->response->status !~ /^(1|3)\d\d$/ ) {
242 if ( $c->response->output && !$c->response->content_length ) {
243 use bytes; # play safe with a utf8 aware perl
244 $c->response->content_length( length $c->response->output );
247 my $status = $c->finalize_headers;
252 =item $c->finalize_cookies
258 sub finalize_cookies {
261 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
262 my $cookie = CGI::Cookie->new(
264 -value => $cookie->{value},
265 -expires => $cookie->{expires},
266 -domain => $cookie->{domain},
267 -path => $cookie->{path},
268 -secure => $cookie->{secure} || 0
271 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
275 =item $c->finalize_error
284 $c->res->headers->content_type('text/html');
285 my $name = $c->config->{name} || 'Catalyst Application';
287 my ( $title, $error, $infos );
289 $error = join '<br/>', @{ $c->error };
290 $error ||= 'No output';
291 $title = $name = "$name on Catalyst $Catalyst::VERSION";
292 my $req = encode_entities Dumper $c->req;
293 my $res = encode_entities Dumper $c->res;
294 my $stash = encode_entities Dumper $c->stash;
297 <b><u>Request</u></b><br/>
299 <b><u>Response</u></b><br/>
301 <b><u>Stash</u></b><br/>
310 (en) Please come back later
311 (de) Bitte versuchen sie es spaeter nocheinmal
312 (nl) Gelieve te komen later terug
313 (no) Vennligst prov igjen senere
314 (fr) Veuillez revenir plus tard
315 (es) Vuelto por favor mas adelante
316 (pt) Voltado por favor mais tarde
317 (it) Ritornato prego piĆ¹ successivamente
322 $c->res->output( <<"" );
325 <title>$title</title>
326 <style type="text/css">
328 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
329 Tahoma, Arial, helvetica, sans-serif;
331 background-color: #eee;
336 background-color: #ccc;
337 border: 1px solid #aaa;
340 -moz-border-radius: 10px;
343 background-color: #977;
344 border: 1px solid #755;
348 -moz-border-radius: 10px;
351 background-color: #797;
352 border: 1px solid #575;
356 -moz-border-radius: 10px;
359 background-color: #779;
360 border: 1px solid #557;
363 -moz-border-radius: 10px;
369 <div class="error">$error</div>
370 <div class="infos">$infos</div>
371 <div class="name">$name</div>
378 =item $c->finalize_headers
384 sub finalize_headers { }
386 =item $c->finalize_output
392 sub finalize_output { }
394 =item $c->forward($command)
396 Forward processing to a private action or a method from a class.
397 If you define a class without method it will default to process().
400 $c->forward('index');
401 $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
402 $c->forward('MyApp::View::TT');
410 $c->log->debug('Nothing to forward to') if $c->debug;
413 my $caller = caller(0);
415 if ( $command =~ /^\// ) {
416 $command =~ /^(.*)\/(\w+)$/;
417 $namespace = $1 || '/';
420 else { $namespace = _class2prefix($caller) || '/' }
421 my $results = $c->get_action( $command, $namespace );
422 unless ( @{$results} ) {
423 my $class = $command;
424 if ( $class =~ /[^\w\:]/ ) {
425 $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
428 my $method = shift || 'process';
429 if ( my $code = $class->can($method) ) {
430 $c->actions->{reverse}->{"$code"} = "$class->$method";
431 $results = [ [ [ $class, $code ] ] ];
434 $c->log->debug(qq/Couldn't forward to "$class->$method"/)
439 for my $result ( @{$results} ) {
440 $c->execute( @{ $result->[0] } );
445 =item $c->get_action( $action, $namespace )
447 Get an action in a given namespace.
452 my ( $c, $action, $namespace ) = @_;
453 return [] unless $action;
456 $namespace = '' if $namespace eq '/';
457 my $parent = $c->tree;
459 my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
460 push @results, [$result] if $result;
461 my $visitor = Tree::Simple::Visitor::FindByPath->new;
462 for my $part ( split '/', $namespace ) {
463 $visitor->setSearchPath($part);
464 $parent->accept($visitor);
465 my $child = $visitor->getResult;
466 my $uid = $child->getUID if $child;
467 my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
468 push @results, [$match] if $match;
469 $parent = $child if $child;
473 elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
474 elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
476 for my $i ( 0 .. $#{ $c->actions->{compiled} } ) {
477 my $name = $c->actions->{compiled}->[$i]->[0];
478 my $regex = $c->actions->{compiled}->[$i]->[1];
479 if ( $action =~ $regex ) {
481 for my $i ( 1 .. 9 ) {
484 push @snippets, ${$i};
486 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
493 =item $c->handler( $class, $r )
500 my ( $class, $engine ) = @_;
502 # Always expect worst case!
507 my $c = $class->prepare($engine);
508 $c->{stats} = \@stats;
512 if ( $class->debug ) {
514 ( $elapsed, $status ) = $class->benchmark($handler);
515 $elapsed = sprintf '%f', $elapsed;
516 my $av = sprintf '%.3f', 1 / $elapsed;
517 my $t = Text::ASCIITable->new;
518 $t->setCols( 'Action', 'Time' );
519 $t->setColWidth( 'Action', 64, 1 );
520 $t->setColWidth( 'Time', 9, 1 );
522 for my $stat (@stats) {
523 $t->addRow( wrap( $stat->[0], 64 ), wrap( $stat->[1], 9 ) );
525 $class->log->info( "Request took $elapsed" . "s ($av/s)",
528 else { $status = &$handler }
530 if ( my $error = $@ ) {
532 $class->log->error(qq/Caught exception in engine "$error"/);
538 =item $c->prepare($r)
540 Turns the engine-specific request( Apache, CGI ... )
541 into a Catalyst context .
546 my ( $class, $r ) = @_;
548 request => Catalyst::Request->new(
552 headers => HTTP::Headers->new,
558 response => Catalyst::Response->new(
559 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
565 my $secs = time - $START || 1;
566 my $av = sprintf '%.3f', $COUNT / $secs;
567 $c->log->debug('**********************************');
568 $c->log->debug("* Request $COUNT ($av/s) [$$]");
569 $c->log->debug('**********************************');
570 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
572 $c->prepare_request($r);
576 $c->prepare_connection;
577 my $method = $c->req->method || '';
578 my $path = $c->req->path || '';
579 my $hostname = $c->req->hostname || '';
580 my $address = $c->req->address || '';
581 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
584 $c->prepare_parameters;
586 if ( $c->debug && keys %{ $c->req->params } ) {
587 my $t = Text::ASCIITable->new;
588 $t->setCols( 'Key', 'Value' );
589 $t->setColWidth( 'Key', 37, 1 );
590 $t->setColWidth( 'Value', 36, 1 );
591 for my $key ( keys %{ $c->req->params } ) {
592 my $value = $c->req->params->{$key} || '';
593 $t->addRow( wrap( $key, 37 ), wrap( $value, 36 ) );
595 $c->log->debug( 'Parameters are', $t->draw );
601 =item $c->prepare_action
609 my $path = $c->req->path;
610 my @path = split /\//, $c->req->path;
611 $c->req->args( \my @args );
613 $path = join '/', @path;
614 if ( my $result = ${ $c->get_action($path) }[0] ) {
618 my $match = $result->[1];
619 my @snippets = @{ $result->[2] };
621 qq/Requested action is "$path" and matched "$match"/)
624 'Snippets are "' . join( ' ', @snippets ) . '"' )
625 if ( $c->debug && @snippets );
626 $c->req->action($match);
627 $c->req->snippets( \@snippets );
630 $c->req->action($path);
631 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
633 $c->req->match($path);
636 unshift @args, pop @path;
638 unless ( $c->req->action ) {
639 $c->req->action('default');
642 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
643 if ( $c->debug && @args );
646 =item $c->prepare_connection
652 sub prepare_connection { }
654 =item $c->prepare_cookies
660 sub prepare_cookies {
663 if ( my $header = $c->request->header('Cookie') ) {
664 $c->req->cookies( { CGI::Cookie->parse($header) } );
668 =item $c->prepare_headers
674 sub prepare_headers { }
676 =item $c->prepare_parameters
682 sub prepare_parameters { }
684 =item $c->prepare_path
686 Prepare path and base.
692 =item $c->prepare_request
694 Prepare the engine request.
698 sub prepare_request { }
700 =item $c->prepare_uploads
706 sub prepare_uploads { }
720 Returns a C<Catalyst::Request> object.
728 Returns a C<Catalyst::Response> object.
732 =item $c->set_action( $action, $code, $namespace, $attrs )
734 Set an action in a given namespace.
739 my ( $c, $method, $code, $namespace, $attrs ) = @_;
741 my $prefix = _class2prefix($namespace) || '';
744 for my $attr ( @{$attrs} ) {
745 if ( $attr =~ /^(Local|Relative)$/ ) { $flags{local}++ }
746 elsif ( $attr =~ /^(Global|Absolute)$/ ) { $flags{global}++ }
747 elsif ( $attr =~ /^Path\((.+)\)$/i ) { $flags{path} = $1 }
748 elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
749 elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
752 return unless keys %flags;
754 my $parent = $c->tree;
755 my $visitor = Tree::Simple::Visitor::FindByPath->new;
756 for my $part ( split '/', $prefix ) {
757 $visitor->setSearchPath($part);
758 $parent->accept($visitor);
759 my $child = $visitor->getResult;
761 $child = $parent->addChild( Tree::Simple->new($part) );
762 $visitor->setSearchPath($part);
763 $parent->accept($visitor);
764 $child = $visitor->getResult;
768 my $uid = $parent->getUID;
769 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
770 my $forward = $prefix ? "$prefix/$method" : $method;
772 if ( $flags{path} ) {
773 $flags{path} =~ s/^\w+//;
774 $flags{path} =~ s/\w+$//;
775 if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
776 if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
778 if ( $flags{regex} ) {
779 $flags{regex} =~ s/^\w+//;
780 $flags{regex} =~ s/\w+$//;
781 if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
782 if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
785 my $reverse = $prefix ? "$prefix/$method" : $method;
787 if ( $flags{local} || $flags{global} || $flags{path} ) {
788 my $path = $flags{path} || $method;
790 if ( $path =~ /^\/(.+)/ ) {
794 $absolute = 1 if $flags{global};
795 my $name = $absolute ? $path : "$prefix/$path";
796 $c->actions->{plain}->{$name} = [ $namespace, $code ];
798 if ( my $regex = $flags{regex} ) {
799 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
800 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
803 $c->actions->{reverse}->{"$code"} = $reverse;
816 $self->setup_components;
817 if ( $self->debug ) {
818 my $name = $self->config->{name} || 'Application';
819 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
823 =item $class->setup_actions($component)
825 Setup actions for a component.
830 my ( $self, $comp ) = @_;
831 $comp = ref $comp || $comp;
832 for my $action ( @{ $comp->_cache } ) {
833 my ( $code, $attrs ) = @{$action};
836 my @cache = ( $comp, @{"$comp\::ISA"} );
838 while ( my $namespace = shift @cache ) {
839 $namespaces{$namespace}++;
840 for my $isa ( @{"$comp\::ISA"} ) {
841 next if $namespaces{$isa};
846 for my $namespace ( keys %namespaces ) {
847 for my $sym ( values %{ $namespace . '::' } ) {
848 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
849 $name = *{$sym}{NAME};
850 $self->set_action( $name, $code, $comp, $attrs );
858 =item $class->setup_components
864 sub setup_components {
868 my $class = ref $self || $self;
871 import Module::Pluggable::Fast
872 name => '_components',
874 '$class\::Controller', '$class\::C',
875 '$class\::Model', '$class\::M',
876 '$class\::View', '$class\::V'
879 if ( my $error = $@ ) {
882 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
884 $self->setup_actions($self);
885 $self->components( {} );
886 for my $comp ( $self->_components($self) ) {
887 $self->components->{ ref $comp } = $comp;
888 $self->setup_actions($comp);
890 my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
891 $t->setCols('Class');
892 $t->setColWidth( 'Class', 75, 1 );
893 $t->addRow( wrap( $_, 75 ) ) for keys %{ $self->components };
894 $self->log->debug( 'Loaded components', $t->draw )
895 if ( @{ $t->{tbl_rows} } && $self->debug );
896 my $actions = $self->actions;
897 my $privates = Text::ASCIITable->new;
898 $privates->setCols( 'Private', 'Class', 'Code' );
899 $privates->setColWidth( 'Private', 28, 1 );
900 $privates->setColWidth( 'Class', 28, 1 );
901 $privates->setColWidth( 'Code', 14, 1 );
903 my ( $walker, $parent, $prefix ) = @_;
904 $prefix .= $parent->getNodeValue || '';
905 $prefix .= '/' unless $prefix =~ /\/$/;
906 my $uid = $parent->getUID;
907 for my $action ( keys %{ $actions->{private}->{$uid} } ) {
908 my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
910 wrap( "$prefix$action", 28 ),
915 $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
917 $walker->( $walker, $self->tree, '' );
918 $self->log->debug( 'Loaded private actions', $privates->draw )
919 if ( @{ $privates->{tbl_rows} } && $self->debug );
920 my $publics = Text::ASCIITable->new;
921 $publics->setCols( 'Public', 'Private' );
922 $publics->setColWidth( 'Public', 37, 1 );
923 $publics->setColWidth( 'Private', 36, 1 );
925 for my $plain ( sort keys %{ $actions->{plain} } ) {
926 my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
927 $publics->addRow( wrap( "/$plain", 37 ),
928 wrap( $self->actions->{reverse}->{$code} || $code, 36 ) );
930 $self->log->debug( 'Loaded public actions', $publics->draw )
931 if ( @{ $publics->{tbl_rows} } && $self->debug );
932 my $regexes = Text::ASCIITable->new;
933 $regexes->setCols( 'Regex', 'Private' );
934 $regexes->setColWidth( 'Regex', 37, 1 );
935 $regexes->setColWidth( 'Private', 36, 1 );
936 for my $regex ( sort keys %{ $actions->{regex} } ) {
937 my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
938 $regexes->addRow( wrap( $regex, 37 ),
939 wrap( $self->actions->{reverse}->{$class} || $class, 36 ) );
941 $self->log->debug( 'Loaded regex actions', $regexes->draw )
942 if ( @{ $regexes->{tbl_rows} } && $self->debug );
947 Contains the return value of the last executed action.
951 Returns a hashref containing all your data.
953 $c->stash->{foo} ||= 'yada';
954 print $c->stash->{foo};
961 my $stash = $_[1] ? {@_} : $_[0];
962 while ( my ( $key, $val ) = each %$stash ) {
963 $self->{stash}->{$key} = $val;
966 return $self->{stash};
970 my ( $class, $name ) = @_;
971 my $prefix = _class2prefix($class);
972 $name = "$prefix/$name" if $prefix;
977 my $class = shift || '';
979 if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
981 $prefix =~ s/\:\:/\//g;
990 Sebastian Riedel, C<sri@cpan.org>
994 This program is free software, you can redistribute it and/or modify it under
995 the same terms as Perl itself.