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/;
14 use Tree::Simple::Visitor::FindByPath;
15 use Catalyst::Request;
16 use Catalyst::Response;
18 require Module::Pluggable::Fast;
20 $Data::Dumper::Terse = 1;
22 __PACKAGE__->mk_classdata($_) for qw/actions components tree/;
23 __PACKAGE__->mk_accessors(qw/request response state/);
26 { plain => {}, private => {}, regex => {}, compiled => [], reverse => {} }
28 __PACKAGE__->tree( Tree::Simple->new( 0, Tree::Simple->ROOT ) );
37 memoize('_class2prefix');
41 Catalyst::Engine - The Catalyst Engine
53 =item $c->benchmark($coderef)
55 Takes a coderef with arguments and returns elapsed time as float.
57 my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
58 $c->log->info( sprintf "Processing took %f seconds", $elapsed );
65 my $time = [gettimeofday];
66 my @return = &$code(@_);
67 my $elapsed = tv_interval $time;
68 return wantarray ? ( $elapsed, @return ) : $elapsed;
73 =item $c->component($name)
75 Get a component object by name.
77 $c->comp('MyApp::Model::MyModel')->do_stuff;
79 Regex search for a component.
81 $c->comp('mymodel')->do_stuff;
86 my ( $c, $name ) = @_;
87 if ( my $component = $c->components->{$name} ) {
91 for my $component ( keys %{ $c->components } ) {
92 return $c->components->{$component} if $component =~ /$name/i;
99 =item $c->error($error, ...)
101 =item $c->error($arrayref)
103 Returns an arrayref containing error messages.
105 my @error = @{ $c->error };
109 $c->error('Something bad happened');
115 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
116 push @{ $c->{error} }, @$error;
120 =item $c->execute($class, $coderef)
122 Execute a coderef in given class and catch exceptions.
123 Errors are available via $c->error.
128 my ( $c, $class, $code ) = @_;
129 $class = $c->comp($class) || $class;
131 my $callsub = ( caller(1) )[3];
135 my $action = $c->actions->{reverse}->{"$code"};
136 $action = "/$action" unless $action =~ /\-\>/;
137 $action = " $action" if $callsub =~ /forward$/;
138 my ( $elapsed, @state ) =
139 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
140 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
143 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
145 if ( my $error = $@ ) {
147 $error = qq/Caught exception "$error"/;
148 $c->log->error($error);
149 $c->error($error) if $c->debug;
164 $c->finalize_cookies;
166 if ( my $location = $c->response->redirect ) {
167 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
168 $c->response->header( Location => $location );
169 $c->response->status(302) if $c->response->status !~ /3\d\d$/;
172 if ( $#{ $c->error } >= 0 ) {
176 if ( !$c->response->output && $c->response->status !~ /^(1|3)\d\d$/ ) {
180 if ( $c->response->output && !$c->response->content_length ) {
181 use bytes; # play safe with a utf8 aware perl
182 $c->response->content_length( length $c->response->output );
185 my $status = $c->finalize_headers;
190 =item $c->finalize_cookies
196 sub finalize_cookies {
199 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
200 my $cookie = CGI::Cookie->new(
202 -value => $cookie->{value},
203 -expires => $cookie->{expires},
204 -domain => $cookie->{domain},
205 -path => $cookie->{path},
206 -secure => $cookie->{secure} || 0
209 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
213 =item $c->finalize_error
222 $c->res->headers->content_type('text/html');
223 my $name = $c->config->{name} || 'Catalyst Application';
225 my ( $title, $error, $infos );
227 $error = join '<br/>', @{ $c->error };
228 $error ||= 'No output';
229 $title = $name = "$name on Catalyst $Catalyst::VERSION";
230 my $req = encode_entities Dumper $c->req;
231 my $res = encode_entities Dumper $c->res;
232 my $stash = encode_entities Dumper $c->stash;
235 <b><u>Request</u></b><br/>
237 <b><u>Response</u></b><br/>
239 <b><u>Stash</u></b><br/>
248 (en) Please come back later
249 (de) Bitte versuchen sie es spaeter nocheinmal
250 (nl) Gelieve te komen later terug
251 (no) Vennligst prov igjen senere
252 (fr) Veuillez revenir plus tard
253 (es) Vuelto por favor mas adelante
254 (pt) Voltado por favor mais tarde
255 (it) Ritornato prego piĆ¹ successivamente
260 $c->res->output( <<"" );
263 <title>$title</title>
264 <style type="text/css">
266 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
267 Tahoma, Arial, helvetica, sans-serif;
269 background-color: #eee;
274 background-color: #ccc;
275 border: 1px solid #aaa;
278 -moz-border-radius: 10px;
281 background-color: #977;
282 border: 1px solid #755;
286 -moz-border-radius: 10px;
289 background-color: #797;
290 border: 1px solid #575;
294 -moz-border-radius: 10px;
297 background-color: #779;
298 border: 1px solid #557;
301 -moz-border-radius: 10px;
307 <div class="error">$error</div>
308 <div class="infos">$infos</div>
309 <div class="name">$name</div>
316 =item $c->finalize_headers
322 sub finalize_headers { }
324 =item $c->finalize_output
330 sub finalize_output { }
332 =item $c->forward($command)
334 Forward processing to a private action or a method from a class.
335 If you define a class without method it will default to process().
338 $c->forward('index');
339 $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
340 $c->forward('MyApp::View::TT');
348 $c->log->debug('Nothing to forward to') if $c->debug;
351 my $caller = caller(0);
353 if ( $command =~ /^\// ) {
354 $command =~ /^(.*)\/(\w+)$/;
355 $namespace = $1 || '/';
358 else { $namespace = _class2prefix($caller) || '/' }
359 my $results = $c->get_action( $command, $namespace );
360 unless ( @{$results} ) {
361 my $class = $command;
362 if ( $class =~ /[^\w\:]/ ) {
363 $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
366 my $method = shift || 'process';
367 if ( my $code = $class->can($method) ) {
368 $c->actions->{reverse}->{"$code"} = "$class->$method";
369 $results = [ [ [ $class, $code ] ] ];
372 $c->log->debug(qq/Couldn't forward to "$class->$method"/)
377 for my $result ( @{$results} ) {
378 $c->state( $c->execute( @{ $result->[0] } ) );
383 =item $c->get_action( $action, $namespace )
385 Get an action in a given namespace.
390 my ( $c, $action, $namespace ) = @_;
393 $namespace = '' if $namespace eq '/';
394 my $parent = $c->tree;
396 my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
397 push @results, [$result] if $result;
398 my $visitor = Tree::Simple::Visitor::FindByPath->new;
399 for my $part ( split '/', $namespace ) {
400 $visitor->setSearchPath($part);
401 $parent->accept($visitor);
402 my $child = $visitor->getResult;
403 my $uid = $child->getUID if $child;
404 my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
405 push @results, [$match] if $match;
406 $parent = $child if $child;
410 elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
411 elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
413 for my $i ( 0 .. $#{ $c->actions->{compiled} } ) {
414 my $name = $c->actions->{compiled}->[$i]->[0];
415 my $regex = $c->actions->{compiled}->[$i]->[1];
416 if ( $action =~ $regex ) {
418 for my $i ( 1 .. 9 ) {
421 push @snippets, ${$i};
423 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
430 =item $c->handler( $class, $r )
437 my ( $class, $engine ) = @_;
439 # Always expect worst case!
444 my $c = $class->prepare($engine);
445 $c->{stats} = \@stats;
446 my $action = $c->req->action;
448 $namespace = ( join( '/', @{ $c->req->args } ) || '/' )
449 if $action eq 'default';
450 unless ($namespace) {
451 if ( my $result = $c->get_action($action) ) {
452 $namespace = _class2prefix( $result->[0]->[0]->[0] );
455 my $default = $action eq 'default' ? $namespace : undef;
456 my $results = $c->get_action( $action, $default );
459 for my $begin ( @{ $c->get_action( 'begin', $namespace ) } ) {
460 $c->state( $c->execute( @{ $begin->[0] } ) );
463 @{ $c->get_action( $c->req->action, $default ) }[-1] )
465 $c->state( $c->execute( @{ $result->[0] } ) );
466 last unless $default;
468 for my $end ( reverse @{ $c->get_action( 'end', $namespace ) } )
470 $c->state( $c->execute( @{ $end->[0] } ) );
474 my $path = $c->req->path;
476 ? qq/Unknown resource "$path"/
477 : "No default action defined";
478 $c->log->error($error) if $c->debug;
483 if ( $class->debug ) {
485 ( $elapsed, $status ) = $class->benchmark($handler);
486 $elapsed = sprintf '%f', $elapsed;
487 my $av = sprintf '%.3f', 1 / $elapsed;
488 my $t = Text::ASCIITable->new;
489 $t->setCols( 'Action', 'Time' );
490 $t->setColWidth( 'Action', 64, 1 );
491 $t->setColWidth( 'Time', 9, 1 );
493 for my $stat (@stats) {
496 $class->log->info( "Request took $elapsed" . "s ($av/s)",
499 else { $status = &$handler }
501 if ( my $error = $@ ) {
503 $class->log->error(qq/Caught exception in engine "$error"/);
509 =item $c->prepare($r)
511 Turns the engine-specific request( Apache, CGI ... )
512 into a Catalyst context .
517 my ( $class, $r ) = @_;
519 request => Catalyst::Request->new(
523 headers => HTTP::Headers->new,
529 response => Catalyst::Response->new(
530 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
536 my $secs = time - $START || 1;
537 my $av = sprintf '%.3f', $COUNT / $secs;
538 $c->log->debug('**********************************');
539 $c->log->debug("* Request $COUNT ($av/s) [$$]");
540 $c->log->debug('**********************************');
541 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
543 $c->prepare_request($r);
547 $c->prepare_connection;
548 my $method = $c->req->method || '';
549 my $path = $c->req->path || '';
550 my $hostname = $c->req->hostname || '';
551 my $address = $c->req->address || '';
552 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
555 $c->prepare_parameters;
557 if ( $c->debug && keys %{ $c->req->params } ) {
558 my $t = Text::ASCIITable->new;
559 $t->setCols( 'Key', 'Value' );
560 $t->setColWidth( 'Key', 37, 1 );
561 $t->setColWidth( 'Value', 36, 1 );
562 for my $key ( keys %{ $c->req->params } ) {
563 my $value = $c->req->params->{$key} || '';
564 $t->addRow( $key, $value );
566 $c->log->debug( 'Parameters are', $t->draw );
572 =item $c->prepare_action
580 my $path = $c->req->path;
581 my @path = split /\//, $c->req->path;
582 $c->req->args( \my @args );
584 $path = join '/', @path;
585 if ( my $result = ${ $c->get_action($path) }[0] ) {
589 my $match = $result->[1];
590 my @snippets = @{ $result->[2] };
592 qq/Requested action is "$path" and matched "$match"/)
595 'Snippets are "' . join( ' ', @snippets ) . '"' )
596 if ( $c->debug && @snippets );
597 $c->req->action($match);
598 $c->req->snippets( \@snippets );
601 $c->req->action($path);
602 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
604 $c->req->match($path);
607 unshift @args, pop @path;
609 unless ( $c->req->action ) {
610 $c->req->action('default');
613 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
614 if ( $c->debug && @args );
617 =item $c->prepare_connection
623 sub prepare_connection { }
625 =item $c->prepare_cookies
631 sub prepare_cookies {
634 if ( my $header = $c->request->header('Cookie') ) {
635 $c->req->cookies( { CGI::Cookie->parse($header) } );
639 =item $c->prepare_headers
645 sub prepare_headers { }
647 =item $c->prepare_parameters
653 sub prepare_parameters { }
655 =item $c->prepare_path
657 Prepare path and base.
663 =item $c->prepare_request
665 Prepare the engine request.
669 sub prepare_request { }
671 =item $c->prepare_uploads
677 sub prepare_uploads { }
691 Returns a C<Catalyst::Request> object.
699 Returns a C<Catalyst::Response> object.
703 =item $c->set_action( $action, $code, $namespace, $attrs )
705 Set an action in a given namespace.
710 my ( $c, $method, $code, $namespace, $attrs ) = @_;
712 my $prefix = _class2prefix($namespace) || '';
715 for my $attr ( @{$attrs} ) {
716 if ( $attr =~ /^(Local|Relative)$/ ) { $flags{local}++ }
717 elsif ( $attr =~ /^(Global|Absolute)$/ ) { $flags{global}++ }
718 elsif ( $attr =~ /^Path\((.+)\)$/i ) { $flags{path} = $1 }
719 elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
720 elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
723 return unless keys %flags;
725 my $parent = $c->tree;
726 my $visitor = Tree::Simple::Visitor::FindByPath->new;
727 for my $part ( split '/', $prefix ) {
728 $visitor->setSearchPath($part);
729 $parent->accept($visitor);
730 my $child = $visitor->getResult;
732 $child = $parent->addChild( Tree::Simple->new($part) );
733 $visitor->setSearchPath($part);
734 $parent->accept($visitor);
735 $child = $visitor->getResult;
739 my $uid = $parent->getUID;
740 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
741 my $forward = $prefix ? "$prefix/$method" : $method;
743 if ( $flags{path} ) {
744 $flags{path} =~ s/^\w+//;
745 $flags{path} =~ s/\w+$//;
746 if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
747 if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
749 if ( $flags{regex} ) {
750 $flags{regex} =~ s/^\w+//;
751 $flags{regex} =~ s/\w+$//;
752 if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
753 if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
756 my $reverse = $prefix ? "$prefix/$method" : $method;
758 if ( $flags{local} || $flags{global} || $flags{path} ) {
759 my $path = $flags{path} || $method;
761 if ( $path =~ /^\/(.+)/ ) {
765 $absolute = 1 if $flags{global};
766 my $name = $absolute ? $path : "$prefix/$path";
767 $c->actions->{plain}->{$name} = [ $namespace, $code ];
769 if ( my $regex = $flags{regex} ) {
770 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
771 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
774 $c->actions->{reverse}->{"$code"} = $reverse;
787 $self->setup_components;
788 if ( $self->debug ) {
789 my $name = $self->config->{name} || 'Application';
790 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
794 =item $class->setup_actions($component)
796 Setup actions for a component.
801 my ( $self, $comp ) = @_;
802 $comp = ref $comp || $comp;
803 for my $action ( @{ $comp->_cache } ) {
804 my ( $code, $attrs ) = @{$action};
807 my @cache = ( $comp, @{"$comp\::ISA"} );
809 while ( my $namespace = shift @cache ) {
810 $namespaces{$namespace}++;
811 for my $isa ( @{"$comp\::ISA"} ) {
812 next if $namespaces{$isa};
817 for my $namespace ( keys %namespaces ) {
818 for my $sym ( values %{ $namespace . '::' } ) {
819 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
820 $name = *{$sym}{NAME};
821 $self->set_action( $name, $code, $comp, $attrs );
829 =item $class->setup_components
835 sub setup_components {
839 my $class = ref $self || $self;
842 import Module::Pluggable::Fast
843 name => '_components',
845 '$class\::Controller', '$class\::C',
846 '$class\::Model', '$class\::M',
847 '$class\::View', '$class\::V'
850 if ( my $error = $@ ) {
853 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
855 $self->setup_actions($self);
856 $self->components( {} );
857 for my $comp ( $self->_components($self) ) {
858 $self->components->{ ref $comp } = $comp;
859 $self->setup_actions($comp);
861 my $t = Text::ASCIITable->new;
862 $t->setCols('Class');
863 $t->setColWidth( 'Class', 75, 1 );
864 $t->addRow($_) for keys %{ $self->components };
865 $self->log->debug( 'Loaded components', $t->draw )
866 if ( @{ $t->{tbl_rows} } && $self->debug );
867 my $actions = $self->actions;
868 my $privates = Text::ASCIITable->new;
869 $privates->setCols( 'Action', 'Class', 'Code' );
870 $privates->setColWidth( 'Action', 28, 1 );
871 $privates->setColWidth( 'Class', 28, 1 );
872 $privates->setColWidth( 'Code', 14, 1 );
874 my ( $walker, $parent, $prefix ) = @_;
875 $prefix .= $parent->getNodeValue || '';
876 $prefix .= '/' unless $prefix =~ /\/$/;
877 my $uid = $parent->getUID;
878 for my $action ( keys %{ $actions->{private}->{$uid} } ) {
879 my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
880 $privates->addRow( "$prefix$action", $class, $code );
882 $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
884 $walker->( $walker, $self->tree, '' );
885 $self->log->debug( 'Loaded private actions', $privates->draw )
886 if ( @{ $privates->{tbl_rows} } && $self->debug );
887 my $publics = Text::ASCIITable->new;
888 $publics->setCols( 'Action', 'Class', 'Code' );
889 $publics->setColWidth( 'Action', 28, 1 );
890 $publics->setColWidth( 'Class', 28, 1 );
891 $publics->setColWidth( 'Code', 14, 1 );
893 for my $plain ( sort keys %{ $actions->{plain} } ) {
894 my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
895 $publics->addRow( "/$plain", $class, $code );
897 $self->log->debug( 'Loaded public actions', $publics->draw )
898 if ( @{ $publics->{tbl_rows} } && $self->debug );
899 my $regexes = Text::ASCIITable->new;
900 $regexes->setCols( 'Action', 'Class', 'Code' );
901 $regexes->setColWidth( 'Action', 28, 1 );
902 $regexes->setColWidth( 'Class', 28, 1 );
903 $regexes->setColWidth( 'Code', 14, 1 );
904 for my $regex ( sort keys %{ $actions->{regex} } ) {
905 my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
906 $regexes->addRow( $regex, $class, $code );
908 $self->log->debug( 'Loaded regex actions', $regexes->draw )
909 if ( @{ $regexes->{tbl_rows} } && $self->debug );
914 Returns a hashref containing all your data.
916 $c->stash->{foo} ||= 'yada';
917 print $c->stash->{foo};
924 my $stash = $_[1] ? {@_} : $_[0];
925 while ( my ( $key, $val ) = each %$stash ) {
926 $self->{stash}->{$key} = $val;
929 return $self->{stash};
933 my ( $class, $name ) = @_;
934 my $prefix = _class2prefix($class);
935 $name = "$prefix/$name" if $prefix;
940 my $class = shift || '';
942 if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
944 $prefix =~ s/\:\:/\//g;
953 Sebastian Riedel, C<sri@cpan.org>
957 This program is free software, you can redistribute it and/or modify it under
958 the same terms as Perl itself.