1 package Catalyst::Engine;
4 use base qw/Class::Data::Inheritable Class::Accessor::Fast/;
5 use UNIVERSAL::require;
10 use Time::HiRes qw/gettimeofday tv_interval/;
12 use Tree::Simple::Visitor::FindByPath;
13 use Catalyst::Request;
14 use Catalyst::Response;
16 require Module::Pluggable::Fast;
18 $Data::Dumper::Terse = 1;
20 __PACKAGE__->mk_classdata($_) for qw/actions components tree/;
21 __PACKAGE__->mk_accessors(qw/request response state/);
24 { plain => {}, private => {}, regex => {}, compiled => [], reverse => {} }
26 __PACKAGE__->tree( Tree::Simple->new( 0, Tree::Simple->ROOT ) );
35 memoize('_class2prefix');
39 Catalyst::Engine - The Catalyst Engine
51 =item $c->benchmark($coderef)
53 Takes a coderef with arguments and returns elapsed time as float.
55 my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
56 $c->log->info( sprintf "Processing took %f seconds", $elapsed );
63 my $time = [gettimeofday];
64 my @return = &$code(@_);
65 my $elapsed = tv_interval $time;
66 return wantarray ? ( $elapsed, @return ) : $elapsed;
71 =item $c->component($name)
73 Get a component object by name.
75 $c->comp('MyApp::Model::MyModel')->do_stuff;
77 Regex search for a component.
79 $c->comp('mymodel')->do_stuff;
84 my ( $c, $name ) = @_;
85 if ( my $component = $c->components->{$name} ) {
89 for my $component ( keys %{ $c->components } ) {
90 return $c->components->{$component} if $component =~ /$name/i;
97 =item $c->error($error, ...)
99 =item $c->error($arrayref)
101 Returns an arrayref containing error messages.
103 my @error = @{ $c->error };
107 $c->error('Something bad happened');
113 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
114 push @{ $c->{error} }, @$error;
127 if ( my $location = $c->res->redirect ) {
128 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
129 $c->res->headers->header( Location => $location );
130 $c->res->headers->remove_content_headers;
131 $c->res->status(302);
132 return $c->finalize_headers;
135 if ( !$c->res->output || $#{ $c->error } >= 0 ) {
136 $c->res->headers->content_type('text/html');
137 my $name = $c->config->{name} || 'Catalyst Application';
138 my ( $title, $error, $infos );
140 $error = join '<br/>', @{ $c->error };
141 $error ||= 'No output';
142 $title = $name = "$name on Catalyst $Catalyst::VERSION";
143 my $req = encode_entities Dumper $c->req;
144 my $res = encode_entities Dumper $c->res;
145 my $stash = encode_entities Dumper $c->stash;
148 <b><u>Request</u></b><br/>
150 <b><u>Response</u></b><br/>
152 <b><u>Stash</u></b><br/>
161 (en) Please come back later
162 (de) Bitte versuchen sie es spaeter nocheinmal
163 (nl) Gelieve te komen later terug
164 (no) Vennligst prov igjen senere
165 (fr) Veuillez revenir plus tard
166 (es) Vuelto por favor mas adelante
167 (pt) Voltado por favor mais tarde
168 (it) Ritornato prego piĆ¹ successivamente
173 $c->res->{output} = <<"";
176 <title>$title</title>
177 <style type="text/css">
179 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
180 Tahoma, Arial, helvetica, sans-serif;
182 background-color: #eee;
187 background-color: #ccc;
188 border: 1px solid #aaa;
191 -moz-border-radius: 10px;
194 background-color: #977;
195 border: 1px solid #755;
199 -moz-border-radius: 10px;
202 background-color: #797;
203 border: 1px solid #575;
207 -moz-border-radius: 10px;
210 background-color: #779;
211 border: 1px solid #557;
214 -moz-border-radius: 10px;
220 <div class="error">$error</div>
221 <div class="infos">$infos</div>
222 <div class="name">$name</div>
228 $c->res->headers->content_length( length $c->res->output );
229 my $status = $c->finalize_headers;
234 =item $c->finalize_headers
240 sub finalize_headers { }
242 =item $c->finalize_output
248 sub finalize_output { }
250 =item $c->forward($command)
252 Forward processing to a private action or a method from a class.
253 If you define a class without method it will default to process().
256 $c->forward('index');
257 $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
258 $c->forward('MyApp::View::TT');
266 $c->log->debug('Nothing to forward to') if $c->debug;
269 my $caller = caller(0);
271 if ( $command =~ /^\// ) {
272 $command =~ /^(.*)\/(\w+)$/;
273 $namespace = $1 || '/';
276 else { $namespace = _class2prefix($caller) || '/' }
277 my $results = $c->get_action( $command, $namespace );
278 unless ( @{$results} ) {
279 my $class = $command;
280 if ( $class =~ /[^\w\:]/ ) {
281 $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
284 my $method = shift || 'process';
285 if ( my $code = $class->can($method) ) {
286 $c->actions->{reverse}->{"$code"} = "$class->$method";
287 $results = [ [ [ $class, $code ] ] ];
290 $c->log->debug(qq/Couldn't forward to "$class->$method"/)
295 for my $result ( @{$results} ) {
296 $c->state( $c->execute( @{ $result->[0] } ) );
301 =item $c->get_action( $action, $namespace )
303 Get an action in a given namespace.
308 my ( $c, $action, $namespace ) = @_;
311 $namespace = '' if $namespace eq '/';
312 my $parent = $c->tree;
314 my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
315 push @results, [$result] if $result;
316 my $visitor = Tree::Simple::Visitor::FindByPath->new;
317 for my $part ( split '/', $namespace ) {
318 $visitor->setSearchPath($part);
319 $parent->accept($visitor);
320 my $child = $visitor->getResult;
321 my $uid = $child->getUID if $child;
322 my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
323 push @results, [$match] if $match;
324 $parent = $child if $child;
328 elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
329 elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
331 for my $i ( 0 .. $#{ $c->actions->{compiled} } ) {
332 my $name = $c->actions->{compiled}->[$i]->[0];
333 my $regex = $c->actions->{compiled}->[$i]->[1];
334 if ( $action =~ $regex ) {
336 for my $i ( 1 .. 9 ) {
339 push @snippets, ${$i};
341 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
348 =item $c->handler( $class, $r )
355 my ( $class, $r ) = @_;
357 # Always expect worst case!
362 my $c = $class->prepare($r);
363 $c->{stats} = \@stats;
364 my $action = $c->req->action;
366 $namespace = ( join( '/', @{ $c->req->args } ) || '/' )
367 if $action eq 'default';
368 unless ($namespace) {
369 if ( my $result = $c->get_action($action) ) {
370 $namespace = _class2prefix( $result->[0]->[0]->[0] );
373 my $default = $action eq 'default' ? $namespace : undef;
374 my $results = $c->get_action( $action, $default );
377 for my $begin ( @{ $c->get_action( 'begin', $namespace ) } ) {
378 $c->state( $c->execute( @{ $begin->[0] } ) );
380 for my $result ( @{ $c->get_action( $action, $default ) }[-1] )
382 $c->state( $c->execute( @{ $result->[0] } ) );
383 last unless $default;
385 for my $end ( reverse @{ $c->get_action( 'end', $namespace ) } )
387 $c->state( $c->execute( @{ $end->[0] } ) );
391 my $path = $c->req->path;
393 ? qq/Unknown resource "$path"/
394 : "No default action defined";
395 $c->log->error($error) if $c->debug;
400 if ( $class->debug ) {
402 ( $elapsed, $status ) = $class->benchmark($handler);
403 $elapsed = sprintf '%f', $elapsed;
404 my $av = sprintf '%.3f', 1 / $elapsed;
405 $class->log->info( "Request took $elapsed" . "s ($av/s)", @stats );
407 else { $status = &$handler }
409 if ( my $error = $@ ) {
411 $class->log->error(qq/Caught exception in engine "$error"/);
417 =item $c->prepare($r)
419 Turns the engine-specific request( Apache, CGI ... )
420 into a Catalyst context .
425 my ( $class, $r ) = @_;
427 request => Catalyst::Request->new(
431 headers => HTTP::Headers->new,
437 response => Catalyst::Response->new(
438 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
444 my $secs = time - $START || 1;
445 my $av = sprintf '%.3f', $COUNT / $secs;
446 $c->log->debug('********************************');
447 $c->log->debug("* Request $COUNT ($av/s) [$$]");
448 $c->log->debug('********************************');
449 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
451 $c->prepare_request($r);
455 $c->prepare_connection;
456 my $method = $c->req->method || '';
457 my $path = $c->req->path || '';
458 my $hostname = $c->req->hostname || '';
459 my $address = $c->req->address || '';
460 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
463 $c->prepare_parameters;
465 if ( $c->debug && keys %{ $c->req->params } ) {
467 for my $key ( keys %{ $c->req->params } ) {
468 my $value = $c->req->params->{$key} || '';
469 push @params, " $key=$value";
471 $c->log->debug( 'Parameters are', @params );
477 =item $c->prepare_action
485 my $path = $c->req->path;
486 my @path = split /\//, $c->req->path;
487 $c->req->args( \my @args );
489 $path = join '/', @path;
490 if ( my $result = ${ $c->get_action($path) }[0] ) {
494 my $match = $result->[1];
495 my @snippets = @{ $result->[2] };
496 $c->log->debug(qq/Requested action "$path" matched "$match"/)
499 'Snippets are "' . join( ' ', @snippets ) . '"' )
500 if ( $c->debug && @snippets );
501 $c->req->action($match);
502 $c->req->snippets( \@snippets );
505 $c->req->action($path);
506 $c->log->debug(qq/Requested action "$path"/) if $c->debug;
508 $c->req->match($path);
511 unshift @args, pop @path;
513 unless ( $c->req->action ) {
514 $c->req->action('default');
517 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
518 if ( $c->debug && @args );
521 =item $c->prepare_connection
527 sub prepare_connection { }
529 =item $c->prepare_cookies
535 sub prepare_cookies { }
537 =item $c->prepare_headers
543 sub prepare_headers { }
545 =item $c->prepare_parameters
551 sub prepare_parameters { }
553 =item $c->prepare_path
555 Prepare path and base.
561 =item $c->prepare_request
563 Prepare the engine request.
567 sub prepare_request { }
569 =item $c->prepare_uploads
575 sub prepare_uploads { }
577 =item $c->execute($class, $coderef)
579 Execute a coderef in given class and catch exceptions.
580 Errors are available via $c->error.
585 my ( $c, $class, $code ) = @_;
586 $class = $c->comp($class) || $class;
591 my $action = $c->actions->{reverse}->{"$code"};
592 $action = "/$action" unless $action =~ /\-\>/;
593 my ( $elapsed, @state ) =
594 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
595 push @{ $c->{stats} },
596 _prettify( $action, '', sprintf( '%fs', $elapsed ) );
599 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
601 if ( my $error = $@ ) {
603 $error = qq/Caught exception "$error"/;
604 $c->log->error($error);
605 $c->error($error) if $c->debug;
623 Returns a C<Catalyst::Request> object.
631 Returns a C<Catalyst::Response> object.
635 =item $c->set_action( $action, $code, $namespace, $attrs )
637 Set an action in a given namespace.
642 my ( $c, $method, $code, $namespace, $attrs ) = @_;
644 my $prefix = _class2prefix($namespace) || '';
647 for my $attr ( @{$attrs} ) {
648 if ( $attr =~ /^(Local|Relative)$/ ) { $flags{local}++ }
649 elsif ( $attr =~ /^(Global|Absolute)$/ ) { $flags{global}++ }
650 elsif ( $attr =~ /^Path\((.+)\)$/i ) { $flags{path} = $1 }
651 elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
652 elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
655 return unless keys %flags;
657 my $parent = $c->tree;
658 my $visitor = Tree::Simple::Visitor::FindByPath->new;
659 for my $part ( split '/', $prefix ) {
660 $visitor->setSearchPath($part);
661 $parent->accept($visitor);
662 my $child = $visitor->getResult;
664 $child = $parent->addChild( Tree::Simple->new($part) );
665 $visitor->setSearchPath($part);
666 $parent->accept($visitor);
667 $child = $visitor->getResult;
671 my $uid = $parent->getUID;
672 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
673 my $forward = $prefix ? "$prefix/$method" : $method;
675 if ( $flags{path} ) {
676 $flags{path} =~ s/^\w+//;
677 $flags{path} =~ s/\w+$//;
678 if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
679 if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
681 if ( $flags{regex} ) {
682 $flags{regex} =~ s/^\w+//;
683 $flags{regex} =~ s/\w+$//;
684 if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
685 if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
688 my $reverse = $prefix ? "$prefix/$method" : $method;
690 if ( $flags{local} || $flags{global} || $flags{path} ) {
691 my $path = $flags{path} || $method;
693 if ( $path =~ /^\/(.+)/ ) {
697 $absolute = 1 if $flags{global};
698 my $name = $absolute ? $path : "$prefix/$path";
699 $c->actions->{plain}->{$name} = [ $namespace, $code ];
701 if ( my $regex = $flags{regex} ) {
702 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
703 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
706 $c->actions->{reverse}->{"$code"} = $reverse;
719 $self->setup_components;
720 if ( $self->debug ) {
721 my $name = $self->config->{name} || 'Application';
722 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
726 =item $class->setup_actions($component)
728 Setup actions for a component.
733 my ( $self, $comp ) = @_;
734 $comp = ref $comp || $comp;
735 for my $action ( @{ $comp->_cache } ) {
736 my ( $code, $attrs ) = @{$action};
739 my @cache = ( $comp, @{"$comp\::ISA"} );
741 while ( my $namespace = shift @cache ) {
742 $namespaces{$namespace}++;
743 for my $isa ( @{"$comp\::ISA"} ) {
744 next if $namespaces{$isa};
749 for my $namespace ( keys %namespaces ) {
750 for my $sym ( values %{ $namespace . '::' } ) {
751 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
752 $name = *{$sym}{NAME};
753 $self->set_action( $name, $code, $comp, $attrs );
761 =item $class->setup_components
767 sub setup_components {
771 my $class = ref $self || $self;
774 import Module::Pluggable::Fast
775 name => '_components',
777 '$class\::Controller', '$class\::C',
778 '$class\::Model', '$class\::M',
779 '$class\::View', '$class\::V'
782 if ( my $error = $@ ) {
785 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
787 $self->setup_actions($self);
788 $self->components( {} );
789 for my $comp ( $self->_components($self) ) {
790 $self->components->{ ref $comp } = $comp;
791 $self->setup_actions($comp);
794 push @comps, " $_" for keys %{ $self->components };
795 $self->log->debug( 'Loaded components', @comps )
796 if ( @comps && $self->debug );
797 my $actions = $self->actions;
798 my @messages = ('Loaded private actions');
800 my ( $walker, $parent, $messages, $prefix ) = @_;
801 $prefix .= $parent->getNodeValue || '';
802 $prefix .= '/' unless $prefix =~ /\/$/;
803 my $uid = $parent->getUID;
804 for my $action ( keys %{ $actions->{private}->{$uid} } ) {
805 my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
806 push @$messages, _prettify( "$prefix$action", $class, $code );
808 $walker->( $walker, $_, $messages, $prefix )
809 for $parent->getAllChildren;
811 $walker->( $walker, $self->tree, \@messages, '' );
812 $self->log->debug(@messages) if ( $#messages && $self->debug );
813 @messages = ('Loaded plain actions');
814 for my $plain ( sort keys %{ $actions->{plain} } ) {
815 my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
816 push @messages, _prettify( "/$plain", $class, $code );
818 $self->log->debug(@messages) if ( $#messages && $self->debug );
819 @messages = ('Loaded regex actions');
820 for my $regex ( sort keys %{ $actions->{regex} } ) {
821 my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
822 push @messages, _prettify( $regex, $class, $code );
824 $self->log->debug(@messages) if ( $#messages && $self->debug );
829 Returns a hashref containing all your data.
831 $c->stash->{foo} ||= 'yada';
832 print $c->stash->{foo};
839 my $stash = $_[1] ? {@_} : $_[0];
840 while ( my ( $key, $val ) = each %$stash ) {
841 $self->{stash}->{$key} = $val;
844 return $self->{stash};
848 my ( $class, $name ) = @_;
849 my $prefix = _class2prefix($class);
850 $name = "$prefix/$name" if $prefix;
855 my $class = shift || '';
857 if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
859 $prefix =~ s/\:\:/\//g;
865 my ( $val1, $val2, $val3 ) = @_;
867 ' @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<< @>>>>>>>>>>>>>> ',
878 Sebastian Riedel, C<sri@cpan.org>
882 This program is free software, you can redistribute it and/or modify it under
883 the same terms as Perl itself.