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 =item $c->error($error, ...)
102 =item $c->error($arrayref)
104 Returns an arrayref containing error messages.
106 my @error = @{ $c->error };
110 $c->error('Something bad happened');
116 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
117 push @{ $c->{error} }, @$error;
121 =item $c->execute($class, $coderef)
123 Execute a coderef in given class and catch exceptions.
124 Errors are available via $c->error.
129 my ( $c, $class, $code ) = @_;
130 $class = $c->comp($class) || $class;
132 my $callsub = ( caller(1) )[3];
136 my $action = $c->actions->{reverse}->{"$code"};
137 $action = "/$action" unless $action =~ /\-\>/;
138 $action = "-> $action" if $callsub =~ /forward$/;
139 my ( $elapsed, @state ) =
140 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
141 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
144 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
146 if ( my $error = $@ ) {
148 $error = qq/Caught exception "$error"/;
149 $c->log->error($error);
150 $c->error($error) if $c->debug;
165 $c->finalize_cookies;
167 if ( my $location = $c->response->redirect ) {
168 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
169 $c->response->header( Location => $location );
170 $c->response->status(302) if $c->response->status !~ /3\d\d$/;
173 if ( $#{ $c->error } >= 0 ) {
177 if ( !$c->response->output && $c->response->status !~ /^(1|3)\d\d$/ ) {
181 if ( $c->response->output && !$c->response->content_length ) {
182 use bytes; # play safe with a utf8 aware perl
183 $c->response->content_length( length $c->response->output );
186 my $status = $c->finalize_headers;
191 =item $c->finalize_cookies
197 sub finalize_cookies {
200 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
201 my $cookie = CGI::Cookie->new(
203 -value => $cookie->{value},
204 -expires => $cookie->{expires},
205 -domain => $cookie->{domain},
206 -path => $cookie->{path},
207 -secure => $cookie->{secure} || 0
210 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
214 =item $c->finalize_error
223 $c->res->headers->content_type('text/html');
224 my $name = $c->config->{name} || 'Catalyst Application';
226 my ( $title, $error, $infos );
228 $error = join '<br/>', @{ $c->error };
229 $error ||= 'No output';
230 $title = $name = "$name on Catalyst $Catalyst::VERSION";
231 my $req = encode_entities Dumper $c->req;
232 my $res = encode_entities Dumper $c->res;
233 my $stash = encode_entities Dumper $c->stash;
236 <b><u>Request</u></b><br/>
238 <b><u>Response</u></b><br/>
240 <b><u>Stash</u></b><br/>
249 (en) Please come back later
250 (de) Bitte versuchen sie es spaeter nocheinmal
251 (nl) Gelieve te komen later terug
252 (no) Vennligst prov igjen senere
253 (fr) Veuillez revenir plus tard
254 (es) Vuelto por favor mas adelante
255 (pt) Voltado por favor mais tarde
256 (it) Ritornato prego piĆ¹ successivamente
261 $c->res->output( <<"" );
264 <title>$title</title>
265 <style type="text/css">
267 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
268 Tahoma, Arial, helvetica, sans-serif;
270 background-color: #eee;
275 background-color: #ccc;
276 border: 1px solid #aaa;
279 -moz-border-radius: 10px;
282 background-color: #977;
283 border: 1px solid #755;
287 -moz-border-radius: 10px;
290 background-color: #797;
291 border: 1px solid #575;
295 -moz-border-radius: 10px;
298 background-color: #779;
299 border: 1px solid #557;
302 -moz-border-radius: 10px;
308 <div class="error">$error</div>
309 <div class="infos">$infos</div>
310 <div class="name">$name</div>
317 =item $c->finalize_headers
323 sub finalize_headers { }
325 =item $c->finalize_output
331 sub finalize_output { }
333 =item $c->forward($command)
335 Forward processing to a private action or a method from a class.
336 If you define a class without method it will default to process().
339 $c->forward('index');
340 $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
341 $c->forward('MyApp::View::TT');
349 $c->log->debug('Nothing to forward to') if $c->debug;
352 my $caller = caller(0);
354 if ( $command =~ /^\// ) {
355 $command =~ /^(.*)\/(\w+)$/;
356 $namespace = $1 || '/';
359 else { $namespace = _class2prefix($caller) || '/' }
360 my $results = $c->get_action( $command, $namespace );
361 unless ( @{$results} ) {
362 my $class = $command;
363 if ( $class =~ /[^\w\:]/ ) {
364 $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
367 my $method = shift || 'process';
368 if ( my $code = $class->can($method) ) {
369 $c->actions->{reverse}->{"$code"} = "$class->$method";
370 $results = [ [ [ $class, $code ] ] ];
373 $c->log->debug(qq/Couldn't forward to "$class->$method"/)
378 for my $result ( @{$results} ) {
379 $c->state( $c->execute( @{ $result->[0] } ) );
384 =item $c->get_action( $action, $namespace )
386 Get an action in a given namespace.
391 my ( $c, $action, $namespace ) = @_;
392 return [] unless $action;
395 $namespace = '' if $namespace eq '/';
396 my $parent = $c->tree;
398 my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
399 push @results, [$result] if $result;
400 my $visitor = Tree::Simple::Visitor::FindByPath->new;
401 for my $part ( split '/', $namespace ) {
402 $visitor->setSearchPath($part);
403 $parent->accept($visitor);
404 my $child = $visitor->getResult;
405 my $uid = $child->getUID if $child;
406 my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
407 push @results, [$match] if $match;
408 $parent = $child if $child;
412 elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
413 elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
415 for my $i ( 0 .. $#{ $c->actions->{compiled} } ) {
416 my $name = $c->actions->{compiled}->[$i]->[0];
417 my $regex = $c->actions->{compiled}->[$i]->[1];
418 if ( $action =~ $regex ) {
420 for my $i ( 1 .. 9 ) {
423 push @snippets, ${$i};
425 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
432 =item $c->handler( $class, $r )
439 my ( $class, $engine ) = @_;
441 # Always expect worst case!
446 my $c = $class->prepare($engine);
447 $c->{stats} = \@stats;
448 my $action = $c->req->action;
450 $namespace = ( join( '/', @{ $c->req->args } ) || '/' )
451 if $action eq 'default';
452 unless ($namespace) {
453 if ( my $result = $c->get_action($action) ) {
454 $namespace = _class2prefix( $result->[0]->[0]->[0] );
457 my $default = $action eq 'default' ? $namespace : undef;
458 my $results = $c->get_action( $action, $default );
461 for my $begin ( @{ $c->get_action( 'begin', $namespace ) } ) {
462 $c->state( $c->execute( @{ $begin->[0] } ) );
464 if ( my $action = $c->req->action ) {
466 @{ $c->get_action( $action, $default ) }[-1] )
468 $c->state( $c->execute( @{ $result->[0] } ) );
469 last unless $default;
472 for my $end ( reverse @{ $c->get_action( 'end', $namespace ) } )
474 $c->state( $c->execute( @{ $end->[0] } ) );
478 my $path = $c->req->path;
480 ? qq/Unknown resource "$path"/
481 : "No default action defined";
482 $c->log->error($error) if $c->debug;
487 if ( $class->debug ) {
489 ( $elapsed, $status ) = $class->benchmark($handler);
490 $elapsed = sprintf '%f', $elapsed;
491 my $av = sprintf '%.3f', 1 / $elapsed;
492 my $t = Text::ASCIITable->new;
493 $t->setCols( 'Action', 'Time' );
494 $t->setColWidth( 'Action', 64, 1 );
495 $t->setColWidth( 'Time', 9, 1 );
497 for my $stat (@stats) {
498 $t->addRow( wrap( $stat->[0], 64 ), wrap( $stat->[1], 9 ) );
500 $class->log->info( "Request took $elapsed" . "s ($av/s)",
503 else { $status = &$handler }
505 if ( my $error = $@ ) {
507 $class->log->error(qq/Caught exception in engine "$error"/);
513 =item $c->prepare($r)
515 Turns the engine-specific request( Apache, CGI ... )
516 into a Catalyst context .
521 my ( $class, $r ) = @_;
523 request => Catalyst::Request->new(
527 headers => HTTP::Headers->new,
533 response => Catalyst::Response->new(
534 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
540 my $secs = time - $START || 1;
541 my $av = sprintf '%.3f', $COUNT / $secs;
542 $c->log->debug('**********************************');
543 $c->log->debug("* Request $COUNT ($av/s) [$$]");
544 $c->log->debug('**********************************');
545 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
547 $c->prepare_request($r);
551 $c->prepare_connection;
552 my $method = $c->req->method || '';
553 my $path = $c->req->path || '';
554 my $hostname = $c->req->hostname || '';
555 my $address = $c->req->address || '';
556 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
559 $c->prepare_parameters;
561 if ( $c->debug && keys %{ $c->req->params } ) {
562 my $t = Text::ASCIITable->new;
563 $t->setCols( 'Key', 'Value' );
564 $t->setColWidth( 'Key', 37, 1 );
565 $t->setColWidth( 'Value', 36, 1 );
566 for my $key ( keys %{ $c->req->params } ) {
567 my $value = $c->req->params->{$key} || '';
568 $t->addRow( wrap( $key, 37 ), wrap( $value, 36 ) );
570 $c->log->debug( 'Parameters are', $t->draw );
576 =item $c->prepare_action
584 my $path = $c->req->path;
585 my @path = split /\//, $c->req->path;
586 $c->req->args( \my @args );
588 $path = join '/', @path;
589 if ( my $result = ${ $c->get_action($path) }[0] ) {
593 my $match = $result->[1];
594 my @snippets = @{ $result->[2] };
596 qq/Requested action is "$path" and matched "$match"/)
599 'Snippets are "' . join( ' ', @snippets ) . '"' )
600 if ( $c->debug && @snippets );
601 $c->req->action($match);
602 $c->req->snippets( \@snippets );
605 $c->req->action($path);
606 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
608 $c->req->match($path);
611 unshift @args, pop @path;
613 unless ( $c->req->action ) {
614 $c->req->action('default');
617 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
618 if ( $c->debug && @args );
621 =item $c->prepare_connection
627 sub prepare_connection { }
629 =item $c->prepare_cookies
635 sub prepare_cookies {
638 if ( my $header = $c->request->header('Cookie') ) {
639 $c->req->cookies( { CGI::Cookie->parse($header) } );
643 =item $c->prepare_headers
649 sub prepare_headers { }
651 =item $c->prepare_parameters
657 sub prepare_parameters { }
659 =item $c->prepare_path
661 Prepare path and base.
667 =item $c->prepare_request
669 Prepare the engine request.
673 sub prepare_request { }
675 =item $c->prepare_uploads
681 sub prepare_uploads { }
695 Returns a C<Catalyst::Request> object.
703 Returns a C<Catalyst::Response> object.
707 =item $c->set_action( $action, $code, $namespace, $attrs )
709 Set an action in a given namespace.
714 my ( $c, $method, $code, $namespace, $attrs ) = @_;
716 my $prefix = _class2prefix($namespace) || '';
719 for my $attr ( @{$attrs} ) {
720 if ( $attr =~ /^(Local|Relative)$/ ) { $flags{local}++ }
721 elsif ( $attr =~ /^(Global|Absolute)$/ ) { $flags{global}++ }
722 elsif ( $attr =~ /^Path\((.+)\)$/i ) { $flags{path} = $1 }
723 elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
724 elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
727 return unless keys %flags;
729 my $parent = $c->tree;
730 my $visitor = Tree::Simple::Visitor::FindByPath->new;
731 for my $part ( split '/', $prefix ) {
732 $visitor->setSearchPath($part);
733 $parent->accept($visitor);
734 my $child = $visitor->getResult;
736 $child = $parent->addChild( Tree::Simple->new($part) );
737 $visitor->setSearchPath($part);
738 $parent->accept($visitor);
739 $child = $visitor->getResult;
743 my $uid = $parent->getUID;
744 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
745 my $forward = $prefix ? "$prefix/$method" : $method;
747 if ( $flags{path} ) {
748 $flags{path} =~ s/^\w+//;
749 $flags{path} =~ s/\w+$//;
750 if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
751 if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
753 if ( $flags{regex} ) {
754 $flags{regex} =~ s/^\w+//;
755 $flags{regex} =~ s/\w+$//;
756 if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
757 if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
760 my $reverse = $prefix ? "$prefix/$method" : $method;
762 if ( $flags{local} || $flags{global} || $flags{path} ) {
763 my $path = $flags{path} || $method;
765 if ( $path =~ /^\/(.+)/ ) {
769 $absolute = 1 if $flags{global};
770 my $name = $absolute ? $path : "$prefix/$path";
771 $c->actions->{plain}->{$name} = [ $namespace, $code ];
773 if ( my $regex = $flags{regex} ) {
774 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
775 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
778 $c->actions->{reverse}->{"$code"} = $reverse;
791 $self->setup_components;
792 if ( $self->debug ) {
793 my $name = $self->config->{name} || 'Application';
794 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
798 =item $class->setup_actions($component)
800 Setup actions for a component.
805 my ( $self, $comp ) = @_;
806 $comp = ref $comp || $comp;
807 for my $action ( @{ $comp->_cache } ) {
808 my ( $code, $attrs ) = @{$action};
811 my @cache = ( $comp, @{"$comp\::ISA"} );
813 while ( my $namespace = shift @cache ) {
814 $namespaces{$namespace}++;
815 for my $isa ( @{"$comp\::ISA"} ) {
816 next if $namespaces{$isa};
821 for my $namespace ( keys %namespaces ) {
822 for my $sym ( values %{ $namespace . '::' } ) {
823 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
824 $name = *{$sym}{NAME};
825 $self->set_action( $name, $code, $comp, $attrs );
833 =item $class->setup_components
839 sub setup_components {
843 my $class = ref $self || $self;
846 import Module::Pluggable::Fast
847 name => '_components',
849 '$class\::Controller', '$class\::C',
850 '$class\::Model', '$class\::M',
851 '$class\::View', '$class\::V'
854 if ( my $error = $@ ) {
857 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
859 $self->setup_actions($self);
860 $self->components( {} );
861 for my $comp ( $self->_components($self) ) {
862 $self->components->{ ref $comp } = $comp;
863 $self->setup_actions($comp);
865 my $t = Text::ASCIITable->new;
866 $t->setCols('Class');
867 $t->setColWidth( 'Class', 75, 1 );
868 $t->addRow( wrap( $_, 75 ) ) for keys %{ $self->components };
869 $self->log->debug( 'Loaded components', $t->draw )
870 if ( @{ $t->{tbl_rows} } && $self->debug );
871 my $actions = $self->actions;
872 my $privates = Text::ASCIITable->new;
873 $privates->setCols( 'Action', 'Class', 'Code' );
874 $privates->setColWidth( 'Action', 28, 1 );
875 $privates->setColWidth( 'Class', 28, 1 );
876 $privates->setColWidth( 'Code', 14, 1 );
878 my ( $walker, $parent, $prefix ) = @_;
879 $prefix .= $parent->getNodeValue || '';
880 $prefix .= '/' unless $prefix =~ /\/$/;
881 my $uid = $parent->getUID;
882 for my $action ( keys %{ $actions->{private}->{$uid} } ) {
883 my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
885 wrap( "$prefix$action", 28 ),
890 $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
892 $walker->( $walker, $self->tree, '' );
893 $self->log->debug( 'Loaded private actions', $privates->draw )
894 if ( @{ $privates->{tbl_rows} } && $self->debug );
895 my $publics = Text::ASCIITable->new;
896 $publics->setCols( 'Action', 'Class', 'Code' );
897 $publics->setColWidth( 'Action', 28, 1 );
898 $publics->setColWidth( 'Class', 28, 1 );
899 $publics->setColWidth( 'Code', 14, 1 );
901 for my $plain ( sort keys %{ $actions->{plain} } ) {
902 my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
904 wrap( "/$plain", 28 ),
909 $self->log->debug( 'Loaded public actions', $publics->draw )
910 if ( @{ $publics->{tbl_rows} } && $self->debug );
911 my $regexes = Text::ASCIITable->new;
912 $regexes->setCols( 'Action', 'Class', 'Code' );
913 $regexes->setColWidth( 'Action', 28, 1 );
914 $regexes->setColWidth( 'Class', 28, 1 );
915 $regexes->setColWidth( 'Code', 14, 1 );
916 for my $regex ( sort keys %{ $actions->{regex} } ) {
917 my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
924 $self->log->debug( 'Loaded regex actions', $regexes->draw )
925 if ( @{ $regexes->{tbl_rows} } && $self->debug );
930 Returns a hashref containing all your data.
932 $c->stash->{foo} ||= 'yada';
933 print $c->stash->{foo};
940 my $stash = $_[1] ? {@_} : $_[0];
941 while ( my ( $key, $val ) = each %$stash ) {
942 $self->{stash}->{$key} = $val;
945 return $self->{stash};
949 my ( $class, $name ) = @_;
950 my $prefix = _class2prefix($class);
951 $name = "$prefix/$name" if $prefix;
956 my $class = shift || '';
958 if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
960 $prefix =~ s/\:\:/\//g;
969 Sebastian Riedel, C<sri@cpan.org>
973 This program is free software, you can redistribute it and/or modify it under
974 the same terms as Perl itself.