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] } );
121 return if scalar @{$c->error};
122 last unless $c->state;
124 if ( my $action = @{ $c->get_action( $action, $default ) }[-1] ) {
125 $c->execute( @{ $action->[0] } );
126 return if scalar @{$c->error};
127 last unless $c->state;
129 for my $end ( reverse @{ $c->get_action( 'end', $namespace ) } ) {
130 $c->execute( @{ $end->[0] } );
131 return if scalar @{$c->error};
132 last unless $c->state;
136 my $path = $c->req->path;
138 ? qq/Unknown resource "$path"/
139 : "No default action defined";
140 $c->log->error($error) if $c->debug;
147 =item $c->error($error, ...)
149 =item $c->error($arrayref)
151 Returns an arrayref containing error messages.
153 my @error = @{ $c->error };
157 $c->error('Something bad happened');
163 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
164 push @{ $c->{error} }, @$error;
168 =item $c->execute($class, $coderef)
170 Execute a coderef in given class and catch exceptions.
171 Errors are available via $c->error.
176 my ( $c, $class, $code ) = @_;
177 $class = $c->comp($class) || $class;
179 my $callsub = ( caller(1) )[3];
183 my $action = $c->actions->{reverse}->{"$code"};
184 $action = "/$action" unless $action =~ /\-\>/;
185 $action = "-> $action" if $callsub =~ /forward$/;
186 my ( $elapsed, @state ) =
187 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
188 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
191 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
193 if ( my $error = $@ ) {
195 $error = qq/Caught exception "$error"/;
196 $c->log->error($error);
212 $c->finalize_cookies;
214 if ( my $location = $c->response->redirect ) {
215 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
216 $c->response->header( Location => $location );
217 $c->response->status(302) if $c->response->status !~ /3\d\d$/;
220 if ( $#{ $c->error } >= 0 ) {
224 if ( !$c->response->output && $c->response->status !~ /^(1|3)\d\d$/ ) {
228 if ( $c->response->output && !$c->response->content_length ) {
229 use bytes; # play safe with a utf8 aware perl
230 $c->response->content_length( length $c->response->output );
233 my $status = $c->finalize_headers;
238 =item $c->finalize_cookies
244 sub finalize_cookies {
247 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
248 my $cookie = CGI::Cookie->new(
250 -value => $cookie->{value},
251 -expires => $cookie->{expires},
252 -domain => $cookie->{domain},
253 -path => $cookie->{path},
254 -secure => $cookie->{secure} || 0
257 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
261 =item $c->finalize_error
270 $c->res->headers->content_type('text/html');
271 my $name = $c->config->{name} || 'Catalyst Application';
273 my ( $title, $error, $infos );
275 $error = join '<br/>', @{ $c->error };
276 $error ||= 'No output';
277 $title = $name = "$name on Catalyst $Catalyst::VERSION";
278 my $req = encode_entities Dumper $c->req;
279 my $res = encode_entities Dumper $c->res;
280 my $stash = encode_entities Dumper $c->stash;
283 <b><u>Request</u></b><br/>
285 <b><u>Response</u></b><br/>
287 <b><u>Stash</u></b><br/>
296 (en) Please come back later
297 (de) Bitte versuchen sie es spaeter nocheinmal
298 (nl) Gelieve te komen later terug
299 (no) Vennligst prov igjen senere
300 (fr) Veuillez revenir plus tard
301 (es) Vuelto por favor mas adelante
302 (pt) Voltado por favor mais tarde
303 (it) Ritornato prego piĆ¹ successivamente
308 $c->res->output( <<"" );
311 <title>$title</title>
312 <style type="text/css">
314 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
315 Tahoma, Arial, helvetica, sans-serif;
317 background-color: #eee;
322 background-color: #ccc;
323 border: 1px solid #aaa;
326 -moz-border-radius: 10px;
329 background-color: #977;
330 border: 1px solid #755;
334 -moz-border-radius: 10px;
337 background-color: #797;
338 border: 1px solid #575;
342 -moz-border-radius: 10px;
345 background-color: #779;
346 border: 1px solid #557;
349 -moz-border-radius: 10px;
355 <div class="error">$error</div>
356 <div class="infos">$infos</div>
357 <div class="name">$name</div>
364 =item $c->finalize_headers
370 sub finalize_headers { }
372 =item $c->finalize_output
378 sub finalize_output { }
380 =item $c->forward($command)
382 Forward processing to a private action or a method from a class.
383 If you define a class without method it will default to process().
386 $c->forward('index');
387 $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
388 $c->forward('MyApp::View::TT');
396 $c->log->debug('Nothing to forward to') if $c->debug;
399 my $caller = caller(0);
401 if ( $command =~ /^\// ) {
402 $command =~ /^(.*)\/(\w+)$/;
403 $namespace = $1 || '/';
406 else { $namespace = _class2prefix($caller) || '/' }
407 my $results = $c->get_action( $command, $namespace );
408 unless ( @{$results} ) {
409 my $class = $command;
410 if ( $class =~ /[^\w\:]/ ) {
411 $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
414 my $method = shift || 'process';
415 if ( my $code = $class->can($method) ) {
416 $c->actions->{reverse}->{"$code"} = "$class->$method";
417 $results = [ [ [ $class, $code ] ] ];
420 $c->log->debug(qq/Couldn't forward to "$class->$method"/)
425 for my $result ( @{$results} ) {
426 $c->execute( @{ $result->[0] } );
431 =item $c->get_action( $action, $namespace )
433 Get an action in a given namespace.
438 my ( $c, $action, $namespace ) = @_;
439 return [] unless $action;
442 $namespace = '' if $namespace eq '/';
443 my $parent = $c->tree;
445 my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
446 push @results, [$result] if $result;
447 my $visitor = Tree::Simple::Visitor::FindByPath->new;
448 for my $part ( split '/', $namespace ) {
449 $visitor->setSearchPath($part);
450 $parent->accept($visitor);
451 my $child = $visitor->getResult;
452 my $uid = $child->getUID if $child;
453 my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
454 push @results, [$match] if $match;
455 $parent = $child if $child;
459 elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
460 elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
462 for my $i ( 0 .. $#{ $c->actions->{compiled} } ) {
463 my $name = $c->actions->{compiled}->[$i]->[0];
464 my $regex = $c->actions->{compiled}->[$i]->[1];
465 if ( $action =~ $regex ) {
467 for my $i ( 1 .. 9 ) {
470 push @snippets, ${$i};
472 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
479 =item $c->handler( $class, $r )
486 my ( $class, $engine ) = @_;
488 # Always expect worst case!
493 my $c = $class->prepare($engine);
494 $c->{stats} = \@stats;
498 if ( $class->debug ) {
500 ( $elapsed, $status ) = $class->benchmark($handler);
501 $elapsed = sprintf '%f', $elapsed;
502 my $av = sprintf '%.3f', 1 / $elapsed;
503 my $t = Text::ASCIITable->new;
504 $t->setCols( 'Action', 'Time' );
505 $t->setColWidth( 'Action', 64, 1 );
506 $t->setColWidth( 'Time', 9, 1 );
508 for my $stat (@stats) {
509 $t->addRow( wrap( $stat->[0], 64 ), wrap( $stat->[1], 9 ) );
511 $class->log->info( "Request took $elapsed" . "s ($av/s)",
514 else { $status = &$handler }
516 if ( my $error = $@ ) {
518 $class->log->error(qq/Caught exception in engine "$error"/);
524 =item $c->prepare($r)
526 Turns the engine-specific request( Apache, CGI ... )
527 into a Catalyst context .
532 my ( $class, $r ) = @_;
534 request => Catalyst::Request->new(
538 headers => HTTP::Headers->new,
544 response => Catalyst::Response->new(
545 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
551 my $secs = time - $START || 1;
552 my $av = sprintf '%.3f', $COUNT / $secs;
553 $c->log->debug('**********************************');
554 $c->log->debug("* Request $COUNT ($av/s) [$$]");
555 $c->log->debug('**********************************');
556 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
558 $c->prepare_request($r);
562 $c->prepare_connection;
563 my $method = $c->req->method || '';
564 my $path = $c->req->path || '';
565 my $hostname = $c->req->hostname || '';
566 my $address = $c->req->address || '';
567 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
570 $c->prepare_parameters;
572 if ( $c->debug && keys %{ $c->req->params } ) {
573 my $t = Text::ASCIITable->new;
574 $t->setCols( 'Key', 'Value' );
575 $t->setColWidth( 'Key', 37, 1 );
576 $t->setColWidth( 'Value', 36, 1 );
577 for my $key ( keys %{ $c->req->params } ) {
578 my $value = $c->req->params->{$key} || '';
579 $t->addRow( wrap( $key, 37 ), wrap( $value, 36 ) );
581 $c->log->debug( 'Parameters are', $t->draw );
587 =item $c->prepare_action
595 my $path = $c->req->path;
596 my @path = split /\//, $c->req->path;
597 $c->req->args( \my @args );
599 $path = join '/', @path;
600 if ( my $result = ${ $c->get_action($path) }[0] ) {
604 my $match = $result->[1];
605 my @snippets = @{ $result->[2] };
607 qq/Requested action is "$path" and matched "$match"/)
610 'Snippets are "' . join( ' ', @snippets ) . '"' )
611 if ( $c->debug && @snippets );
612 $c->req->action($match);
613 $c->req->snippets( \@snippets );
616 $c->req->action($path);
617 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
619 $c->req->match($path);
622 unshift @args, pop @path;
624 unless ( $c->req->action ) {
625 $c->req->action('default');
628 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
629 if ( $c->debug && @args );
632 =item $c->prepare_connection
638 sub prepare_connection { }
640 =item $c->prepare_cookies
646 sub prepare_cookies {
649 if ( my $header = $c->request->header('Cookie') ) {
650 $c->req->cookies( { CGI::Cookie->parse($header) } );
654 =item $c->prepare_headers
660 sub prepare_headers { }
662 =item $c->prepare_parameters
668 sub prepare_parameters { }
670 =item $c->prepare_path
672 Prepare path and base.
678 =item $c->prepare_request
680 Prepare the engine request.
684 sub prepare_request { }
686 =item $c->prepare_uploads
692 sub prepare_uploads { }
706 Returns a C<Catalyst::Request> object.
714 Returns a C<Catalyst::Response> object.
718 =item $c->set_action( $action, $code, $namespace, $attrs )
720 Set an action in a given namespace.
725 my ( $c, $method, $code, $namespace, $attrs ) = @_;
727 my $prefix = _class2prefix($namespace) || '';
730 for my $attr ( @{$attrs} ) {
731 if ( $attr =~ /^(Local|Relative)$/ ) { $flags{local}++ }
732 elsif ( $attr =~ /^(Global|Absolute)$/ ) { $flags{global}++ }
733 elsif ( $attr =~ /^Path\((.+)\)$/i ) { $flags{path} = $1 }
734 elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
735 elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
738 return unless keys %flags;
740 my $parent = $c->tree;
741 my $visitor = Tree::Simple::Visitor::FindByPath->new;
742 for my $part ( split '/', $prefix ) {
743 $visitor->setSearchPath($part);
744 $parent->accept($visitor);
745 my $child = $visitor->getResult;
747 $child = $parent->addChild( Tree::Simple->new($part) );
748 $visitor->setSearchPath($part);
749 $parent->accept($visitor);
750 $child = $visitor->getResult;
754 my $uid = $parent->getUID;
755 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
756 my $forward = $prefix ? "$prefix/$method" : $method;
758 if ( $flags{path} ) {
759 $flags{path} =~ s/^\w+//;
760 $flags{path} =~ s/\w+$//;
761 if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
762 if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
764 if ( $flags{regex} ) {
765 $flags{regex} =~ s/^\w+//;
766 $flags{regex} =~ s/\w+$//;
767 if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
768 if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
771 my $reverse = $prefix ? "$prefix/$method" : $method;
773 if ( $flags{local} || $flags{global} || $flags{path} ) {
774 my $path = $flags{path} || $method;
776 if ( $path =~ /^\/(.+)/ ) {
780 $absolute = 1 if $flags{global};
781 my $name = $absolute ? $path : "$prefix/$path";
782 $c->actions->{plain}->{$name} = [ $namespace, $code ];
784 if ( my $regex = $flags{regex} ) {
785 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
786 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
789 $c->actions->{reverse}->{"$code"} = $reverse;
802 $self->setup_components;
803 if ( $self->debug ) {
804 my $name = $self->config->{name} || 'Application';
805 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
809 =item $class->setup_actions($component)
811 Setup actions for a component.
816 my ( $self, $comp ) = @_;
817 $comp = ref $comp || $comp;
818 for my $action ( @{ $comp->_cache } ) {
819 my ( $code, $attrs ) = @{$action};
822 my @cache = ( $comp, @{"$comp\::ISA"} );
824 while ( my $namespace = shift @cache ) {
825 $namespaces{$namespace}++;
826 for my $isa ( @{"$comp\::ISA"} ) {
827 next if $namespaces{$isa};
832 for my $namespace ( keys %namespaces ) {
833 for my $sym ( values %{ $namespace . '::' } ) {
834 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
835 $name = *{$sym}{NAME};
836 $self->set_action( $name, $code, $comp, $attrs );
844 =item $class->setup_components
850 sub setup_components {
854 my $class = ref $self || $self;
857 import Module::Pluggable::Fast
858 name => '_components',
860 '$class\::Controller', '$class\::C',
861 '$class\::Model', '$class\::M',
862 '$class\::View', '$class\::V'
865 if ( my $error = $@ ) {
868 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
870 $self->setup_actions($self);
871 $self->components( {} );
872 for my $comp ( $self->_components($self) ) {
873 $self->components->{ ref $comp } = $comp;
874 $self->setup_actions($comp);
876 my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
877 $t->setCols('Class');
878 $t->setColWidth( 'Class', 75, 1 );
879 $t->addRow( wrap( $_, 75 ) ) for keys %{ $self->components };
880 $self->log->debug( 'Loaded components', $t->draw )
881 if ( @{ $t->{tbl_rows} } && $self->debug );
882 my $actions = $self->actions;
883 my $privates = Text::ASCIITable->new;
884 $privates->setCols( 'Private', 'Class', 'Code' );
885 $privates->setColWidth( 'Private', 28, 1 );
886 $privates->setColWidth( 'Class', 28, 1 );
887 $privates->setColWidth( 'Code', 14, 1 );
889 my ( $walker, $parent, $prefix ) = @_;
890 $prefix .= $parent->getNodeValue || '';
891 $prefix .= '/' unless $prefix =~ /\/$/;
892 my $uid = $parent->getUID;
893 for my $action ( keys %{ $actions->{private}->{$uid} } ) {
894 my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
896 wrap( "$prefix$action", 28 ),
901 $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
903 $walker->( $walker, $self->tree, '' );
904 $self->log->debug( 'Loaded private actions', $privates->draw )
905 if ( @{ $privates->{tbl_rows} } && $self->debug );
906 my $publics = Text::ASCIITable->new;
907 $publics->setCols( 'Public', 'Private' );
908 $publics->setColWidth( 'Public', 37, 1 );
909 $publics->setColWidth( 'Private', 36, 1 );
911 for my $plain ( sort keys %{ $actions->{plain} } ) {
912 my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
913 $publics->addRow( wrap( "/$plain", 37 ),
914 wrap( $self->actions->{reverse}->{$code} || $code, 36 ) );
916 $self->log->debug( 'Loaded public actions', $publics->draw )
917 if ( @{ $publics->{tbl_rows} } && $self->debug );
918 my $regexes = Text::ASCIITable->new;
919 $regexes->setCols( 'Regex', 'Private' );
920 $regexes->setColWidth( 'Regex', 37, 1 );
921 $regexes->setColWidth( 'Private', 36, 1 );
922 for my $regex ( sort keys %{ $actions->{regex} } ) {
923 my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
924 $regexes->addRow( wrap( $regex, 37 ),
925 wrap( $self->actions->{reverse}->{$class} || $class, 36 ) );
927 $self->log->debug( 'Loaded regex actions', $regexes->draw )
928 if ( @{ $regexes->{tbl_rows} } && $self->debug );
933 Contains the return value of the last executed action.
937 Returns a hashref containing all your data.
939 $c->stash->{foo} ||= 'yada';
940 print $c->stash->{foo};
947 my $stash = $_[1] ? {@_} : $_[0];
948 while ( my ( $key, $val ) = each %$stash ) {
949 $self->{stash}->{$key} = $val;
952 return $self->{stash};
956 my ( $class, $name ) = @_;
957 my $prefix = _class2prefix($class);
958 $name = "$prefix/$name" if $prefix;
963 my $class = shift || '';
965 if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
967 $prefix =~ s/\:\:/\//g;
976 Sebastian Riedel, C<sri@cpan.org>
980 This program is free software, you can redistribute it and/or modify it under
981 the same terms as Perl itself.