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 Tree::Simple::Visitor::FindByPath;
14 use Catalyst::Request;
15 use Catalyst::Response;
17 require Module::Pluggable::Fast;
19 $Data::Dumper::Terse = 1;
21 __PACKAGE__->mk_classdata($_) for qw/actions components tree/;
22 __PACKAGE__->mk_accessors(qw/request response state/);
25 { plain => {}, private => {}, regex => {}, compiled => [], reverse => {} }
27 __PACKAGE__->tree( Tree::Simple->new( 0, Tree::Simple->ROOT ) );
36 memoize('_class2prefix');
40 Catalyst::Engine - The Catalyst Engine
52 =item $c->benchmark($coderef)
54 Takes a coderef with arguments and returns elapsed time as float.
56 my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
57 $c->log->info( sprintf "Processing took %f seconds", $elapsed );
64 my $time = [gettimeofday];
65 my @return = &$code(@_);
66 my $elapsed = tv_interval $time;
67 return wantarray ? ( $elapsed, @return ) : $elapsed;
72 =item $c->component($name)
74 Get a component object by name.
76 $c->comp('MyApp::Model::MyModel')->do_stuff;
78 Regex search for a component.
80 $c->comp('mymodel')->do_stuff;
85 my ( $c, $name ) = @_;
86 if ( my $component = $c->components->{$name} ) {
90 for my $component ( keys %{ $c->components } ) {
91 return $c->components->{$component} if $component =~ /$name/i;
98 =item $c->error($error, ...)
100 =item $c->error($arrayref)
102 Returns an arrayref containing error messages.
104 my @error = @{ $c->error };
108 $c->error('Something bad happened');
114 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
115 push @{ $c->{error} }, @$error;
119 =item $c->execute($class, $coderef)
121 Execute a coderef in given class and catch exceptions.
122 Errors are available via $c->error.
127 my ( $c, $class, $code ) = @_;
128 $class = $c->comp($class) || $class;
133 my $action = $c->actions->{reverse}->{"$code"};
134 $action = "/$action" unless $action =~ /\-\>/;
135 my ( $elapsed, @state ) =
136 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
137 push @{ $c->{stats} },
138 _prettify( $action, sprintf( '%fs', $elapsed ), '' );
141 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
143 if ( my $error = $@ ) {
145 $error = qq/Caught exception "$error"/;
146 $c->log->error($error);
147 $c->error($error) if $c->debug;
162 $c->finalize_cookies;
164 if ( my $location = $c->response->redirect ) {
165 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
166 $c->response->header( Location => $location );
167 $c->response->status(302) if $c->response->status !~ /3\d\d$/;
170 if ( $#{ $c->error } >= 0 ) {
174 if ( !$c->response->output && $c->response->status !~ /^(1|3)\d\d$/ ) {
178 if ( $c->response->output && !$c->response->content_length ) {
179 use bytes; # play safe with a utf8 aware perl
180 $c->response->content_length( length $c->response->output );
183 my $status = $c->finalize_headers;
188 =item $c->finalize_cookies
194 sub finalize_cookies {
197 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
198 my $cookie = CGI::Cookie->new(
200 -value => $cookie->{value},
201 -expires => $cookie->{expires},
202 -domain => $cookie->{domain},
203 -path => $cookie->{path},
204 -secure => $cookie->{secure} || 0
207 $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
211 =item $c->finalize_error
220 $c->res->headers->content_type('text/html');
221 my $name = $c->config->{name} || 'Catalyst Application';
223 my ( $title, $error, $infos );
225 $error = join '<br/>', @{ $c->error };
226 $error ||= 'No output';
227 $title = $name = "$name on Catalyst $Catalyst::VERSION";
228 my $req = encode_entities Dumper $c->req;
229 my $res = encode_entities Dumper $c->res;
230 my $stash = encode_entities Dumper $c->stash;
233 <b><u>Request</u></b><br/>
235 <b><u>Response</u></b><br/>
237 <b><u>Stash</u></b><br/>
246 (en) Please come back later
247 (de) Bitte versuchen sie es spaeter nocheinmal
248 (nl) Gelieve te komen later terug
249 (no) Vennligst prov igjen senere
250 (fr) Veuillez revenir plus tard
251 (es) Vuelto por favor mas adelante
252 (pt) Voltado por favor mais tarde
253 (it) Ritornato prego piĆ¹ successivamente
258 $c->res->output( <<"" );
261 <title>$title</title>
262 <style type="text/css">
264 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
265 Tahoma, Arial, helvetica, sans-serif;
267 background-color: #eee;
272 background-color: #ccc;
273 border: 1px solid #aaa;
276 -moz-border-radius: 10px;
279 background-color: #977;
280 border: 1px solid #755;
284 -moz-border-radius: 10px;
287 background-color: #797;
288 border: 1px solid #575;
292 -moz-border-radius: 10px;
295 background-color: #779;
296 border: 1px solid #557;
299 -moz-border-radius: 10px;
305 <div class="error">$error</div>
306 <div class="infos">$infos</div>
307 <div class="name">$name</div>
314 =item $c->finalize_headers
320 sub finalize_headers { }
322 =item $c->finalize_output
328 sub finalize_output { }
330 =item $c->forward($command)
332 Forward processing to a private action or a method from a class.
333 If you define a class without method it will default to process().
336 $c->forward('index');
337 $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
338 $c->forward('MyApp::View::TT');
346 $c->log->debug('Nothing to forward to') if $c->debug;
349 my $caller = caller(0);
351 if ( $command =~ /^\// ) {
352 $command =~ /^(.*)\/(\w+)$/;
353 $namespace = $1 || '/';
356 else { $namespace = _class2prefix($caller) || '/' }
357 my $results = $c->get_action( $command, $namespace );
358 unless ( @{$results} ) {
359 my $class = $command;
360 if ( $class =~ /[^\w\:]/ ) {
361 $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
364 my $method = shift || 'process';
365 if ( my $code = $class->can($method) ) {
366 $c->actions->{reverse}->{"$code"} = "$class->$method";
367 $results = [ [ [ $class, $code ] ] ];
370 $c->log->debug(qq/Couldn't forward to "$class->$method"/)
375 for my $result ( @{$results} ) {
376 $c->state( $c->execute( @{ $result->[0] } ) );
381 =item $c->get_action( $action, $namespace )
383 Get an action in a given namespace.
388 my ( $c, $action, $namespace ) = @_;
391 $namespace = '' if $namespace eq '/';
392 my $parent = $c->tree;
394 my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
395 push @results, [$result] if $result;
396 my $visitor = Tree::Simple::Visitor::FindByPath->new;
397 for my $part ( split '/', $namespace ) {
398 $visitor->setSearchPath($part);
399 $parent->accept($visitor);
400 my $child = $visitor->getResult;
401 my $uid = $child->getUID if $child;
402 my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
403 push @results, [$match] if $match;
404 $parent = $child if $child;
408 elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
409 elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
411 for my $i ( 0 .. $#{ $c->actions->{compiled} } ) {
412 my $name = $c->actions->{compiled}->[$i]->[0];
413 my $regex = $c->actions->{compiled}->[$i]->[1];
414 if ( $action =~ $regex ) {
416 for my $i ( 1 .. 9 ) {
419 push @snippets, ${$i};
421 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
428 =item $c->handler( $class, $r )
435 my ( $class, $engine ) = @_;
437 # Always expect worst case!
442 my $c = $class->prepare($engine);
443 $c->{stats} = \@stats;
444 my $action = $c->req->action;
446 $namespace = ( join( '/', @{ $c->req->args } ) || '/' )
447 if $action eq 'default';
448 unless ($namespace) {
449 if ( my $result = $c->get_action($action) ) {
450 $namespace = _class2prefix( $result->[0]->[0]->[0] );
453 my $default = $action eq 'default' ? $namespace : undef;
454 my $results = $c->get_action( $action, $default );
457 for my $begin ( @{ $c->get_action( 'begin', $namespace ) } ) {
458 $c->state( $c->execute( @{ $begin->[0] } ) );
460 for my $result ( @{ $c->get_action( $action, $default ) }[-1] )
462 $c->state( $c->execute( @{ $result->[0] } ) );
463 last unless $default;
465 for my $end ( reverse @{ $c->get_action( 'end', $namespace ) } )
467 $c->state( $c->execute( @{ $end->[0] } ) );
471 my $path = $c->req->path;
473 ? qq/Unknown resource "$path"/
474 : "No default action defined";
475 $c->log->error($error) if $c->debug;
480 if ( $class->debug ) {
482 ( $elapsed, $status ) = $class->benchmark($handler);
483 $elapsed = sprintf '%f', $elapsed;
484 my $av = sprintf '%.3f', 1 / $elapsed;
485 $class->log->info( "Request took $elapsed" . "s ($av/s)", @stats );
487 else { $status = &$handler }
489 if ( my $error = $@ ) {
491 $class->log->error(qq/Caught exception in engine "$error"/);
497 =item $c->prepare($r)
499 Turns the engine-specific request( Apache, CGI ... )
500 into a Catalyst context .
505 my ( $class, $r ) = @_;
507 request => Catalyst::Request->new(
511 headers => HTTP::Headers->new,
517 response => Catalyst::Response->new(
518 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
524 my $secs = time - $START || 1;
525 my $av = sprintf '%.3f', $COUNT / $secs;
526 $c->log->debug('********************************');
527 $c->log->debug("* Request $COUNT ($av/s) [$$]");
528 $c->log->debug('********************************');
529 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
531 $c->prepare_request($r);
535 $c->prepare_connection;
536 my $method = $c->req->method || '';
537 my $path = $c->req->path || '';
538 my $hostname = $c->req->hostname || '';
539 my $address = $c->req->address || '';
540 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
543 $c->prepare_parameters;
545 if ( $c->debug && keys %{ $c->req->params } ) {
547 for my $key ( keys %{ $c->req->params } ) {
548 my $value = $c->req->params->{$key} || '';
549 push @params, " $key=$value";
551 $c->log->debug( 'Parameters are', @params );
557 =item $c->prepare_action
565 my $path = $c->req->path;
566 my @path = split /\//, $c->req->path;
567 $c->req->args( \my @args );
569 $path = join '/', @path;
570 if ( my $result = ${ $c->get_action($path) }[0] ) {
574 my $match = $result->[1];
575 my @snippets = @{ $result->[2] };
576 $c->log->debug(qq/Requested action "$path" matched "$match"/)
579 'Snippets are "' . join( ' ', @snippets ) . '"' )
580 if ( $c->debug && @snippets );
581 $c->req->action($match);
582 $c->req->snippets( \@snippets );
585 $c->req->action($path);
586 $c->log->debug(qq/Requested action "$path"/) if $c->debug;
588 $c->req->match($path);
591 unshift @args, pop @path;
593 unless ( $c->req->action ) {
594 $c->req->action('default');
597 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
598 if ( $c->debug && @args );
601 =item $c->prepare_connection
607 sub prepare_connection { }
609 =item $c->prepare_cookies
615 sub prepare_cookies {
618 if ( my $header = $c->request->header('Cookie') ) {
619 $c->req->cookies( { CGI::Cookie->parse($header) } );
623 =item $c->prepare_headers
629 sub prepare_headers { }
631 =item $c->prepare_parameters
637 sub prepare_parameters { }
639 =item $c->prepare_path
641 Prepare path and base.
647 =item $c->prepare_request
649 Prepare the engine request.
653 sub prepare_request { }
655 =item $c->prepare_uploads
661 sub prepare_uploads { }
675 Returns a C<Catalyst::Request> object.
683 Returns a C<Catalyst::Response> object.
687 =item $c->set_action( $action, $code, $namespace, $attrs )
689 Set an action in a given namespace.
694 my ( $c, $method, $code, $namespace, $attrs ) = @_;
696 my $prefix = _class2prefix($namespace) || '';
699 for my $attr ( @{$attrs} ) {
700 if ( $attr =~ /^(Local|Relative)$/ ) { $flags{local}++ }
701 elsif ( $attr =~ /^(Global|Absolute)$/ ) { $flags{global}++ }
702 elsif ( $attr =~ /^Path\((.+)\)$/i ) { $flags{path} = $1 }
703 elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
704 elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
707 return unless keys %flags;
709 my $parent = $c->tree;
710 my $visitor = Tree::Simple::Visitor::FindByPath->new;
711 for my $part ( split '/', $prefix ) {
712 $visitor->setSearchPath($part);
713 $parent->accept($visitor);
714 my $child = $visitor->getResult;
716 $child = $parent->addChild( Tree::Simple->new($part) );
717 $visitor->setSearchPath($part);
718 $parent->accept($visitor);
719 $child = $visitor->getResult;
723 my $uid = $parent->getUID;
724 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
725 my $forward = $prefix ? "$prefix/$method" : $method;
727 if ( $flags{path} ) {
728 $flags{path} =~ s/^\w+//;
729 $flags{path} =~ s/\w+$//;
730 if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
731 if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
733 if ( $flags{regex} ) {
734 $flags{regex} =~ s/^\w+//;
735 $flags{regex} =~ s/\w+$//;
736 if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
737 if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
740 my $reverse = $prefix ? "$prefix/$method" : $method;
742 if ( $flags{local} || $flags{global} || $flags{path} ) {
743 my $path = $flags{path} || $method;
745 if ( $path =~ /^\/(.+)/ ) {
749 $absolute = 1 if $flags{global};
750 my $name = $absolute ? $path : "$prefix/$path";
751 $c->actions->{plain}->{$name} = [ $namespace, $code ];
753 if ( my $regex = $flags{regex} ) {
754 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
755 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
758 $c->actions->{reverse}->{"$code"} = $reverse;
771 $self->setup_components;
772 if ( $self->debug ) {
773 my $name = $self->config->{name} || 'Application';
774 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
778 =item $class->setup_actions($component)
780 Setup actions for a component.
785 my ( $self, $comp ) = @_;
786 $comp = ref $comp || $comp;
787 for my $action ( @{ $comp->_cache } ) {
788 my ( $code, $attrs ) = @{$action};
791 my @cache = ( $comp, @{"$comp\::ISA"} );
793 while ( my $namespace = shift @cache ) {
794 $namespaces{$namespace}++;
795 for my $isa ( @{"$comp\::ISA"} ) {
796 next if $namespaces{$isa};
801 for my $namespace ( keys %namespaces ) {
802 for my $sym ( values %{ $namespace . '::' } ) {
803 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
804 $name = *{$sym}{NAME};
805 $self->set_action( $name, $code, $comp, $attrs );
813 =item $class->setup_components
819 sub setup_components {
823 my $class = ref $self || $self;
826 import Module::Pluggable::Fast
827 name => '_components',
829 '$class\::Controller', '$class\::C',
830 '$class\::Model', '$class\::M',
831 '$class\::View', '$class\::V'
834 if ( my $error = $@ ) {
837 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
839 $self->setup_actions($self);
840 $self->components( {} );
841 for my $comp ( $self->_components($self) ) {
842 $self->components->{ ref $comp } = $comp;
843 $self->setup_actions($comp);
846 push @comps, " $_" for keys %{ $self->components };
847 $self->log->debug( 'Loaded components', @comps )
848 if ( @comps && $self->debug );
849 my $actions = $self->actions;
850 my @messages = ('Loaded private actions');
852 my ( $walker, $parent, $messages, $prefix ) = @_;
853 $prefix .= $parent->getNodeValue || '';
854 $prefix .= '/' unless $prefix =~ /\/$/;
855 my $uid = $parent->getUID;
856 for my $action ( keys %{ $actions->{private}->{$uid} } ) {
857 my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
858 push @$messages, _prettify( "$prefix$action", $class, $code );
860 $walker->( $walker, $_, $messages, $prefix )
861 for $parent->getAllChildren;
863 $walker->( $walker, $self->tree, \@messages, '' );
864 $self->log->debug(@messages) if ( $#messages && $self->debug );
865 @messages = ('Loaded plain actions');
866 for my $plain ( sort keys %{ $actions->{plain} } ) {
867 my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
868 push @messages, _prettify( "/$plain", $class, $code );
870 $self->log->debug(@messages) if ( $#messages && $self->debug );
871 @messages = ('Loaded regex actions');
872 for my $regex ( sort keys %{ $actions->{regex} } ) {
873 my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
874 push @messages, _prettify( $regex, $class, $code );
876 $self->log->debug(@messages) if ( $#messages && $self->debug );
881 Returns a hashref containing all your data.
883 $c->stash->{foo} ||= 'yada';
884 print $c->stash->{foo};
891 my $stash = $_[1] ? {@_} : $_[0];
892 while ( my ( $key, $val ) = each %$stash ) {
893 $self->{stash}->{$key} = $val;
896 return $self->{stash};
900 my ( $class, $name ) = @_;
901 my $prefix = _class2prefix($class);
902 $name = "$prefix/$name" if $prefix;
907 my $class = shift || '';
909 if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
911 $prefix =~ s/\:\:/\//g;
917 my ( $val1, $val2, $val3 ) = @_;
919 ' @<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<< @>>>>>>>>>>>>>> ',
930 Sebastian Riedel, C<sri@cpan.org>
934 This program is free software, you can redistribute it and/or modify it under
935 the same terms as Perl itself.