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 Dispatch request to actions.
106 my $action = $c->req->action;
108 $namespace = ( join( '/', @{ $c->req->args } ) || '/' )
109 if $action eq 'default';
110 unless ($namespace) {
111 if ( my $result = $c->get_action($action) ) {
112 $namespace = _class2prefix( $result->[0]->[0]->[0] );
115 my $default = $action eq 'default' ? $namespace : undef;
116 my $results = $c->get_action( $action, $default );
122 if ( my $begin = @{ $c->get_action( 'begin', $namespace ) }[-1] ) {
123 $c->execute( @{ $begin->[0] } );
124 return if scalar @{ $c->error };
127 # Execute the auto chain
128 for my $auto ( @{ $c->get_action( 'auto', $namespace ) } ) {
129 $c->execute( @{ $auto->[0] } );
130 return if scalar @{ $c->error };
131 last unless $c->state;
134 # Execute the action or last default
135 if ( ( my $action = $c->req->action ) && $c->state ) {
136 if ( my $result = @{ $c->get_action( $action, $default ) }[-1] ) {
137 $c->execute( @{ $result->[0] } );
142 if ( my $end = @{ $c->get_action( 'end', $namespace ) }[-1] ) {
143 $c->execute( @{ $end->[0] } );
144 return if scalar @{ $c->error };
148 my $path = $c->req->path;
150 ? qq/Unknown resource "$path"/
151 : "No default action defined";
152 $c->log->error($error) if $c->debug;
159 =item $c->error($error, ...)
161 =item $c->error($arrayref)
163 Returns an arrayref containing error messages.
165 my @error = @{ $c->error };
169 $c->error('Something bad happened');
175 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
176 push @{ $c->{error} }, @$error;
180 =item $c->execute($class, $coderef)
182 Execute a coderef in given class and catch exceptions.
183 Errors are available via $c->error.
188 my ( $c, $class, $code ) = @_;
189 $class = $c->comp($class) || $class;
191 my $callsub = ( caller(1) )[3];
195 my $action = $c->actions->{reverse}->{"$code"};
196 $action = "/$action" unless $action =~ /\-\>/;
197 $action = "-> $action" if $callsub =~ /forward$/;
198 my ( $elapsed, @state ) =
199 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
200 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
203 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
205 if ( my $error = $@ ) {
207 unless ( ref $error ) {
209 $error = qq/Caught exception "$error"/;
212 $c->log->error($error);
228 $c->finalize_cookies;
230 if ( my $location = $c->response->redirect ) {
231 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
232 $c->response->header( Location => $location );
233 $c->response->status(302) if $c->response->status !~ /3\d\d$/;
236 if ( $#{ $c->error } >= 0 ) {
240 if ( !$c->response->output && $c->response->status !~ /^(1|3)\d\d$/ ) {
244 if ( $c->response->output && !$c->response->content_length ) {
245 use bytes; # play safe with a utf8 aware perl
246 $c->response->content_length( length $c->response->output );
249 my $status = $c->finalize_headers;
254 =item $c->finalize_cookies
260 sub finalize_cookies {
263 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
264 my $cookie = CGI::Cookie->new(
266 -value => $cookie->{value},
267 -expires => $cookie->{expires},
268 -domain => $cookie->{domain},
269 -path => $cookie->{path},
270 -secure => $cookie->{secure} || 0
273 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
277 =item $c->finalize_error
286 $c->res->headers->content_type('text/html');
287 my $name = $c->config->{name} || 'Catalyst Application';
289 my ( $title, $error, $infos );
291 $error = join '<br/>', @{ $c->error };
292 $error ||= 'No output';
293 $title = $name = "$name on Catalyst $Catalyst::VERSION";
294 my $req = encode_entities Dumper $c->req;
295 my $res = encode_entities Dumper $c->res;
296 my $stash = encode_entities Dumper $c->stash;
299 <b><u>Request</u></b><br/>
301 <b><u>Response</u></b><br/>
303 <b><u>Stash</u></b><br/>
312 (en) Please come back later
313 (de) Bitte versuchen sie es spaeter nocheinmal
314 (nl) Gelieve te komen later terug
315 (no) Vennligst prov igjen senere
316 (fr) Veuillez revenir plus tard
317 (es) Vuelto por favor mas adelante
318 (pt) Voltado por favor mais tarde
319 (it) Ritornato prego piĆ¹ successivamente
324 $c->res->output( <<"" );
327 <title>$title</title>
328 <style type="text/css">
330 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
331 Tahoma, Arial, helvetica, sans-serif;
333 background-color: #eee;
338 background-color: #ccc;
339 border: 1px solid #aaa;
342 -moz-border-radius: 10px;
345 background-color: #977;
346 border: 1px solid #755;
350 -moz-border-radius: 10px;
353 background-color: #797;
354 border: 1px solid #575;
358 -moz-border-radius: 10px;
361 background-color: #779;
362 border: 1px solid #557;
365 -moz-border-radius: 10px;
371 <div class="error">$error</div>
372 <div class="infos">$infos</div>
373 <div class="name">$name</div>
380 =item $c->finalize_headers
386 sub finalize_headers { }
388 =item $c->finalize_output
394 sub finalize_output { }
396 =item $c->forward($command)
398 Forward processing to a private action or a method from a class.
399 If you define a class without method it will default to process().
402 $c->forward('index');
403 $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
404 $c->forward('MyApp::View::TT');
412 $c->log->debug('Nothing to forward to') if $c->debug;
415 my $caller = caller(0);
417 if ( $command =~ /^\// ) {
418 $command =~ /^(.*)\/(\w+)$/;
419 $namespace = $1 || '/';
422 else { $namespace = _class2prefix($caller) || '/' }
423 my $results = $c->get_action( $command, $namespace );
424 unless ( @{$results} ) {
425 my $class = $command;
426 if ( $class =~ /[^\w\:]/ ) {
427 $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
430 my $method = shift || 'process';
431 if ( my $code = $class->can($method) ) {
432 $c->actions->{reverse}->{"$code"} = "$class->$method";
433 $results = [ [ [ $class, $code ] ] ];
436 $c->log->debug(qq/Couldn't forward to "$class->$method"/)
441 for my $result ( @{$results} ) {
442 $c->execute( @{ $result->[0] } );
443 return if scalar @{ $c->error };
444 last unless $c->state;
449 =item $c->get_action( $action, $namespace )
451 Get an action in a given namespace.
456 my ( $c, $action, $namespace ) = @_;
457 return [] unless $action;
460 $namespace = '' if $namespace eq '/';
461 my $parent = $c->tree;
463 my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
464 push @results, [$result] if $result;
465 my $visitor = Tree::Simple::Visitor::FindByPath->new;
466 for my $part ( split '/', $namespace ) {
467 $visitor->setSearchPath($part);
468 $parent->accept($visitor);
469 my $child = $visitor->getResult;
470 my $uid = $child->getUID if $child;
471 my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
472 push @results, [$match] if $match;
473 $parent = $child if $child;
477 elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
478 elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
480 for my $i ( 0 .. $#{ $c->actions->{compiled} } ) {
481 my $name = $c->actions->{compiled}->[$i]->[0];
482 my $regex = $c->actions->{compiled}->[$i]->[1];
483 if ( $action =~ $regex ) {
485 for my $i ( 1 .. 9 ) {
488 push @snippets, ${$i};
490 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
497 =item $c->handler( $class, $r )
504 my ( $class, $engine ) = @_;
506 # Always expect worst case!
511 my $c = $class->prepare($engine);
512 $c->{stats} = \@stats;
516 if ( $class->debug ) {
518 ( $elapsed, $status ) = $class->benchmark($handler);
519 $elapsed = sprintf '%f', $elapsed;
520 my $av = sprintf '%.3f', 1 / $elapsed;
521 my $t = Text::ASCIITable->new;
522 $t->setCols( 'Action', 'Time' );
523 $t->setColWidth( 'Action', 64, 1 );
524 $t->setColWidth( 'Time', 9, 1 );
526 for my $stat (@stats) {
527 $t->addRow( wrap( $stat->[0], 64 ), wrap( $stat->[1], 9 ) );
529 $class->log->info( "Request took $elapsed" . "s ($av/s)",
532 else { $status = &$handler }
534 if ( my $error = $@ ) {
536 $class->log->error(qq/Caught exception in engine "$error"/);
542 =item $c->prepare($r)
544 Turns the engine-specific request( Apache, CGI ... )
545 into a Catalyst context .
550 my ( $class, $r ) = @_;
552 request => Catalyst::Request->new(
556 headers => HTTP::Headers->new,
562 response => Catalyst::Response->new(
563 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
569 my $secs = time - $START || 1;
570 my $av = sprintf '%.3f', $COUNT / $secs;
571 $c->log->debug('**********************************');
572 $c->log->debug("* Request $COUNT ($av/s) [$$]");
573 $c->log->debug('**********************************');
574 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
576 $c->prepare_request($r);
580 $c->prepare_connection;
581 my $method = $c->req->method || '';
582 my $path = $c->req->path || '';
583 my $hostname = $c->req->hostname || '';
584 my $address = $c->req->address || '';
585 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
588 $c->prepare_parameters;
590 if ( $c->debug && keys %{ $c->req->params } ) {
591 my $t = Text::ASCIITable->new;
592 $t->setCols( 'Key', 'Value' );
593 $t->setColWidth( 'Key', 37, 1 );
594 $t->setColWidth( 'Value', 36, 1 );
595 for my $key ( keys %{ $c->req->params } ) {
596 my $value = $c->req->params->{$key} || '';
597 $t->addRow( wrap( $key, 37 ), wrap( $value, 36 ) );
599 $c->log->debug( 'Parameters are', $t->draw );
605 =item $c->prepare_action
613 my $path = $c->req->path;
614 my @path = split /\//, $c->req->path;
615 $c->req->args( \my @args );
617 $path = join '/', @path;
618 if ( my $result = ${ $c->get_action($path) }[0] ) {
622 my $match = $result->[1];
623 my @snippets = @{ $result->[2] };
625 qq/Requested action is "$path" and matched "$match"/)
628 'Snippets are "' . join( ' ', @snippets ) . '"' )
629 if ( $c->debug && @snippets );
630 $c->req->action($match);
631 $c->req->snippets( \@snippets );
634 $c->req->action($path);
635 $c->log->debug(qq/Requested action is "$path"/) if $c->debug;
637 $c->req->match($path);
640 unshift @args, pop @path;
642 unless ( $c->req->action ) {
643 $c->req->action('default');
646 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
647 if ( $c->debug && @args );
650 =item $c->prepare_connection
656 sub prepare_connection { }
658 =item $c->prepare_cookies
664 sub prepare_cookies {
667 if ( my $header = $c->request->header('Cookie') ) {
668 $c->req->cookies( { CGI::Cookie->parse($header) } );
672 =item $c->prepare_headers
678 sub prepare_headers { }
680 =item $c->prepare_parameters
686 sub prepare_parameters { }
688 =item $c->prepare_path
690 Prepare path and base.
696 =item $c->prepare_request
698 Prepare the engine request.
702 sub prepare_request { }
704 =item $c->prepare_uploads
710 sub prepare_uploads { }
724 Returns a C<Catalyst::Request> object.
732 Returns a C<Catalyst::Response> object.
736 =item $c->set_action( $action, $code, $namespace, $attrs )
738 Set an action in a given namespace.
743 my ( $c, $method, $code, $namespace, $attrs ) = @_;
745 my $prefix = _class2prefix($namespace) || '';
748 for my $attr ( @{$attrs} ) {
749 if ( $attr =~ /^(Local|Relative)$/ ) { $flags{local}++ }
750 elsif ( $attr =~ /^(Global|Absolute)$/ ) { $flags{global}++ }
751 elsif ( $attr =~ /^Path\((.+)\)$/i ) { $flags{path} = $1 }
752 elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
753 elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
756 return unless keys %flags;
758 my $parent = $c->tree;
759 my $visitor = Tree::Simple::Visitor::FindByPath->new;
760 for my $part ( split '/', $prefix ) {
761 $visitor->setSearchPath($part);
762 $parent->accept($visitor);
763 my $child = $visitor->getResult;
765 $child = $parent->addChild( Tree::Simple->new($part) );
766 $visitor->setSearchPath($part);
767 $parent->accept($visitor);
768 $child = $visitor->getResult;
772 my $uid = $parent->getUID;
773 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
774 my $forward = $prefix ? "$prefix/$method" : $method;
776 if ( $flags{path} ) {
777 $flags{path} =~ s/^\w+//;
778 $flags{path} =~ s/\w+$//;
779 if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
780 if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
782 if ( $flags{regex} ) {
783 $flags{regex} =~ s/^\w+//;
784 $flags{regex} =~ s/\w+$//;
785 if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
786 if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
789 my $reverse = $prefix ? "$prefix/$method" : $method;
791 if ( $flags{local} || $flags{global} || $flags{path} ) {
792 my $path = $flags{path} || $method;
794 if ( $path =~ /^\/(.+)/ ) {
798 $absolute = 1 if $flags{global};
799 my $name = $absolute ? $path : $prefix ? "$prefix/$path" : $path;
800 $c->actions->{plain}->{$name} = [ $namespace, $code ];
802 if ( my $regex = $flags{regex} ) {
803 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
804 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
807 $c->actions->{reverse}->{"$code"} = $reverse;
820 $self->setup_components;
821 if ( $self->debug ) {
822 my $name = $self->config->{name} || 'Application';
823 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
827 =item $class->setup_actions($component)
829 Setup actions for a component.
834 my ( $self, $comp ) = @_;
835 $comp = ref $comp || $comp;
836 for my $action ( @{ $comp->_cache } ) {
837 my ( $code, $attrs ) = @{$action};
840 my @cache = ( $comp, @{"$comp\::ISA"} );
842 while ( my $namespace = shift @cache ) {
843 $namespaces{$namespace}++;
844 for my $isa ( @{"$comp\::ISA"} ) {
845 next if $namespaces{$isa};
850 for my $namespace ( keys %namespaces ) {
851 for my $sym ( values %{ $namespace . '::' } ) {
852 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
853 $name = *{$sym}{NAME};
854 $self->set_action( $name, $code, $comp, $attrs );
862 =item $class->setup_components
868 sub setup_components {
872 my $class = ref $self || $self;
875 import Module::Pluggable::Fast
876 name => '_components',
878 '$class\::Controller', '$class\::C',
879 '$class\::Model', '$class\::M',
880 '$class\::View', '$class\::V'
883 if ( my $error = $@ ) {
886 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
888 $self->setup_actions($self);
889 $self->components( {} );
890 for my $comp ( $self->_components($self) ) {
891 $self->components->{ ref $comp } = $comp;
892 $self->setup_actions($comp);
894 my $t = Text::ASCIITable->new( { hide_HeadRow => 1, hide_HeadLine => 1 } );
895 $t->setCols('Class');
896 $t->setColWidth( 'Class', 75, 1 );
897 $t->addRow( wrap( $_, 75 ) ) for keys %{ $self->components };
898 $self->log->debug( 'Loaded components', $t->draw )
899 if ( @{ $t->{tbl_rows} } && $self->debug );
900 my $actions = $self->actions;
901 my $privates = Text::ASCIITable->new;
902 $privates->setCols( 'Private', 'Class', 'Code' );
903 $privates->setColWidth( 'Private', 28, 1 );
904 $privates->setColWidth( 'Class', 28, 1 );
905 $privates->setColWidth( 'Code', 14, 1 );
907 my ( $walker, $parent, $prefix ) = @_;
908 $prefix .= $parent->getNodeValue || '';
909 $prefix .= '/' unless $prefix =~ /\/$/;
910 my $uid = $parent->getUID;
911 for my $action ( keys %{ $actions->{private}->{$uid} } ) {
912 my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
914 wrap( "$prefix$action", 28 ),
919 $walker->( $walker, $_, $prefix ) for $parent->getAllChildren;
921 $walker->( $walker, $self->tree, '' );
922 $self->log->debug( 'Loaded private actions', $privates->draw )
923 if ( @{ $privates->{tbl_rows} } && $self->debug );
924 my $publics = Text::ASCIITable->new;
925 $publics->setCols( 'Public', 'Private' );
926 $publics->setColWidth( 'Public', 37, 1 );
927 $publics->setColWidth( 'Private', 36, 1 );
929 for my $plain ( sort keys %{ $actions->{plain} } ) {
930 my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
931 $publics->addRow( wrap( "/$plain", 37 ),
932 wrap( $self->actions->{reverse}->{$code} || $code, 36 ) );
934 $self->log->debug( 'Loaded public actions', $publics->draw )
935 if ( @{ $publics->{tbl_rows} } && $self->debug );
936 my $regexes = Text::ASCIITable->new;
937 $regexes->setCols( 'Regex', 'Private' );
938 $regexes->setColWidth( 'Regex', 37, 1 );
939 $regexes->setColWidth( 'Private', 36, 1 );
940 for my $regex ( sort keys %{ $actions->{regex} } ) {
941 my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
942 $regexes->addRow( wrap( $regex, 37 ),
943 wrap( $self->actions->{reverse}->{$class} || $class, 36 ) );
945 $self->log->debug( 'Loaded regex actions', $regexes->draw )
946 if ( @{ $regexes->{tbl_rows} } && $self->debug );
951 Contains the return value of the last executed action.
955 Returns a hashref containing all your data.
957 $c->stash->{foo} ||= 'yada';
958 print $c->stash->{foo};
965 my $stash = $_[1] ? {@_} : $_[0];
966 while ( my ( $key, $val ) = each %$stash ) {
967 $self->{stash}->{$key} = $val;
970 return $self->{stash};
974 my ( $class, $name ) = @_;
975 my $prefix = _class2prefix($class);
976 $name = "$prefix/$name" if $prefix;
981 my $class = shift || '';
983 if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
985 $prefix =~ s/\:\:/\//g;
994 Sebastian Riedel, C<sri@cpan.org>
998 This program is free software, you can redistribute it and/or modify it under
999 the same terms as Perl itself.