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] } ) );
462 for my $result ( @{ $c->get_action( $action, $default ) }[-1] )
464 $c->state( $c->execute( @{ $result->[0] } ) );
465 last unless $default;
467 for my $end ( reverse @{ $c->get_action( 'end', $namespace ) } )
469 $c->state( $c->execute( @{ $end->[0] } ) );
473 my $path = $c->req->path;
475 ? qq/Unknown resource "$path"/
476 : "No default action defined";
477 $c->log->error($error) if $c->debug;
482 if ( $class->debug ) {
484 ( $elapsed, $status ) = $class->benchmark($handler);
485 $elapsed = sprintf '%f', $elapsed;
486 my $av = sprintf '%.3f', 1 / $elapsed;
487 my $t = Text::ASCIITable->new;
488 $t->setCols( 'Action', 'Time' );
489 $t->setColWidth( 'Action', 65, 1 );
490 $t->setColWidth( 'Time', 8, 1 );
492 for my $stat (@stats) {
495 $class->log->info( "Request took $elapsed" . "s ($av/s)",
498 else { $status = &$handler }
500 if ( my $error = $@ ) {
502 $class->log->error(qq/Caught exception in engine "$error"/);
508 =item $c->prepare($r)
510 Turns the engine-specific request( Apache, CGI ... )
511 into a Catalyst context .
516 my ( $class, $r ) = @_;
518 request => Catalyst::Request->new(
522 headers => HTTP::Headers->new,
528 response => Catalyst::Response->new(
529 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
535 my $secs = time - $START || 1;
536 my $av = sprintf '%.3f', $COUNT / $secs;
537 $c->log->debug('********************************');
538 $c->log->debug("* Request $COUNT ($av/s) [$$]");
539 $c->log->debug('********************************');
540 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
542 $c->prepare_request($r);
546 $c->prepare_connection;
547 my $method = $c->req->method || '';
548 my $path = $c->req->path || '';
549 my $hostname = $c->req->hostname || '';
550 my $address = $c->req->address || '';
551 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
554 $c->prepare_parameters;
556 if ( $c->debug && keys %{ $c->req->params } ) {
557 my $t = Text::ASCIITable->new;
558 $t->setCols( 'Key', 'Value' );
559 $t->setColWidth( 'Key', 37, 1 );
560 $t->setColWidth( 'Value', 36, 1 );
561 for my $key ( keys %{ $c->req->params } ) {
562 my $value = $c->req->params->{$key} || '';
563 $t->addRow( $key, $value );
565 $c->log->debug( 'Parameters are', $t->draw );
571 =item $c->prepare_action
579 my $path = $c->req->path;
580 my @path = split /\//, $c->req->path;
581 $c->req->args( \my @args );
583 $path = join '/', @path;
584 if ( my $result = ${ $c->get_action($path) }[0] ) {
588 my $match = $result->[1];
589 my @snippets = @{ $result->[2] };
591 qq/Requested action is "$path" and matched "$match"/)
594 'Snippets are "' . join( ' ', @snippets ) . '"' )
595 if ( $c->debug && @snippets );
596 $c->req->action($match);
597 $c->req->snippets( \@snippets );
600 $c->req->action($path);
601 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
603 $c->req->match($path);
606 unshift @args, pop @path;
608 unless ( $c->req->action ) {
609 $c->req->action('default');
612 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
613 if ( $c->debug && @args );
616 =item $c->prepare_connection
622 sub prepare_connection { }
624 =item $c->prepare_cookies
630 sub prepare_cookies {
633 if ( my $header = $c->request->header('Cookie') ) {
634 $c->req->cookies( { CGI::Cookie->parse($header) } );
638 =item $c->prepare_headers
644 sub prepare_headers { }
646 =item $c->prepare_parameters
652 sub prepare_parameters { }
654 =item $c->prepare_path
656 Prepare path and base.
662 =item $c->prepare_request
664 Prepare the engine request.
668 sub prepare_request { }
670 =item $c->prepare_uploads
676 sub prepare_uploads { }
690 Returns a C<Catalyst::Request> object.
698 Returns a C<Catalyst::Response> object.
702 =item $c->set_action( $action, $code, $namespace, $attrs )
704 Set an action in a given namespace.
709 my ( $c, $method, $code, $namespace, $attrs ) = @_;
711 my $prefix = _class2prefix($namespace) || '';
714 for my $attr ( @{$attrs} ) {
715 if ( $attr =~ /^(Local|Relative)$/ ) { $flags{local}++ }
716 elsif ( $attr =~ /^(Global|Absolute)$/ ) { $flags{global}++ }
717 elsif ( $attr =~ /^Path\((.+)\)$/i ) { $flags{path} = $1 }
718 elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
719 elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
722 return unless keys %flags;
724 my $parent = $c->tree;
725 my $visitor = Tree::Simple::Visitor::FindByPath->new;
726 for my $part ( split '/', $prefix ) {
727 $visitor->setSearchPath($part);
728 $parent->accept($visitor);
729 my $child = $visitor->getResult;
731 $child = $parent->addChild( Tree::Simple->new($part) );
732 $visitor->setSearchPath($part);
733 $parent->accept($visitor);
734 $child = $visitor->getResult;
738 my $uid = $parent->getUID;
739 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
740 my $forward = $prefix ? "$prefix/$method" : $method;
742 if ( $flags{path} ) {
743 $flags{path} =~ s/^\w+//;
744 $flags{path} =~ s/\w+$//;
745 if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
746 if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
748 if ( $flags{regex} ) {
749 $flags{regex} =~ s/^\w+//;
750 $flags{regex} =~ s/\w+$//;
751 if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
752 if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
755 my $reverse = $prefix ? "$prefix/$method" : $method;
757 if ( $flags{local} || $flags{global} || $flags{path} ) {
758 my $path = $flags{path} || $method;
760 if ( $path =~ /^\/(.+)/ ) {
764 $absolute = 1 if $flags{global};
765 my $name = $absolute ? $path : "$prefix/$path";
766 $c->actions->{plain}->{$name} = [ $namespace, $code ];
768 if ( my $regex = $flags{regex} ) {
769 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
770 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
773 $c->actions->{reverse}->{"$code"} = $reverse;
786 $self->setup_components;
787 if ( $self->debug ) {
788 my $name = $self->config->{name} || 'Application';
789 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
793 =item $class->setup_actions($component)
795 Setup actions for a component.
800 my ( $self, $comp ) = @_;
801 $comp = ref $comp || $comp;
802 for my $action ( @{ $comp->_cache } ) {
803 my ( $code, $attrs ) = @{$action};
806 my @cache = ( $comp, @{"$comp\::ISA"} );
808 while ( my $namespace = shift @cache ) {
809 $namespaces{$namespace}++;
810 for my $isa ( @{"$comp\::ISA"} ) {
811 next if $namespaces{$isa};
816 for my $namespace ( keys %namespaces ) {
817 for my $sym ( values %{ $namespace . '::' } ) {
818 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
819 $name = *{$sym}{NAME};
820 $self->set_action( $name, $code, $comp, $attrs );
828 =item $class->setup_components
834 sub setup_components {
838 my $class = ref $self || $self;
841 import Module::Pluggable::Fast
842 name => '_components',
844 '$class\::Controller', '$class\::C',
845 '$class\::Model', '$class\::M',
846 '$class\::View', '$class\::V'
849 if ( my $error = $@ ) {
852 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
854 $self->setup_actions($self);
855 $self->components( {} );
856 for my $comp ( $self->_components($self) ) {
857 $self->components->{ ref $comp } = $comp;
858 $self->setup_actions($comp);
860 my $t = Text::ASCIITable->new;
861 $t->setCols('Class');
862 $t->setColWidth( 'Class', 75, 1 );
863 $t->addRow($_) for keys %{ $self->components };
864 $self->log->debug( 'Loaded components', $t->draw )
865 if ( @{ $t->{tbl_rows} } && $self->debug );
866 my $actions = $self->actions;
867 my $privates = Text::ASCIITable->new;
868 $privates->setCols( 'Action', 'Class', 'Code' );
869 $privates->setColWidth( 'Action', 28, 1 );
870 $privates->setColWidth( 'Class', 28, 1 );
871 $privates->setColWidth( 'Code', 14, 1 );
873 my ( $walker, $parent, $prefix ) = @_;
874 $prefix .= $parent->getNodeValue || '';
875 $prefix .= '/' unless $prefix =~ /\/$/;
876 my $uid = $parent->getUID;
877 for my $action ( keys %{ $actions->{private}->{$uid} } ) {
878 my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
879 $privates->addRow( "$prefix$action", $class, $code );
881 $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
883 $walker->( $walker, $self->tree, '' );
884 $self->log->debug( 'Loaded private actions', $privates->draw )
885 if ( @{ $privates->{tbl_rows} } && $self->debug );
886 my $publics = Text::ASCIITable->new;
887 $publics->setCols( 'Action', 'Class', 'Code' );
888 $publics->setColWidth( 'Action', 28, 1 );
889 $publics->setColWidth( 'Class', 28, 1 );
890 $publics->setColWidth( 'Code', 14, 1 );
892 for my $plain ( sort keys %{ $actions->{plain} } ) {
893 my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
894 $publics->addRow( "/$plain", $class, $code );
896 $self->log->debug( 'Loaded public actions', $publics->draw )
897 if ( @{ $publics->{tbl_rows} } && $self->debug );
898 my $regexes = Text::ASCIITable->new;
899 $regexes->setCols( 'Action', 'Class', 'Code' );
900 $regexes->setColWidth( 'Action', 28, 1 );
901 $regexes->setColWidth( 'Class', 28, 1 );
902 $regexes->setColWidth( 'Code', 14, 1 );
903 for my $regex ( sort keys %{ $actions->{regex} } ) {
904 my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
905 $regexes->addRow( $regex, $class, $code );
907 $self->log->debug( 'Loaded regex actions', $regexes->draw )
908 if ( @{ $regexes->{tbl_rows} } && $self->debug );
913 Returns a hashref containing all your data.
915 $c->stash->{foo} ||= 'yada';
916 print $c->stash->{foo};
923 my $stash = $_[1] ? {@_} : $_[0];
924 while ( my ( $key, $val ) = each %$stash ) {
925 $self->{stash}->{$key} = $val;
928 return $self->{stash};
932 my ( $class, $name ) = @_;
933 my $prefix = _class2prefix($class);
934 $name = "$prefix/$name" if $prefix;
939 my $class = shift || '';
941 if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
943 $prefix =~ s/\:\:/\//g;
952 Sebastian Riedel, C<sri@cpan.org>
956 This program is free software, you can redistribute it and/or modify it under
957 the same terms as Perl itself.