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 };
127 # Execute the auto chain
128 for my $auto ( @{ $c->get_action( 'auto', $namespace ) } ) {
129 $c->execute( @{ $auto->[0] } );
130 return if scalar @{ $c->error };
131 last unless $c->state;
134 # Execute the action or last default
135 if ( ( my $action = $c->req->action ) && $c->state ) {
136 if ( my $result = @{ $c->get_action( $action, $default ) }[-1] ) {
137 $c->execute( @{ $result->[0] } );
142 if ( my $end = @{ $c->get_action( 'end', $namespace ) }[-1] ) {
143 $c->execute( @{ $end->[0] } );
144 return if scalar @{ $c->error };
148 my $path = $c->req->path;
150 ? qq/Unknown resource "$path"/
151 : "No default action defined";
152 $c->log->error($error) if $c->debug;
159 =item $c->error($error, ...)
161 =item $c->error($arrayref)
163 Returns an arrayref containing error messages.
165 my @error = @{ $c->error };
169 $c->error('Something bad happened');
175 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
176 push @{ $c->{error} }, @$error;
180 =item $c->execute($class, $coderef)
182 Execute a coderef in given class and catch exceptions.
183 Errors are available via $c->error.
188 my ( $c, $class, $code ) = @_;
189 $class = $c->comp($class) || $class;
191 my $callsub = ( caller(1) )[3];
195 my $action = $c->actions->{reverse}->{"$code"};
196 $action = "/$action" unless $action =~ /\-\>/;
197 $action = "-> $action" if $callsub =~ /forward$/;
198 my ( $elapsed, @state ) =
199 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
200 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
203 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
205 if ( my $error = $@ ) {
207 unless ( ref $error ) {
209 $error = qq/Caught exception "$error"/;
212 $c->log->error($error);
228 $c->finalize_cookies;
230 if ( my $location = $c->response->redirect ) {
231 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
232 $c->response->header( Location => $location );
233 $c->response->status(302) if $c->response->status !~ /3\d\d$/;
236 if ( $#{ $c->error } >= 0 ) {
240 if ( !$c->response->output && $c->response->status !~ /^(1|3)\d\d$/ ) {
244 if ( $c->response->output && !$c->response->content_length ) {
245 use bytes; # play safe with a utf8 aware perl
246 $c->response->content_length( length $c->response->output );
249 my $status = $c->finalize_headers;
254 =item $c->finalize_cookies
260 sub finalize_cookies {
263 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
264 my $cookie = CGI::Cookie->new(
266 -value => $cookie->{value},
267 -expires => $cookie->{expires},
268 -domain => $cookie->{domain},
269 -path => $cookie->{path},
270 -secure => $cookie->{secure} || 0
273 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
277 =item $c->finalize_error
286 $c->res->headers->content_type('text/html');
287 my $name = $c->config->{name} || 'Catalyst Application';
289 my ( $title, $error, $infos );
291 $error = join '<br/>', @{ $c->error };
292 $error ||= 'No output';
293 $title = $name = "$name on Catalyst $Catalyst::VERSION";
294 my $req = encode_entities Dumper $c->req;
295 my $res = encode_entities Dumper $c->res;
296 my $stash = encode_entities Dumper $c->stash;
299 <b><u>Request</u></b><br/>
301 <b><u>Response</u></b><br/>
303 <b><u>Stash</u></b><br/>
312 (en) Please come back later
313 (de) Bitte versuchen sie es spaeter nocheinmal
314 (nl) Gelieve te komen later terug
315 (no) Vennligst prov igjen senere
316 (fr) Veuillez revenir plus tard
317 (es) Vuelto por favor mas adelante
318 (pt) Voltado por favor mais tarde
319 (it) Ritornato prego piĆ¹ successivamente
324 $c->res->output( <<"" );
327 <title>$title</title>
328 <style type="text/css">
330 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
331 Tahoma, Arial, helvetica, sans-serif;
333 background-color: #eee;
338 background-color: #ccc;
339 border: 1px solid #aaa;
342 -moz-border-radius: 10px;
345 background-color: #977;
346 border: 1px solid #755;
350 -moz-border-radius: 10px;
353 background-color: #797;
354 border: 1px solid #575;
358 -moz-border-radius: 10px;
361 background-color: #779;
362 border: 1px solid #557;
365 -moz-border-radius: 10px;
371 <div class="error">$error</div>
372 <div class="infos">$infos</div>
373 <div class="name">$name</div>
380 =item $c->finalize_headers
386 sub finalize_headers { }
388 =item $c->finalize_output
394 sub finalize_output { }
396 =item $c->forward($command)
398 Forward processing to a private action or a method from a class.
399 If you define a class without method it will default to process().
402 $c->forward('index');
403 $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
404 $c->forward('MyApp::View::TT');
412 $c->log->debug('Nothing to forward to') if $c->debug;
415 my $caller = caller(0);
417 if ( $command =~ /^\// ) {
418 $command =~ /^(.*)\/(\w+)$/;
419 $namespace = $1 || '/';
422 else { $namespace = _class2prefix($caller) || '/' }
423 my $results = $c->get_action( $command, $namespace );
424 unless ( @{$results} ) {
425 my $class = $command;
426 if ( $class =~ /[^\w\:]/ ) {
427 $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
430 my $method = shift || 'process';
431 if ( my $code = $class->can($method) ) {
432 $c->actions->{reverse}->{"$code"} = "$class->$method";
433 $results = [ [ [ $class, $code ] ] ];
436 $c->log->debug(qq/Couldn't forward to "$class->$method"/)
441 for my $result ( @{$results} ) {
442 $c->execute( @{ $result->[0] } );
443 return if scalar @{ $c->error };
444 last unless $c->state;
449 =item $c->get_action( $action, $namespace )
451 Get an action in a given namespace.
456 my ( $c, $action, $namespace ) = @_;
457 return [] unless $action;
460 $namespace = '' if $namespace eq '/';
461 my $parent = $c->tree;
463 my %allowed = ( begin => 1, auto => 1, default => 1, end => 1 );
464 if ( $allowed{$action} ) {
465 my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
466 push @results, [$result] if $result;
467 my $visitor = Tree::Simple::Visitor::FindByPath->new;
468 for my $part ( split '/', $namespace ) {
469 $visitor->setSearchPath($part);
470 $parent->accept($visitor);
471 my $child = $visitor->getResult;
472 my $uid = $child->getUID if $child;
473 my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
474 push @results, [$match] if $match;
475 $parent = $child if $child;
480 my $visitor = Tree::Simple::Visitor::FindByPath->new;
481 $visitor->setSearchPath( split '/', $namespace );
482 $parent->accept($visitor);
483 my $child = $visitor->getResult;
484 my $uid = $child->getUID if $child;
485 my $match = $c->actions->{private}->{$uid}->{$action}
487 push @results, [$match] if $match;
491 $c->actions->{private}->{ $parent->getUID }->{$action};
492 push @results, [$result] if $result;
497 elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
498 elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
500 for my $i ( 0 .. $#{ $c->actions->{compiled} } ) {
501 my $name = $c->actions->{compiled}->[$i]->[0];
502 my $regex = $c->actions->{compiled}->[$i]->[1];
503 if ( $action =~ $regex ) {
505 for my $i ( 1 .. 9 ) {
508 push @snippets, ${$i};
510 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
517 =item $c->handler( $class, $r )
524 my ( $class, $engine ) = @_;
526 # Always expect worst case!
531 my $c = $class->prepare($engine);
532 $c->{stats} = \@stats;
536 if ( $class->debug ) {
538 ( $elapsed, $status ) = $class->benchmark($handler);
539 $elapsed = sprintf '%f', $elapsed;
540 my $av = sprintf '%.3f', 1 / $elapsed;
541 my $t = Text::ASCIITable->new;
542 $t->setCols( 'Action', 'Time' );
543 $t->setColWidth( 'Action', 64, 1 );
544 $t->setColWidth( 'Time', 9, 1 );
546 for my $stat (@stats) {
547 $t->addRow( wrap( $stat->[0], 64 ), wrap( $stat->[1], 9 ) );
549 $class->log->info( "Request took $elapsed" . "s ($av/s)",
552 else { $status = &$handler }
554 if ( my $error = $@ ) {
556 $class->log->error(qq/Caught exception in engine "$error"/);
562 =item $c->prepare($r)
564 Turns the engine-specific request( Apache, CGI ... )
565 into a Catalyst context .
570 my ( $class, $r ) = @_;
572 request => Catalyst::Request->new(
576 headers => HTTP::Headers->new,
582 response => Catalyst::Response->new(
583 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
589 my $secs = time - $START || 1;
590 my $av = sprintf '%.3f', $COUNT / $secs;
591 $c->log->debug('**********************************');
592 $c->log->debug("* Request $COUNT ($av/s) [$$]");
593 $c->log->debug('**********************************');
594 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
596 $c->prepare_request($r);
600 $c->prepare_connection;
601 my $method = $c->req->method || '';
602 my $path = $c->req->path || '';
603 my $hostname = $c->req->hostname || '';
604 my $address = $c->req->address || '';
605 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
608 $c->prepare_parameters;
610 if ( $c->debug && keys %{ $c->req->params } ) {
611 my $t = Text::ASCIITable->new;
612 $t->setCols( 'Key', 'Value' );
613 $t->setColWidth( 'Key', 37, 1 );
614 $t->setColWidth( 'Value', 36, 1 );
615 for my $key ( keys %{ $c->req->params } ) {
616 my $value = $c->req->params->{$key} || '';
617 $t->addRow( wrap( $key, 37 ), wrap( $value, 36 ) );
619 $c->log->debug( 'Parameters are', $t->draw );
625 =item $c->prepare_action
633 my $path = $c->req->path;
634 my @path = split /\//, $c->req->path;
635 $c->req->args( \my @args );
637 $path = join '/', @path;
638 if ( my $result = ${ $c->get_action($path) }[0] ) {
642 my $match = $result->[1];
643 my @snippets = @{ $result->[2] };
645 qq/Requested action is "$path" and matched "$match"/)
648 'Snippets are "' . join( ' ', @snippets ) . '"' )
649 if ( $c->debug && @snippets );
650 $c->req->action($match);
651 $c->req->snippets( \@snippets );
654 $c->req->action($path);
655 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
657 $c->req->match($path);
660 unshift @args, pop @path;
662 unless ( $c->req->action ) {
663 $c->req->action('default');
666 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
667 if ( $c->debug && @args );
670 =item $c->prepare_connection
676 sub prepare_connection { }
678 =item $c->prepare_cookies
684 sub prepare_cookies {
687 if ( my $header = $c->request->header('Cookie') ) {
688 $c->req->cookies( { CGI::Cookie->parse($header) } );
692 =item $c->prepare_headers
698 sub prepare_headers { }
700 =item $c->prepare_parameters
706 sub prepare_parameters { }
708 =item $c->prepare_path
710 Prepare path and base.
716 =item $c->prepare_request
718 Prepare the engine request.
722 sub prepare_request { }
724 =item $c->prepare_uploads
730 sub prepare_uploads { }
744 Returns a C<Catalyst::Request> object.
752 Returns a C<Catalyst::Response> object.
756 =item $c->set_action( $action, $code, $namespace, $attrs )
758 Set an action in a given namespace.
763 my ( $c, $method, $code, $namespace, $attrs ) = @_;
765 my $prefix = _class2prefix($namespace) || '';
768 for my $attr ( @{$attrs} ) {
769 if ( $attr =~ /^(Local|Relative)$/ ) { $flags{local}++ }
770 elsif ( $attr =~ /^(Global|Absolute)$/ ) { $flags{global}++ }
771 elsif ( $attr =~ /^Path\((.+)\)$/i ) { $flags{path} = $1 }
772 elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
773 elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
776 return unless keys %flags;
778 my $parent = $c->tree;
779 my $visitor = Tree::Simple::Visitor::FindByPath->new;
780 for my $part ( split '/', $prefix ) {
781 $visitor->setSearchPath($part);
782 $parent->accept($visitor);
783 my $child = $visitor->getResult;
785 $child = $parent->addChild( Tree::Simple->new($part) );
786 $visitor->setSearchPath($part);
787 $parent->accept($visitor);
788 $child = $visitor->getResult;
792 my $uid = $parent->getUID;
793 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
794 my $forward = $prefix ? "$prefix/$method" : $method;
796 if ( $flags{path} ) {
797 $flags{path} =~ s/^\w+//;
798 $flags{path} =~ s/\w+$//;
799 if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
800 if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
802 if ( $flags{regex} ) {
803 $flags{regex} =~ s/^\w+//;
804 $flags{regex} =~ s/\w+$//;
805 if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
806 if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
809 my $reverse = $prefix ? "$prefix/$method" : $method;
811 if ( $flags{local} || $flags{global} || $flags{path} ) {
812 my $path = $flags{path} || $method;
814 if ( $path =~ /^\/(.+)/ ) {
818 $absolute = 1 if $flags{global};
819 my $name = $absolute ? $path : $prefix ? "$prefix/$path" : $path;
820 $c->actions->{plain}->{$name} = [ $namespace, $code ];
822 if ( my $regex = $flags{regex} ) {
823 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
824 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
827 $c->actions->{reverse}->{"$code"} = $reverse;
840 $self->setup_components;
841 if ( $self->debug ) {
842 my $name = $self->config->{name} || 'Application';
843 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
847 =item $class->setup_actions($component)
849 Setup actions for a component.
854 my ( $self, $comp ) = @_;
855 $comp = ref $comp || $comp;
856 for my $action ( @{ $comp->_cache } ) {
857 my ( $code, $attrs ) = @{$action};
860 my @cache = ( $comp, @{"$comp\::ISA"} );
862 while ( my $namespace = shift @cache ) {
863 $namespaces{$namespace}++;
864 for my $isa ( @{"$comp\::ISA"} ) {
865 next if $namespaces{$isa};
870 for my $namespace ( keys %namespaces ) {
871 for my $sym ( values %{ $namespace . '::' } ) {
872 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
873 $name = *{$sym}{NAME};
874 $self->set_action( $name, $code, $comp, $attrs );
882 =item $class->setup_components
888 sub setup_components {
892 my $class = ref $self || $self;
895 import Module::Pluggable::Fast
896 name => '_components',
898 '$class\::Controller', '$class\::C',
899 '$class\::Model', '$class\::M',
900 '$class\::View', '$class\::V'
903 if ( my $error = $@ ) {
906 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
908 $self->setup_actions($self);
909 $self->components( {} );
910 for my $comp ( $self->_components($self) ) {
911 $self->components->{ ref $comp } = $comp;
912 $self->setup_actions($comp);
914 my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
915 $t->setCols('Class');
916 $t->setColWidth( 'Class', 75, 1 );
917 $t->addRow( wrap( $_, 75 ) ) for keys %{ $self->components };
918 $self->log->debug( 'Loaded components', $t->draw )
919 if ( @{ $t->{tbl_rows} } && $self->debug );
920 my $actions = $self->actions;
921 my $privates = Text::ASCIITable->new;
922 $privates->setCols( 'Private', 'Class', 'Code' );
923 $privates->setColWidth( 'Private', 28, 1 );
924 $privates->setColWidth( 'Class', 28, 1 );
925 $privates->setColWidth( 'Code', 14, 1 );
927 my ( $walker, $parent, $prefix ) = @_;
928 $prefix .= $parent->getNodeValue || '';
929 $prefix .= '/' unless $prefix =~ /\/$/;
930 my $uid = $parent->getUID;
931 for my $action ( keys %{ $actions->{private}->{$uid} } ) {
932 my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
934 wrap( "$prefix$action", 28 ),
939 $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
941 $walker->( $walker, $self->tree, '' );
942 $self->log->debug( 'Loaded private actions', $privates->draw )
943 if ( @{ $privates->{tbl_rows} } && $self->debug );
944 my $publics = Text::ASCIITable->new;
945 $publics->setCols( 'Public', 'Private' );
946 $publics->setColWidth( 'Public', 37, 1 );
947 $publics->setColWidth( 'Private', 36, 1 );
949 for my $plain ( sort keys %{ $actions->{plain} } ) {
950 my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
951 $publics->addRow( wrap( "/$plain", 37 ),
952 wrap( $self->actions->{reverse}->{$code} || $code, 36 ) );
954 $self->log->debug( 'Loaded public actions', $publics->draw )
955 if ( @{ $publics->{tbl_rows} } && $self->debug );
956 my $regexes = Text::ASCIITable->new;
957 $regexes->setCols( 'Regex', 'Private' );
958 $regexes->setColWidth( 'Regex', 37, 1 );
959 $regexes->setColWidth( 'Private', 36, 1 );
960 for my $regex ( sort keys %{ $actions->{regex} } ) {
961 my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
962 $regexes->addRow( wrap( $regex, 37 ),
963 wrap( $self->actions->{reverse}->{$class} || $class, 36 ) );
965 $self->log->debug( 'Loaded regex actions', $regexes->draw )
966 if ( @{ $regexes->{tbl_rows} } && $self->debug );
971 Contains the return value of the last executed action.
975 Returns a hashref containing all your data.
977 $c->stash->{foo} ||= 'yada';
978 print $c->stash->{foo};
985 my $stash = $_[1] ? {@_} : $_[0];
986 while ( my ( $key, $val ) = each %$stash ) {
987 $self->{stash}->{$key} = $val;
990 return $self->{stash};
994 my ( $class, $name ) = @_;
995 my $prefix = _class2prefix($class);
996 $name = "$prefix/$name" if $prefix;
1001 my $class = shift || '';
1003 if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
1005 $prefix =~ s/\:\:/\//g;
1014 Sebastian Riedel, C<sri@cpan.org>
1018 This program is free software, you can redistribute it and/or modify it under
1019 the same terms as Perl itself.