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 for my $stat (@stats) {
492 $class->log->info( "Request took $elapsed" . "s ($av/s)",
495 else { $status = &$handler }
497 if ( my $error = $@ ) {
499 $class->log->error(qq/Caught exception in engine "$error"/);
505 =item $c->prepare($r)
507 Turns the engine-specific request( Apache, CGI ... )
508 into a Catalyst context .
513 my ( $class, $r ) = @_;
515 request => Catalyst::Request->new(
519 headers => HTTP::Headers->new,
525 response => Catalyst::Response->new(
526 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
532 my $secs = time - $START || 1;
533 my $av = sprintf '%.3f', $COUNT / $secs;
534 $c->log->debug('********************************');
535 $c->log->debug("* Request $COUNT ($av/s) [$$]");
536 $c->log->debug('********************************');
537 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
539 $c->prepare_request($r);
543 $c->prepare_connection;
544 my $method = $c->req->method || '';
545 my $path = $c->req->path || '';
546 my $hostname = $c->req->hostname || '';
547 my $address = $c->req->address || '';
548 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
551 $c->prepare_parameters;
553 if ( $c->debug && keys %{ $c->req->params } ) {
554 my $t = Text::ASCIITable->new;
555 $t->setCols( 'Key', 'Value' );
556 for my $key ( keys %{ $c->req->params } ) {
557 my $value = $c->req->params->{$key} || '';
558 $t->addRow( $key, $value );
560 $c->log->debug( 'Parameters are', $t->draw );
566 =item $c->prepare_action
574 my $path = $c->req->path;
575 my @path = split /\//, $c->req->path;
576 $c->req->args( \my @args );
578 $path = join '/', @path;
579 if ( my $result = ${ $c->get_action($path) }[0] ) {
583 my $match = $result->[1];
584 my @snippets = @{ $result->[2] };
585 $c->log->debug(qq/Requested action "$path" matched "$match"/)
588 'Snippets are "' . join( ' ', @snippets ) . '"' )
589 if ( $c->debug && @snippets );
590 $c->req->action($match);
591 $c->req->snippets( \@snippets );
594 $c->req->action($path);
595 $c->log->debug(qq/Requested action "$path"/) if $c->debug;
597 $c->req->match($path);
600 unshift @args, pop @path;
602 unless ( $c->req->action ) {
603 $c->req->action('default');
606 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
607 if ( $c->debug && @args );
610 =item $c->prepare_connection
616 sub prepare_connection { }
618 =item $c->prepare_cookies
624 sub prepare_cookies {
627 if ( my $header = $c->request->header('Cookie') ) {
628 $c->req->cookies( { CGI::Cookie->parse($header) } );
632 =item $c->prepare_headers
638 sub prepare_headers { }
640 =item $c->prepare_parameters
646 sub prepare_parameters { }
648 =item $c->prepare_path
650 Prepare path and base.
656 =item $c->prepare_request
658 Prepare the engine request.
662 sub prepare_request { }
664 =item $c->prepare_uploads
670 sub prepare_uploads { }
684 Returns a C<Catalyst::Request> object.
692 Returns a C<Catalyst::Response> object.
696 =item $c->set_action( $action, $code, $namespace, $attrs )
698 Set an action in a given namespace.
703 my ( $c, $method, $code, $namespace, $attrs ) = @_;
705 my $prefix = _class2prefix($namespace) || '';
708 for my $attr ( @{$attrs} ) {
709 if ( $attr =~ /^(Local|Relative)$/ ) { $flags{local}++ }
710 elsif ( $attr =~ /^(Global|Absolute)$/ ) { $flags{global}++ }
711 elsif ( $attr =~ /^Path\((.+)\)$/i ) { $flags{path} = $1 }
712 elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
713 elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
716 return unless keys %flags;
718 my $parent = $c->tree;
719 my $visitor = Tree::Simple::Visitor::FindByPath->new;
720 for my $part ( split '/', $prefix ) {
721 $visitor->setSearchPath($part);
722 $parent->accept($visitor);
723 my $child = $visitor->getResult;
725 $child = $parent->addChild( Tree::Simple->new($part) );
726 $visitor->setSearchPath($part);
727 $parent->accept($visitor);
728 $child = $visitor->getResult;
732 my $uid = $parent->getUID;
733 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
734 my $forward = $prefix ? "$prefix/$method" : $method;
736 if ( $flags{path} ) {
737 $flags{path} =~ s/^\w+//;
738 $flags{path} =~ s/\w+$//;
739 if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
740 if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
742 if ( $flags{regex} ) {
743 $flags{regex} =~ s/^\w+//;
744 $flags{regex} =~ s/\w+$//;
745 if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
746 if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
749 my $reverse = $prefix ? "$prefix/$method" : $method;
751 if ( $flags{local} || $flags{global} || $flags{path} ) {
752 my $path = $flags{path} || $method;
754 if ( $path =~ /^\/(.+)/ ) {
758 $absolute = 1 if $flags{global};
759 my $name = $absolute ? $path : "$prefix/$path";
760 $c->actions->{plain}->{$name} = [ $namespace, $code ];
762 if ( my $regex = $flags{regex} ) {
763 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
764 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
767 $c->actions->{reverse}->{"$code"} = $reverse;
780 $self->setup_components;
781 if ( $self->debug ) {
782 my $name = $self->config->{name} || 'Application';
783 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
787 =item $class->setup_actions($component)
789 Setup actions for a component.
794 my ( $self, $comp ) = @_;
795 $comp = ref $comp || $comp;
796 for my $action ( @{ $comp->_cache } ) {
797 my ( $code, $attrs ) = @{$action};
800 my @cache = ( $comp, @{"$comp\::ISA"} );
802 while ( my $namespace = shift @cache ) {
803 $namespaces{$namespace}++;
804 for my $isa ( @{"$comp\::ISA"} ) {
805 next if $namespaces{$isa};
810 for my $namespace ( keys %namespaces ) {
811 for my $sym ( values %{ $namespace . '::' } ) {
812 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
813 $name = *{$sym}{NAME};
814 $self->set_action( $name, $code, $comp, $attrs );
822 =item $class->setup_components
828 sub setup_components {
832 my $class = ref $self || $self;
835 import Module::Pluggable::Fast
836 name => '_components',
838 '$class\::Controller', '$class\::C',
839 '$class\::Model', '$class\::M',
840 '$class\::View', '$class\::V'
843 if ( my $error = $@ ) {
846 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
848 $self->setup_actions($self);
849 $self->components( {} );
850 for my $comp ( $self->_components($self) ) {
851 $self->components->{ ref $comp } = $comp;
852 $self->setup_actions($comp);
854 my $t = Text::ASCIITable->new;
855 $t->setCols('Class');
856 $t->addRow($_) for keys %{ $self->components };
857 $self->log->debug( 'Loaded components', $t->draw )
858 if ( @{ $t->{tbl_rows} } && $self->debug );
859 my $actions = $self->actions;
860 my $privates = Text::ASCIITable->new;
861 $privates->setCols( 'Action', 'Class', 'Code' );
863 my ( $walker, $parent, $prefix ) = @_;
864 $prefix .= $parent->getNodeValue || '';
865 $prefix .= '/' unless $prefix =~ /\/$/;
866 my $uid = $parent->getUID;
867 for my $action ( keys %{ $actions->{private}->{$uid} } ) {
868 my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
869 $privates->addRow( "$prefix$action", $class, $code );
871 $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
873 $walker->( $walker, $self->tree, '' );
874 $self->log->debug( 'Loaded private actions', $privates->draw )
875 if ( @{ $privates->{tbl_rows} } && $self->debug );
876 my $publics = Text::ASCIITable->new;
877 $publics->setCols( 'Action', 'Class', 'Code' );
878 for my $plain ( sort keys %{ $actions->{plain} } ) {
879 my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
880 $publics->addRow( "/$plain", $class, $code );
882 $self->log->debug( 'Loaded public actions', $publics->draw )
883 if ( @{ $publics->{tbl_rows} } && $self->debug );
884 my $regexes = Text::ASCIITable->new;
885 $regexes->setCols( 'Action', 'Class', 'Code' );
886 for my $regex ( sort keys %{ $actions->{regex} } ) {
887 my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
888 $regexes->addRow( $regex, $class, $code );
890 $self->log->debug( 'Loaded regex actions', $regexes->draw )
891 if ( @{ $regexes->{tbl_rows} } && $self->debug );
896 Returns a hashref containing all your data.
898 $c->stash->{foo} ||= 'yada';
899 print $c->stash->{foo};
906 my $stash = $_[1] ? {@_} : $_[0];
907 while ( my ( $key, $val ) = each %$stash ) {
908 $self->{stash}->{$key} = $val;
911 return $self->{stash};
915 my ( $class, $name ) = @_;
916 my $prefix = _class2prefix($class);
917 $name = "$prefix/$name" if $prefix;
922 my $class = shift || '';
924 if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
926 $prefix =~ s/\:\:/\//g;
931 sub _prettify_action {
932 my ( $val1, $val2, $val3 ) = @_;
933 formline ' + @<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<'
934 . ' @>>>>>>>>>>>>>> ', $val1, $val2, $val3;
940 sub _prettify_stats {
941 my ( $val1, $val2 ) = @_;
942 formline ' + @<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<< ',
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.