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 ) = @_;
391 return [] unless $action;
394 $namespace = '' if $namespace eq '/';
395 my $parent = $c->tree;
397 my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
398 push @results, [$result] if $result;
399 my $visitor = Tree::Simple::Visitor::FindByPath->new;
400 for my $part ( split '/', $namespace ) {
401 $visitor->setSearchPath($part);
402 $parent->accept($visitor);
403 my $child = $visitor->getResult;
404 my $uid = $child->getUID if $child;
405 my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
406 push @results, [$match] if $match;
407 $parent = $child if $child;
411 elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
412 elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
414 for my $i ( 0 .. $#{ $c->actions->{compiled} } ) {
415 my $name = $c->actions->{compiled}->[$i]->[0];
416 my $regex = $c->actions->{compiled}->[$i]->[1];
417 if ( $action =~ $regex ) {
419 for my $i ( 1 .. 9 ) {
422 push @snippets, ${$i};
424 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
431 =item $c->handler( $class, $r )
438 my ( $class, $engine ) = @_;
440 # Always expect worst case!
445 my $c = $class->prepare($engine);
446 $c->{stats} = \@stats;
447 my $action = $c->req->action;
449 $namespace = ( join( '/', @{ $c->req->args } ) || '/' )
450 if $action eq 'default';
451 unless ($namespace) {
452 if ( my $result = $c->get_action($action) ) {
453 $namespace = _class2prefix( $result->[0]->[0]->[0] );
456 my $default = $action eq 'default' ? $namespace : undef;
457 my $results = $c->get_action( $action, $default );
460 for my $begin ( @{ $c->get_action( 'begin', $namespace ) } ) {
461 $c->state( $c->execute( @{ $begin->[0] } ) );
463 if ( my $action = $c->req->action ) {
465 @{ $c->get_action( $action, $default ) }[-1] )
467 $c->state( $c->execute( @{ $result->[0] } ) );
468 last unless $default;
471 for my $end ( reverse @{ $c->get_action( 'end', $namespace ) } )
473 $c->state( $c->execute( @{ $end->[0] } ) );
477 my $path = $c->req->path;
479 ? qq/Unknown resource "$path"/
480 : "No default action defined";
481 $c->log->error($error) if $c->debug;
486 if ( $class->debug ) {
488 ( $elapsed, $status ) = $class->benchmark($handler);
489 $elapsed = sprintf '%f', $elapsed;
490 my $av = sprintf '%.3f', 1 / $elapsed;
491 my $t = Text::ASCIITable->new;
492 $t->setCols( 'Action', 'Time' );
493 $t->setColWidth( 'Action', 64, 1 );
494 $t->setColWidth( 'Time', 9, 1 );
496 for my $stat (@stats) {
499 $class->log->info( "Request took $elapsed" . "s ($av/s)",
502 else { $status = &$handler }
504 if ( my $error = $@ ) {
506 $class->log->error(qq/Caught exception in engine "$error"/);
512 =item $c->prepare($r)
514 Turns the engine-specific request( Apache, CGI ... )
515 into a Catalyst context .
520 my ( $class, $r ) = @_;
522 request => Catalyst::Request->new(
526 headers => HTTP::Headers->new,
532 response => Catalyst::Response->new(
533 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
539 my $secs = time - $START || 1;
540 my $av = sprintf '%.3f', $COUNT / $secs;
541 $c->log->debug('**********************************');
542 $c->log->debug("* Request $COUNT ($av/s) [$$]");
543 $c->log->debug('**********************************');
544 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
546 $c->prepare_request($r);
550 $c->prepare_connection;
551 my $method = $c->req->method || '';
552 my $path = $c->req->path || '';
553 my $hostname = $c->req->hostname || '';
554 my $address = $c->req->address || '';
555 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
558 $c->prepare_parameters;
560 if ( $c->debug && keys %{ $c->req->params } ) {
561 my $t = Text::ASCIITable->new;
562 $t->setCols( 'Key', 'Value' );
563 $t->setColWidth( 'Key', 37, 1 );
564 $t->setColWidth( 'Value', 36, 1 );
565 for my $key ( keys %{ $c->req->params } ) {
566 my $value = $c->req->params->{$key} || '';
567 $t->addRow( $key, $value );
569 $c->log->debug( 'Parameters are', $t->draw );
575 =item $c->prepare_action
583 my $path = $c->req->path;
584 my @path = split /\//, $c->req->path;
585 $c->req->args( \my @args );
587 $path = join '/', @path;
588 if ( my $result = ${ $c->get_action($path) }[0] ) {
592 my $match = $result->[1];
593 my @snippets = @{ $result->[2] };
595 qq/Requested action is "$path" and matched "$match"/)
598 'Snippets are "' . join( ' ', @snippets ) . '"' )
599 if ( $c->debug && @snippets );
600 $c->req->action($match);
601 $c->req->snippets( \@snippets );
604 $c->req->action($path);
605 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
607 $c->req->match($path);
610 unshift @args, pop @path;
612 unless ( $c->req->action ) {
613 $c->req->action('default');
616 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
617 if ( $c->debug && @args );
620 =item $c->prepare_connection
626 sub prepare_connection { }
628 =item $c->prepare_cookies
634 sub prepare_cookies {
637 if ( my $header = $c->request->header('Cookie') ) {
638 $c->req->cookies( { CGI::Cookie->parse($header) } );
642 =item $c->prepare_headers
648 sub prepare_headers { }
650 =item $c->prepare_parameters
656 sub prepare_parameters { }
658 =item $c->prepare_path
660 Prepare path and base.
666 =item $c->prepare_request
668 Prepare the engine request.
672 sub prepare_request { }
674 =item $c->prepare_uploads
680 sub prepare_uploads { }
694 Returns a C<Catalyst::Request> object.
702 Returns a C<Catalyst::Response> object.
706 =item $c->set_action( $action, $code, $namespace, $attrs )
708 Set an action in a given namespace.
713 my ( $c, $method, $code, $namespace, $attrs ) = @_;
715 my $prefix = _class2prefix($namespace) || '';
718 for my $attr ( @{$attrs} ) {
719 if ( $attr =~ /^(Local|Relative)$/ ) { $flags{local}++ }
720 elsif ( $attr =~ /^(Global|Absolute)$/ ) { $flags{global}++ }
721 elsif ( $attr =~ /^Path\((.+)\)$/i ) { $flags{path} = $1 }
722 elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
723 elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
726 return unless keys %flags;
728 my $parent = $c->tree;
729 my $visitor = Tree::Simple::Visitor::FindByPath->new;
730 for my $part ( split '/', $prefix ) {
731 $visitor->setSearchPath($part);
732 $parent->accept($visitor);
733 my $child = $visitor->getResult;
735 $child = $parent->addChild( Tree::Simple->new($part) );
736 $visitor->setSearchPath($part);
737 $parent->accept($visitor);
738 $child = $visitor->getResult;
742 my $uid = $parent->getUID;
743 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
744 my $forward = $prefix ? "$prefix/$method" : $method;
746 if ( $flags{path} ) {
747 $flags{path} =~ s/^\w+//;
748 $flags{path} =~ s/\w+$//;
749 if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
750 if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
752 if ( $flags{regex} ) {
753 $flags{regex} =~ s/^\w+//;
754 $flags{regex} =~ s/\w+$//;
755 if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
756 if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
759 my $reverse = $prefix ? "$prefix/$method" : $method;
761 if ( $flags{local} || $flags{global} || $flags{path} ) {
762 my $path = $flags{path} || $method;
764 if ( $path =~ /^\/(.+)/ ) {
768 $absolute = 1 if $flags{global};
769 my $name = $absolute ? $path : "$prefix/$path";
770 $c->actions->{plain}->{$name} = [ $namespace, $code ];
772 if ( my $regex = $flags{regex} ) {
773 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
774 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
777 $c->actions->{reverse}->{"$code"} = $reverse;
790 $self->setup_components;
791 if ( $self->debug ) {
792 my $name = $self->config->{name} || 'Application';
793 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
797 =item $class->setup_actions($component)
799 Setup actions for a component.
804 my ( $self, $comp ) = @_;
805 $comp = ref $comp || $comp;
806 for my $action ( @{ $comp->_cache } ) {
807 my ( $code, $attrs ) = @{$action};
810 my @cache = ( $comp, @{"$comp\::ISA"} );
812 while ( my $namespace = shift @cache ) {
813 $namespaces{$namespace}++;
814 for my $isa ( @{"$comp\::ISA"} ) {
815 next if $namespaces{$isa};
820 for my $namespace ( keys %namespaces ) {
821 for my $sym ( values %{ $namespace . '::' } ) {
822 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
823 $name = *{$sym}{NAME};
824 $self->set_action( $name, $code, $comp, $attrs );
832 =item $class->setup_components
838 sub setup_components {
842 my $class = ref $self || $self;
845 import Module::Pluggable::Fast
846 name => '_components',
848 '$class\::Controller', '$class\::C',
849 '$class\::Model', '$class\::M',
850 '$class\::View', '$class\::V'
853 if ( my $error = $@ ) {
856 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
858 $self->setup_actions($self);
859 $self->components( {} );
860 for my $comp ( $self->_components($self) ) {
861 $self->components->{ ref $comp } = $comp;
862 $self->setup_actions($comp);
864 my $t = Text::ASCIITable->new;
865 $t->setCols('Class');
866 $t->setColWidth( 'Class', 75, 1 );
867 $t->addRow($_) for keys %{ $self->components };
868 $self->log->debug( 'Loaded components', $t->draw )
869 if ( @{ $t->{tbl_rows} } && $self->debug );
870 my $actions = $self->actions;
871 my $privates = Text::ASCIITable->new;
872 $privates->setCols( 'Action', 'Class', 'Code' );
873 $privates->setColWidth( 'Action', 28, 1 );
874 $privates->setColWidth( 'Class', 28, 1 );
875 $privates->setColWidth( 'Code', 14, 1 );
877 my ( $walker, $parent, $prefix ) = @_;
878 $prefix .= $parent->getNodeValue || '';
879 $prefix .= '/' unless $prefix =~ /\/$/;
880 my $uid = $parent->getUID;
881 for my $action ( keys %{ $actions->{private}->{$uid} } ) {
882 my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
883 $privates->addRow( "$prefix$action", $class, $code );
885 $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
887 $walker->( $walker, $self->tree, '' );
888 $self->log->debug( 'Loaded private actions', $privates->draw )
889 if ( @{ $privates->{tbl_rows} } && $self->debug );
890 my $publics = Text::ASCIITable->new;
891 $publics->setCols( 'Action', 'Class', 'Code' );
892 $publics->setColWidth( 'Action', 28, 1 );
893 $publics->setColWidth( 'Class', 28, 1 );
894 $publics->setColWidth( 'Code', 14, 1 );
896 for my $plain ( sort keys %{ $actions->{plain} } ) {
897 my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
898 $publics->addRow( "/$plain", $class, $code );
900 $self->log->debug( 'Loaded public actions', $publics->draw )
901 if ( @{ $publics->{tbl_rows} } && $self->debug );
902 my $regexes = Text::ASCIITable->new;
903 $regexes->setCols( 'Action', 'Class', 'Code' );
904 $regexes->setColWidth( 'Action', 28, 1 );
905 $regexes->setColWidth( 'Class', 28, 1 );
906 $regexes->setColWidth( 'Code', 14, 1 );
907 for my $regex ( sort keys %{ $actions->{regex} } ) {
908 my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
909 $regexes->addRow( $regex, $class, $code );
911 $self->log->debug( 'Loaded regex actions', $regexes->draw )
912 if ( @{ $regexes->{tbl_rows} } && $self->debug );
917 Returns a hashref containing all your data.
919 $c->stash->{foo} ||= 'yada';
920 print $c->stash->{foo};
927 my $stash = $_[1] ? {@_} : $_[0];
928 while ( my ( $key, $val ) = each %$stash ) {
929 $self->{stash}->{$key} = $val;
932 return $self->{stash};
936 my ( $class, $name ) = @_;
937 my $prefix = _class2prefix($class);
938 $name = "$prefix/$name" if $prefix;
943 my $class = shift || '';
945 if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
947 $prefix =~ s/\:\:/\//g;
956 Sebastian Riedel, C<sri@cpan.org>
960 This program is free software, you can redistribute it and/or modify it under
961 the same terms as Perl itself.