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 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};
145 last unless $c->state;
149 my $path = $c->req->path;
151 ? qq/Unknown resource "$path"/
152 : "No default action defined";
153 $c->log->error($error) if $c->debug;
160 =item $c->error($error, ...)
162 =item $c->error($arrayref)
164 Returns an arrayref containing error messages.
166 my @error = @{ $c->error };
170 $c->error('Something bad happened');
176 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
177 push @{ $c->{error} }, @$error;
181 =item $c->execute($class, $coderef)
183 Execute a coderef in given class and catch exceptions.
184 Errors are available via $c->error.
189 my ( $c, $class, $code ) = @_;
190 $class = $c->comp($class) || $class;
192 my $callsub = ( caller(1) )[3];
196 my $action = $c->actions->{reverse}->{"$code"};
197 $action = "/$action" unless $action =~ /\-\>/;
198 $action = "-> $action" if $callsub =~ /forward$/;
199 my ( $elapsed, @state ) =
200 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
201 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
204 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
206 if ( my $error = $@ ) {
208 $error = qq/Caught exception "$error"/;
209 $c->log->error($error);
225 $c->finalize_cookies;
227 if ( my $location = $c->response->redirect ) {
228 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
229 $c->response->header( Location => $location );
230 $c->response->status(302) if $c->response->status !~ /3\d\d$/;
233 if ( $#{ $c->error } >= 0 ) {
237 if ( !$c->response->output && $c->response->status !~ /^(1|3)\d\d$/ ) {
241 if ( $c->response->output && !$c->response->content_length ) {
242 use bytes; # play safe with a utf8 aware perl
243 $c->response->content_length( length $c->response->output );
246 my $status = $c->finalize_headers;
251 =item $c->finalize_cookies
257 sub finalize_cookies {
260 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
261 my $cookie = CGI::Cookie->new(
263 -value => $cookie->{value},
264 -expires => $cookie->{expires},
265 -domain => $cookie->{domain},
266 -path => $cookie->{path},
267 -secure => $cookie->{secure} || 0
270 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
274 =item $c->finalize_error
283 $c->res->headers->content_type('text/html');
284 my $name = $c->config->{name} || 'Catalyst Application';
286 my ( $title, $error, $infos );
288 $error = join '<br/>', @{ $c->error };
289 $error ||= 'No output';
290 $title = $name = "$name on Catalyst $Catalyst::VERSION";
291 my $req = encode_entities Dumper $c->req;
292 my $res = encode_entities Dumper $c->res;
293 my $stash = encode_entities Dumper $c->stash;
296 <b><u>Request</u></b><br/>
298 <b><u>Response</u></b><br/>
300 <b><u>Stash</u></b><br/>
309 (en) Please come back later
310 (de) Bitte versuchen sie es spaeter nocheinmal
311 (nl) Gelieve te komen later terug
312 (no) Vennligst prov igjen senere
313 (fr) Veuillez revenir plus tard
314 (es) Vuelto por favor mas adelante
315 (pt) Voltado por favor mais tarde
316 (it) Ritornato prego piĆ¹ successivamente
321 $c->res->output( <<"" );
324 <title>$title</title>
325 <style type="text/css">
327 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
328 Tahoma, Arial, helvetica, sans-serif;
330 background-color: #eee;
335 background-color: #ccc;
336 border: 1px solid #aaa;
339 -moz-border-radius: 10px;
342 background-color: #977;
343 border: 1px solid #755;
347 -moz-border-radius: 10px;
350 background-color: #797;
351 border: 1px solid #575;
355 -moz-border-radius: 10px;
358 background-color: #779;
359 border: 1px solid #557;
362 -moz-border-radius: 10px;
368 <div class="error">$error</div>
369 <div class="infos">$infos</div>
370 <div class="name">$name</div>
377 =item $c->finalize_headers
383 sub finalize_headers { }
385 =item $c->finalize_output
391 sub finalize_output { }
393 =item $c->forward($command)
395 Forward processing to a private action or a method from a class.
396 If you define a class without method it will default to process().
399 $c->forward('index');
400 $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
401 $c->forward('MyApp::View::TT');
409 $c->log->debug('Nothing to forward to') if $c->debug;
412 my $caller = caller(0);
414 if ( $command =~ /^\// ) {
415 $command =~ /^(.*)\/(\w+)$/;
416 $namespace = $1 || '/';
419 else { $namespace = _class2prefix($caller) || '/' }
420 my $results = $c->get_action( $command, $namespace );
421 unless ( @{$results} ) {
422 my $class = $command;
423 if ( $class =~ /[^\w\:]/ ) {
424 $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
427 my $method = shift || 'process';
428 if ( my $code = $class->can($method) ) {
429 $c->actions->{reverse}->{"$code"} = "$class->$method";
430 $results = [ [ [ $class, $code ] ] ];
433 $c->log->debug(qq/Couldn't forward to "$class->$method"/)
438 for my $result ( @{$results} ) {
439 $c->execute( @{ $result->[0] } );
444 =item $c->get_action( $action, $namespace )
446 Get an action in a given namespace.
451 my ( $c, $action, $namespace ) = @_;
452 return [] unless $action;
455 $namespace = '' if $namespace eq '/';
456 my $parent = $c->tree;
458 my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
459 push @results, [$result] if $result;
460 my $visitor = Tree::Simple::Visitor::FindByPath->new;
461 for my $part ( split '/', $namespace ) {
462 $visitor->setSearchPath($part);
463 $parent->accept($visitor);
464 my $child = $visitor->getResult;
465 my $uid = $child->getUID if $child;
466 my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
467 push @results, [$match] if $match;
468 $parent = $child if $child;
472 elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
473 elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
475 for my $i ( 0 .. $#{ $c->actions->{compiled} } ) {
476 my $name = $c->actions->{compiled}->[$i]->[0];
477 my $regex = $c->actions->{compiled}->[$i]->[1];
478 if ( $action =~ $regex ) {
480 for my $i ( 1 .. 9 ) {
483 push @snippets, ${$i};
485 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
492 =item $c->handler( $class, $r )
499 my ( $class, $engine ) = @_;
501 # Always expect worst case!
506 my $c = $class->prepare($engine);
507 $c->{stats} = \@stats;
511 if ( $class->debug ) {
513 ( $elapsed, $status ) = $class->benchmark($handler);
514 $elapsed = sprintf '%f', $elapsed;
515 my $av = sprintf '%.3f', 1 / $elapsed;
516 my $t = Text::ASCIITable->new;
517 $t->setCols( 'Action', 'Time' );
518 $t->setColWidth( 'Action', 64, 1 );
519 $t->setColWidth( 'Time', 9, 1 );
521 for my $stat (@stats) {
522 $t->addRow( wrap( $stat->[0], 64 ), wrap( $stat->[1], 9 ) );
524 $class->log->info( "Request took $elapsed" . "s ($av/s)",
527 else { $status = &$handler }
529 if ( my $error = $@ ) {
531 $class->log->error(qq/Caught exception in engine "$error"/);
537 =item $c->prepare($r)
539 Turns the engine-specific request( Apache, CGI ... )
540 into a Catalyst context .
545 my ( $class, $r ) = @_;
547 request => Catalyst::Request->new(
551 headers => HTTP::Headers->new,
557 response => Catalyst::Response->new(
558 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
564 my $secs = time - $START || 1;
565 my $av = sprintf '%.3f', $COUNT / $secs;
566 $c->log->debug('**********************************');
567 $c->log->debug("* Request $COUNT ($av/s) [$$]");
568 $c->log->debug('**********************************');
569 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
571 $c->prepare_request($r);
575 $c->prepare_connection;
576 my $method = $c->req->method || '';
577 my $path = $c->req->path || '';
578 my $hostname = $c->req->hostname || '';
579 my $address = $c->req->address || '';
580 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
583 $c->prepare_parameters;
585 if ( $c->debug && keys %{ $c->req->params } ) {
586 my $t = Text::ASCIITable->new;
587 $t->setCols( 'Key', 'Value' );
588 $t->setColWidth( 'Key', 37, 1 );
589 $t->setColWidth( 'Value', 36, 1 );
590 for my $key ( keys %{ $c->req->params } ) {
591 my $value = $c->req->params->{$key} || '';
592 $t->addRow( wrap( $key, 37 ), wrap( $value, 36 ) );
594 $c->log->debug( 'Parameters are', $t->draw );
600 =item $c->prepare_action
608 my $path = $c->req->path;
609 my @path = split /\//, $c->req->path;
610 $c->req->args( \my @args );
612 $path = join '/', @path;
613 if ( my $result = ${ $c->get_action($path) }[0] ) {
617 my $match = $result->[1];
618 my @snippets = @{ $result->[2] };
620 qq/Requested action is "$path" and matched "$match"/)
623 'Snippets are "' . join( ' ', @snippets ) . '"' )
624 if ( $c->debug && @snippets );
625 $c->req->action($match);
626 $c->req->snippets( \@snippets );
629 $c->req->action($path);
630 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
632 $c->req->match($path);
635 unshift @args, pop @path;
637 unless ( $c->req->action ) {
638 $c->req->action('default');
641 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
642 if ( $c->debug && @args );
645 =item $c->prepare_connection
651 sub prepare_connection { }
653 =item $c->prepare_cookies
659 sub prepare_cookies {
662 if ( my $header = $c->request->header('Cookie') ) {
663 $c->req->cookies( { CGI::Cookie->parse($header) } );
667 =item $c->prepare_headers
673 sub prepare_headers { }
675 =item $c->prepare_parameters
681 sub prepare_parameters { }
683 =item $c->prepare_path
685 Prepare path and base.
691 =item $c->prepare_request
693 Prepare the engine request.
697 sub prepare_request { }
699 =item $c->prepare_uploads
705 sub prepare_uploads { }
719 Returns a C<Catalyst::Request> object.
727 Returns a C<Catalyst::Response> object.
731 =item $c->set_action( $action, $code, $namespace, $attrs )
733 Set an action in a given namespace.
738 my ( $c, $method, $code, $namespace, $attrs ) = @_;
740 my $prefix = _class2prefix($namespace) || '';
743 for my $attr ( @{$attrs} ) {
744 if ( $attr =~ /^(Local|Relative)$/ ) { $flags{local}++ }
745 elsif ( $attr =~ /^(Global|Absolute)$/ ) { $flags{global}++ }
746 elsif ( $attr =~ /^Path\((.+)\)$/i ) { $flags{path} = $1 }
747 elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
748 elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
751 return unless keys %flags;
753 my $parent = $c->tree;
754 my $visitor = Tree::Simple::Visitor::FindByPath->new;
755 for my $part ( split '/', $prefix ) {
756 $visitor->setSearchPath($part);
757 $parent->accept($visitor);
758 my $child = $visitor->getResult;
760 $child = $parent->addChild( Tree::Simple->new($part) );
761 $visitor->setSearchPath($part);
762 $parent->accept($visitor);
763 $child = $visitor->getResult;
767 my $uid = $parent->getUID;
768 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
769 my $forward = $prefix ? "$prefix/$method" : $method;
771 if ( $flags{path} ) {
772 $flags{path} =~ s/^\w+//;
773 $flags{path} =~ s/\w+$//;
774 if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
775 if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
777 if ( $flags{regex} ) {
778 $flags{regex} =~ s/^\w+//;
779 $flags{regex} =~ s/\w+$//;
780 if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
781 if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
784 my $reverse = $prefix ? "$prefix/$method" : $method;
786 if ( $flags{local} || $flags{global} || $flags{path} ) {
787 my $path = $flags{path} || $method;
789 if ( $path =~ /^\/(.+)/ ) {
793 $absolute = 1 if $flags{global};
794 my $name = $absolute ? $path : "$prefix/$path";
795 $c->actions->{plain}->{$name} = [ $namespace, $code ];
797 if ( my $regex = $flags{regex} ) {
798 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
799 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
802 $c->actions->{reverse}->{"$code"} = $reverse;
815 $self->setup_components;
816 if ( $self->debug ) {
817 my $name = $self->config->{name} || 'Application';
818 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
822 =item $class->setup_actions($component)
824 Setup actions for a component.
829 my ( $self, $comp ) = @_;
830 $comp = ref $comp || $comp;
831 for my $action ( @{ $comp->_cache } ) {
832 my ( $code, $attrs ) = @{$action};
835 my @cache = ( $comp, @{"$comp\::ISA"} );
837 while ( my $namespace = shift @cache ) {
838 $namespaces{$namespace}++;
839 for my $isa ( @{"$comp\::ISA"} ) {
840 next if $namespaces{$isa};
845 for my $namespace ( keys %namespaces ) {
846 for my $sym ( values %{ $namespace . '::' } ) {
847 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
848 $name = *{$sym}{NAME};
849 $self->set_action( $name, $code, $comp, $attrs );
857 =item $class->setup_components
863 sub setup_components {
867 my $class = ref $self || $self;
870 import Module::Pluggable::Fast
871 name => '_components',
873 '$class\::Controller', '$class\::C',
874 '$class\::Model', '$class\::M',
875 '$class\::View', '$class\::V'
878 if ( my $error = $@ ) {
881 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
883 $self->setup_actions($self);
884 $self->components( {} );
885 for my $comp ( $self->_components($self) ) {
886 $self->components->{ ref $comp } = $comp;
887 $self->setup_actions($comp);
889 my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
890 $t->setCols('Class');
891 $t->setColWidth( 'Class', 75, 1 );
892 $t->addRow( wrap( $_, 75 ) ) for keys %{ $self->components };
893 $self->log->debug( 'Loaded components', $t->draw )
894 if ( @{ $t->{tbl_rows} } && $self->debug );
895 my $actions = $self->actions;
896 my $privates = Text::ASCIITable->new;
897 $privates->setCols( 'Private', 'Class', 'Code' );
898 $privates->setColWidth( 'Private', 28, 1 );
899 $privates->setColWidth( 'Class', 28, 1 );
900 $privates->setColWidth( 'Code', 14, 1 );
902 my ( $walker, $parent, $prefix ) = @_;
903 $prefix .= $parent->getNodeValue || '';
904 $prefix .= '/' unless $prefix =~ /\/$/;
905 my $uid = $parent->getUID;
906 for my $action ( keys %{ $actions->{private}->{$uid} } ) {
907 my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
909 wrap( "$prefix$action", 28 ),
914 $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
916 $walker->( $walker, $self->tree, '' );
917 $self->log->debug( 'Loaded private actions', $privates->draw )
918 if ( @{ $privates->{tbl_rows} } && $self->debug );
919 my $publics = Text::ASCIITable->new;
920 $publics->setCols( 'Public', 'Private' );
921 $publics->setColWidth( 'Public', 37, 1 );
922 $publics->setColWidth( 'Private', 36, 1 );
924 for my $plain ( sort keys %{ $actions->{plain} } ) {
925 my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
926 $publics->addRow( wrap( "/$plain", 37 ),
927 wrap( $self->actions->{reverse}->{$code} || $code, 36 ) );
929 $self->log->debug( 'Loaded public actions', $publics->draw )
930 if ( @{ $publics->{tbl_rows} } && $self->debug );
931 my $regexes = Text::ASCIITable->new;
932 $regexes->setCols( 'Regex', 'Private' );
933 $regexes->setColWidth( 'Regex', 37, 1 );
934 $regexes->setColWidth( 'Private', 36, 1 );
935 for my $regex ( sort keys %{ $actions->{regex} } ) {
936 my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
937 $regexes->addRow( wrap( $regex, 37 ),
938 wrap( $self->actions->{reverse}->{$class} || $class, 36 ) );
940 $self->log->debug( 'Loaded regex actions', $regexes->draw )
941 if ( @{ $regexes->{tbl_rows} } && $self->debug );
946 Contains the return value of the last executed action.
950 Returns a hashref containing all your data.
952 $c->stash->{foo} ||= 'yada';
953 print $c->stash->{foo};
960 my $stash = $_[1] ? {@_} : $_[0];
961 while ( my ( $key, $val ) = each %$stash ) {
962 $self->{stash}->{$key} = $val;
965 return $self->{stash};
969 my ( $class, $name ) = @_;
970 my $prefix = _class2prefix($class);
971 $name = "$prefix/$name" if $prefix;
976 my $class = shift || '';
978 if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
980 $prefix =~ s/\:\:/\//g;
989 Sebastian Riedel, C<sri@cpan.org>
993 This program is free software, you can redistribute it and/or modify it under
994 the same terms as Perl itself.