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 );
119 for my $begin ( @{ $c->get_action( 'begin', $namespace ) } ) {
120 $c->execute( @{ $begin->[0] } );
122 if ( my $action = $c->req->action ) {
123 for my $result ( @{ $c->get_action( $action, $default ) }[-1] ) {
124 $c->execute( @{ $result->[0] } );
125 last unless $default;
128 for my $end ( reverse @{ $c->get_action( 'end', $namespace ) } ) {
129 $c->execute( @{ $end->[0] } );
133 my $path = $c->req->path;
135 ? qq/Unknown resource "$path"/
136 : "No default action defined";
137 $c->log->error($error) if $c->debug;
144 =item $c->error($error, ...)
146 =item $c->error($arrayref)
148 Returns an arrayref containing error messages.
150 my @error = @{ $c->error };
154 $c->error('Something bad happened');
160 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
161 push @{ $c->{error} }, @$error;
165 =item $c->execute($class, $coderef)
167 Execute a coderef in given class and catch exceptions.
168 Errors are available via $c->error.
173 my ( $c, $class, $code ) = @_;
174 $class = $c->comp($class) || $class;
176 my $callsub = ( caller(1) )[3];
180 my $action = $c->actions->{reverse}->{"$code"};
181 $action = "/$action" unless $action =~ /\-\>/;
182 $action = "-> $action" if $callsub =~ /forward$/;
183 my ( $elapsed, @state ) =
184 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
185 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
188 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
190 if ( my $error = $@ ) {
192 $error = qq/Caught exception "$error"/;
193 $c->log->error($error);
194 $c->error($error) if $c->debug;
209 $c->finalize_cookies;
211 if ( my $location = $c->response->redirect ) {
212 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
213 $c->response->header( Location => $location );
214 $c->response->status(302) if $c->response->status !~ /3\d\d$/;
217 if ( $#{ $c->error } >= 0 ) {
221 if ( !$c->response->output && $c->response->status !~ /^(1|3)\d\d$/ ) {
225 if ( $c->response->output && !$c->response->content_length ) {
226 use bytes; # play safe with a utf8 aware perl
227 $c->response->content_length( length $c->response->output );
230 my $status = $c->finalize_headers;
235 =item $c->finalize_cookies
241 sub finalize_cookies {
244 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
245 my $cookie = CGI::Cookie->new(
247 -value => $cookie->{value},
248 -expires => $cookie->{expires},
249 -domain => $cookie->{domain},
250 -path => $cookie->{path},
251 -secure => $cookie->{secure} || 0
254 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
258 =item $c->finalize_error
267 $c->res->headers->content_type('text/html');
268 my $name = $c->config->{name} || 'Catalyst Application';
270 my ( $title, $error, $infos );
272 $error = join '<br/>', @{ $c->error };
273 $error ||= 'No output';
274 $title = $name = "$name on Catalyst $Catalyst::VERSION";
275 my $req = encode_entities Dumper $c->req;
276 my $res = encode_entities Dumper $c->res;
277 my $stash = encode_entities Dumper $c->stash;
280 <b><u>Request</u></b><br/>
282 <b><u>Response</u></b><br/>
284 <b><u>Stash</u></b><br/>
293 (en) Please come back later
294 (de) Bitte versuchen sie es spaeter nocheinmal
295 (nl) Gelieve te komen later terug
296 (no) Vennligst prov igjen senere
297 (fr) Veuillez revenir plus tard
298 (es) Vuelto por favor mas adelante
299 (pt) Voltado por favor mais tarde
300 (it) Ritornato prego piĆ¹ successivamente
305 $c->res->output( <<"" );
308 <title>$title</title>
309 <style type="text/css">
311 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
312 Tahoma, Arial, helvetica, sans-serif;
314 background-color: #eee;
319 background-color: #ccc;
320 border: 1px solid #aaa;
323 -moz-border-radius: 10px;
326 background-color: #977;
327 border: 1px solid #755;
331 -moz-border-radius: 10px;
334 background-color: #797;
335 border: 1px solid #575;
339 -moz-border-radius: 10px;
342 background-color: #779;
343 border: 1px solid #557;
346 -moz-border-radius: 10px;
352 <div class="error">$error</div>
353 <div class="infos">$infos</div>
354 <div class="name">$name</div>
361 =item $c->finalize_headers
367 sub finalize_headers { }
369 =item $c->finalize_output
375 sub finalize_output { }
377 =item $c->forward($command)
379 Forward processing to a private action or a method from a class.
380 If you define a class without method it will default to process().
383 $c->forward('index');
384 $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
385 $c->forward('MyApp::View::TT');
393 $c->log->debug('Nothing to forward to') if $c->debug;
396 my $caller = caller(0);
398 if ( $command =~ /^\// ) {
399 $command =~ /^(.*)\/(\w+)$/;
400 $namespace = $1 || '/';
403 else { $namespace = _class2prefix($caller) || '/' }
404 my $results = $c->get_action( $command, $namespace );
405 unless ( @{$results} ) {
406 my $class = $command;
407 if ( $class =~ /[^\w\:]/ ) {
408 $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
411 my $method = shift || 'process';
412 if ( my $code = $class->can($method) ) {
413 $c->actions->{reverse}->{"$code"} = "$class->$method";
414 $results = [ [ [ $class, $code ] ] ];
417 $c->log->debug(qq/Couldn't forward to "$class->$method"/)
422 for my $result ( @{$results} ) {
423 $c->execute( @{ $result->[0] } );
428 =item $c->get_action( $action, $namespace )
430 Get an action in a given namespace.
435 my ( $c, $action, $namespace ) = @_;
436 return [] unless $action;
439 $namespace = '' if $namespace eq '/';
440 my $parent = $c->tree;
442 my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
443 push @results, [$result] if $result;
444 my $visitor = Tree::Simple::Visitor::FindByPath->new;
445 for my $part ( split '/', $namespace ) {
446 $visitor->setSearchPath($part);
447 $parent->accept($visitor);
448 my $child = $visitor->getResult;
449 my $uid = $child->getUID if $child;
450 my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
451 push @results, [$match] if $match;
452 $parent = $child if $child;
456 elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
457 elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
459 for my $i ( 0 .. $#{ $c->actions->{compiled} } ) {
460 my $name = $c->actions->{compiled}->[$i]->[0];
461 my $regex = $c->actions->{compiled}->[$i]->[1];
462 if ( $action =~ $regex ) {
464 for my $i ( 1 .. 9 ) {
467 push @snippets, ${$i};
469 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
476 =item $c->handler( $class, $r )
483 my ( $class, $engine ) = @_;
485 # Always expect worst case!
490 my $c = $class->prepare($engine);
491 $c->{stats} = \@stats;
495 if ( $class->debug ) {
497 ( $elapsed, $status ) = $class->benchmark($handler);
498 $elapsed = sprintf '%f', $elapsed;
499 my $av = sprintf '%.3f', 1 / $elapsed;
500 my $t = Text::ASCIITable->new;
501 $t->setCols( 'Action', 'Time' );
502 $t->setColWidth( 'Action', 64, 1 );
503 $t->setColWidth( 'Time', 9, 1 );
505 for my $stat (@stats) {
506 $t->addRow( wrap( $stat->[0], 64 ), wrap( $stat->[1], 9 ) );
508 $class->log->info( "Request took $elapsed" . "s ($av/s)",
511 else { $status = &$handler }
513 if ( my $error = $@ ) {
515 $class->log->error(qq/Caught exception in engine "$error"/);
521 =item $c->prepare($r)
523 Turns the engine-specific request( Apache, CGI ... )
524 into a Catalyst context .
529 my ( $class, $r ) = @_;
531 request => Catalyst::Request->new(
535 headers => HTTP::Headers->new,
541 response => Catalyst::Response->new(
542 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
548 my $secs = time - $START || 1;
549 my $av = sprintf '%.3f', $COUNT / $secs;
550 $c->log->debug('**********************************');
551 $c->log->debug("* Request $COUNT ($av/s) [$$]");
552 $c->log->debug('**********************************');
553 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
555 $c->prepare_request($r);
559 $c->prepare_connection;
560 my $method = $c->req->method || '';
561 my $path = $c->req->path || '';
562 my $hostname = $c->req->hostname || '';
563 my $address = $c->req->address || '';
564 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
567 $c->prepare_parameters;
569 if ( $c->debug && keys %{ $c->req->params } ) {
570 my $t = Text::ASCIITable->new;
571 $t->setCols( 'Key', 'Value' );
572 $t->setColWidth( 'Key', 37, 1 );
573 $t->setColWidth( 'Value', 36, 1 );
574 for my $key ( keys %{ $c->req->params } ) {
575 my $value = $c->req->params->{$key} || '';
576 $t->addRow( wrap( $key, 37 ), wrap( $value, 36 ) );
578 $c->log->debug( 'Parameters are', $t->draw );
584 =item $c->prepare_action
592 my $path = $c->req->path;
593 my @path = split /\//, $c->req->path;
594 $c->req->args( \my @args );
596 $path = join '/', @path;
597 if ( my $result = ${ $c->get_action($path) }[0] ) {
601 my $match = $result->[1];
602 my @snippets = @{ $result->[2] };
604 qq/Requested action is "$path" and matched "$match"/)
607 'Snippets are "' . join( ' ', @snippets ) . '"' )
608 if ( $c->debug && @snippets );
609 $c->req->action($match);
610 $c->req->snippets( \@snippets );
613 $c->req->action($path);
614 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
616 $c->req->match($path);
619 unshift @args, pop @path;
621 unless ( $c->req->action ) {
622 $c->req->action('default');
625 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
626 if ( $c->debug && @args );
629 =item $c->prepare_connection
635 sub prepare_connection { }
637 =item $c->prepare_cookies
643 sub prepare_cookies {
646 if ( my $header = $c->request->header('Cookie') ) {
647 $c->req->cookies( { CGI::Cookie->parse($header) } );
651 =item $c->prepare_headers
657 sub prepare_headers { }
659 =item $c->prepare_parameters
665 sub prepare_parameters { }
667 =item $c->prepare_path
669 Prepare path and base.
675 =item $c->prepare_request
677 Prepare the engine request.
681 sub prepare_request { }
683 =item $c->prepare_uploads
689 sub prepare_uploads { }
703 Returns a C<Catalyst::Request> object.
711 Returns a C<Catalyst::Response> object.
715 =item $c->set_action( $action, $code, $namespace, $attrs )
717 Set an action in a given namespace.
722 my ( $c, $method, $code, $namespace, $attrs ) = @_;
724 my $prefix = _class2prefix($namespace) || '';
727 for my $attr ( @{$attrs} ) {
728 if ( $attr =~ /^(Local|Relative)$/ ) { $flags{local}++ }
729 elsif ( $attr =~ /^(Global|Absolute)$/ ) { $flags{global}++ }
730 elsif ( $attr =~ /^Path\((.+)\)$/i ) { $flags{path} = $1 }
731 elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
732 elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
735 return unless keys %flags;
737 my $parent = $c->tree;
738 my $visitor = Tree::Simple::Visitor::FindByPath->new;
739 for my $part ( split '/', $prefix ) {
740 $visitor->setSearchPath($part);
741 $parent->accept($visitor);
742 my $child = $visitor->getResult;
744 $child = $parent->addChild( Tree::Simple->new($part) );
745 $visitor->setSearchPath($part);
746 $parent->accept($visitor);
747 $child = $visitor->getResult;
751 my $uid = $parent->getUID;
752 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
753 my $forward = $prefix ? "$prefix/$method" : $method;
755 if ( $flags{path} ) {
756 $flags{path} =~ s/^\w+//;
757 $flags{path} =~ s/\w+$//;
758 if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
759 if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
761 if ( $flags{regex} ) {
762 $flags{regex} =~ s/^\w+//;
763 $flags{regex} =~ s/\w+$//;
764 if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
765 if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
768 my $reverse = $prefix ? "$prefix/$method" : $method;
770 if ( $flags{local} || $flags{global} || $flags{path} ) {
771 my $path = $flags{path} || $method;
773 if ( $path =~ /^\/(.+)/ ) {
777 $absolute = 1 if $flags{global};
778 my $name = $absolute ? $path : "$prefix/$path";
779 $c->actions->{plain}->{$name} = [ $namespace, $code ];
781 if ( my $regex = $flags{regex} ) {
782 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
783 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
786 $c->actions->{reverse}->{"$code"} = $reverse;
799 $self->setup_components;
800 if ( $self->debug ) {
801 my $name = $self->config->{name} || 'Application';
802 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
806 =item $class->setup_actions($component)
808 Setup actions for a component.
813 my ( $self, $comp ) = @_;
814 $comp = ref $comp || $comp;
815 for my $action ( @{ $comp->_cache } ) {
816 my ( $code, $attrs ) = @{$action};
819 my @cache = ( $comp, @{"$comp\::ISA"} );
821 while ( my $namespace = shift @cache ) {
822 $namespaces{$namespace}++;
823 for my $isa ( @{"$comp\::ISA"} ) {
824 next if $namespaces{$isa};
829 for my $namespace ( keys %namespaces ) {
830 for my $sym ( values %{ $namespace . '::' } ) {
831 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
832 $name = *{$sym}{NAME};
833 $self->set_action( $name, $code, $comp, $attrs );
841 =item $class->setup_components
847 sub setup_components {
851 my $class = ref $self || $self;
854 import Module::Pluggable::Fast
855 name => '_components',
857 '$class\::Controller', '$class\::C',
858 '$class\::Model', '$class\::M',
859 '$class\::View', '$class\::V'
862 if ( my $error = $@ ) {
865 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
867 $self->setup_actions($self);
868 $self->components( {} );
869 for my $comp ( $self->_components($self) ) {
870 $self->components->{ ref $comp } = $comp;
871 $self->setup_actions($comp);
873 my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
874 $t->setCols('Class');
875 $t->setColWidth( 'Class', 75, 1 );
876 $t->addRow( wrap( $_, 75 ) ) for keys %{ $self->components };
877 $self->log->debug( 'Loaded components', $t->draw )
878 if ( @{ $t->{tbl_rows} } && $self->debug );
879 my $actions = $self->actions;
880 my $privates = Text::ASCIITable->new;
881 $privates->setCols( 'Private', 'Class', 'Code' );
882 $privates->setColWidth( 'Private', 28, 1 );
883 $privates->setColWidth( 'Class', 28, 1 );
884 $privates->setColWidth( 'Code', 14, 1 );
886 my ( $walker, $parent, $prefix ) = @_;
887 $prefix .= $parent->getNodeValue || '';
888 $prefix .= '/' unless $prefix =~ /\/$/;
889 my $uid = $parent->getUID;
890 for my $action ( keys %{ $actions->{private}->{$uid} } ) {
891 my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
893 wrap( "$prefix$action", 28 ),
898 $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
900 $walker->( $walker, $self->tree, '' );
901 $self->log->debug( 'Loaded private actions', $privates->draw )
902 if ( @{ $privates->{tbl_rows} } && $self->debug );
903 my $publics = Text::ASCIITable->new;
904 $publics->setCols( 'Public', 'Private' );
905 $publics->setColWidth( 'Public', 37, 1 );
906 $publics->setColWidth( 'Private', 36, 1 );
908 for my $plain ( sort keys %{ $actions->{plain} } ) {
909 my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
910 $publics->addRow( wrap( "/$plain", 37 ),
911 wrap( $self->actions->{reverse}->{$code} || $code, 36 ) );
913 $self->log->debug( 'Loaded public actions', $publics->draw )
914 if ( @{ $publics->{tbl_rows} } && $self->debug );
915 my $regexes = Text::ASCIITable->new;
916 $regexes->setCols( 'Regex', 'Private' );
917 $regexes->setColWidth( 'Regex', 37, 1 );
918 $regexes->setColWidth( 'Private', 36, 1 );
919 for my $regex ( sort keys %{ $actions->{regex} } ) {
920 my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
921 $regexes->addRow( wrap( $regex, 37 ),
922 wrap( $self->actions->{reverse}->{$class} || $class, 36 ) );
924 $self->log->debug( 'Loaded regex actions', $regexes->draw )
925 if ( @{ $regexes->{tbl_rows} } && $self->debug );
930 Contains the return value of the last executed action.
934 Returns a hashref containing all your data.
936 $c->stash->{foo} ||= 'yada';
937 print $c->stash->{foo};
944 my $stash = $_[1] ? {@_} : $_[0];
945 while ( my ( $key, $val ) = each %$stash ) {
946 $self->{stash}->{$key} = $val;
949 return $self->{stash};
953 my ( $class, $name ) = @_;
954 my $prefix = _class2prefix($class);
955 $name = "$prefix/$name" if $prefix;
960 my $class = shift || '';
962 if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
964 $prefix =~ s/\:\:/\//g;
973 Sebastian Riedel, C<sri@cpan.org>
977 This program is free software, you can redistribute it and/or modify it under
978 the same terms as Perl itself.