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!
361 my $c = $class->prepare($r);
362 my $action = $c->req->action;
364 $namespace = ( join( '/', @{ $c->req->args } ) || '/' )
365 if $action eq 'default';
366 unless ($namespace) {
367 if ( my $result = $c->get_action($action) ) {
368 $namespace = _class2prefix( $result->[0]->[0]->[0] );
371 my $default = $action eq 'default' ? $namespace : undef;
372 my $results = $c->get_action( $action, $default );
375 for my $begin ( @{ $c->get_action( 'begin', $namespace ) } ) {
376 $c->state( $c->execute( @{ $begin->[0] } ) );
378 for my $result ( @{ $c->get_action( $action, $default ) }[-1] )
380 $c->state( $c->execute( @{ $result->[0] } ) );
381 last unless $default;
383 for my $end ( reverse @{ $c->get_action( 'end', $namespace ) } )
385 $c->state( $c->execute( @{ $end->[0] } ) );
389 my $path = $c->req->path;
391 ? qq/Unknown resource "$path"/
392 : "No default action defined";
393 $c->log->error($error) if $c->debug;
398 if ( $class->debug ) {
400 ( $elapsed, $status ) = $class->benchmark($handler);
401 $elapsed = sprintf '%f', $elapsed;
402 my $av = sprintf '%.3f', 1 / $elapsed;
403 $class->log->info( "Request took $elapsed" . "s ($av/s)" );
405 else { $status = &$handler }
407 if ( my $error = $@ ) {
409 $class->log->error(qq/Caught exception in engine "$error"/);
415 =item $c->prepare($r)
417 Turns the engine-specific request( Apache, CGI ... )
418 into a Catalyst context .
423 my ( $class, $r ) = @_;
425 request => Catalyst::Request->new(
429 headers => HTTP::Headers->new,
435 response => Catalyst::Response->new(
436 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
442 my $secs = time - $START || 1;
443 my $av = sprintf '%.3f', $COUNT / $secs;
444 $c->log->debug('********************************');
445 $c->log->debug("* Request $COUNT ($av/s) [$$]");
446 $c->log->debug('********************************');
447 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
449 $c->prepare_request($r);
453 $c->prepare_connection;
454 my $method = $c->req->method || '';
455 my $path = $c->req->path || '';
456 my $hostname = $c->req->hostname || '';
457 my $address = $c->req->address || '';
458 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
461 $c->prepare_parameters;
463 if ( $c->debug && keys %{ $c->req->params } ) {
465 for my $key ( keys %{ $c->req->params } ) {
466 my $value = $c->req->params->{$key} || '';
467 push @params, "$key=$value";
469 $c->log->debug( 'Parameters are "' . join( ' ', @params ) . '"' );
475 =item $c->prepare_action
483 my $path = $c->req->path;
484 my @path = split /\//, $c->req->path;
485 $c->req->args( \my @args );
487 $path = join '/', @path;
488 if ( my $result = ${ $c->get_action($path) }[0] ) {
492 my $match = $result->[1];
493 my @snippets = @{ $result->[2] };
494 $c->log->debug(qq/Requested action "$path" matched "$match"/)
497 'Snippets are "' . join( ' ', @snippets ) . '"' )
498 if ( $c->debug && @snippets );
499 $c->req->action($match);
500 $c->req->snippets( \@snippets );
503 $c->req->action($path);
504 $c->log->debug(qq/Requested action "$path"/) if $c->debug;
506 $c->req->match($path);
509 unshift @args, pop @path;
511 unless ( $c->req->action ) {
512 $c->req->action('default');
515 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
516 if ( $c->debug && @args );
519 =item $c->prepare_connection
525 sub prepare_connection { }
527 =item $c->prepare_cookies
533 sub prepare_cookies { }
535 =item $c->prepare_headers
541 sub prepare_headers { }
543 =item $c->prepare_parameters
549 sub prepare_parameters { }
551 =item $c->prepare_path
553 Prepare path and base.
559 =item $c->prepare_request
561 Prepare the engine request.
565 sub prepare_request { }
567 =item $c->prepare_uploads
573 sub prepare_uploads { }
575 =item $c->execute($class, $coderef)
577 Execute a coderef in given class and catch exceptions.
578 Errors are available via $c->error.
583 my ( $c, $class, $code ) = @_;
584 $class = $c->comp($class) || $class;
589 my $action = $c->actions->{reverse}->{"$code"} || "$code";
590 my ( $elapsed, @state ) =
591 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
592 $c->log->info( sprintf qq/Processing "$action" took %fs/, $elapsed )
596 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
598 if ( my $error = $@ ) {
600 $error = qq/Caught exception "$error"/;
601 $c->log->error($error);
602 $c->error($error) if $c->debug;
620 Returns a C<Catalyst::Request> object.
628 Returns a C<Catalyst::Response> object.
632 =item $c->set_action( $action, $code, $namespace, $attrs )
634 Set an action in a given namespace.
639 my ( $c, $method, $code, $namespace, $attrs ) = @_;
641 my $prefix = _class2prefix($namespace) || '';
644 for my $attr ( @{$attrs} ) {
645 if ( $attr =~ /^(Local|Relative)$/ ) { $flags{local}++ }
646 elsif ( $attr =~ /^(Global|Absolute)$/ ) { $flags{global}++ }
647 elsif ( $attr =~ /^Path\((.+)\)$/i ) { $flags{path} = $1 }
648 elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
649 elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
652 return unless keys %flags;
654 my $parent = $c->tree;
655 my $visitor = Tree::Simple::Visitor::FindByPath->new;
656 for my $part ( split '/', $prefix ) {
657 $visitor->setSearchPath($part);
658 $parent->accept($visitor);
659 my $child = $visitor->getResult;
661 $child = $parent->addChild( Tree::Simple->new($part) );
662 $visitor->setSearchPath($part);
663 $parent->accept($visitor);
664 $child = $visitor->getResult;
668 my $uid = $parent->getUID;
669 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
670 my $forward = $prefix ? "$prefix/$method" : $method;
671 $c->log->debug(qq|Private "/$forward" is "$namespace->$method"|)
674 if ( $flags{path} ) {
675 $flags{path} =~ s/^\w+//;
676 $flags{path} =~ s/\w+$//;
677 if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
678 if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
680 if ( $flags{regex} ) {
681 $flags{regex} =~ s/^\w+//;
682 $flags{regex} =~ s/\w+$//;
683 if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
684 if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
687 my $reverse = $prefix ? "$method ($prefix)" : $method;
689 if ( $flags{local} || $flags{global} || $flags{path} ) {
690 my $path = $flags{path} || $method;
692 if ( $path =~ /^\/(.+)/ ) {
696 $absolute = 1 if $flags{global};
697 my $name = $absolute ? $path : "$prefix/$path";
698 $c->actions->{plain}->{$name} = [ $namespace, $code ];
699 $c->log->debug(qq|Public "/$name" is "/$forward"|) if $c->debug;
701 if ( my $regex = $flags{regex} ) {
702 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
703 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
704 $c->log->debug(qq|Public "$regex" is "/$forward"|) if $c->debug;
707 $c->actions->{reverse}->{"$code"} = $reverse;
720 $self->setup_components;
721 if ( $self->debug ) {
722 my $name = $self->config->{name} || 'Application';
723 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
727 =item $class->setup_actions($component)
729 Setup actions for a component.
734 my ( $self, $comp ) = @_;
735 $comp = ref $comp || $comp;
736 for my $action ( @{ $comp->_cache } ) {
737 my ( $code, $attrs ) = @{$action};
740 my @cache = ( $comp, @{"$comp\::ISA"} );
742 while ( my $namespace = shift @cache ) {
743 $namespaces{$namespace}++;
744 for my $isa ( @{"$comp\::ISA"} ) {
745 next if $namespaces{$isa};
750 for my $namespace ( keys %namespaces ) {
751 for my $sym ( values %{ $namespace . '::' } ) {
752 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
753 $name = *{$sym}{NAME};
754 $self->set_action( $name, $code, $comp, $attrs );
762 =item $class->setup_components
768 sub setup_components {
772 my $class = ref $self || $self;
775 import Module::Pluggable::Fast
776 name => '_components',
778 '$class\::Controller', '$class\::C',
779 '$class\::Model', '$class\::M',
780 '$class\::View', '$class\::V'
783 if ( my $error = $@ ) {
786 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
788 $self->setup_actions($self);
789 $self->components( {} );
790 for my $comp ( $self->_components($self) ) {
791 $self->components->{ ref $comp } = $comp;
792 $self->setup_actions($comp);
794 $self->log->debug( 'Initialized components "'
795 . join( ' ', keys %{ $self->components } )
802 Returns a hashref containing all your data.
804 $c->stash->{foo} ||= 'yada';
805 print $c->stash->{foo};
812 my $stash = $_[1] ? {@_} : $_[0];
813 while ( my ( $key, $val ) = each %$stash ) {
814 $self->{stash}->{$key} = $val;
817 return $self->{stash};
821 my ( $class, $name ) = @_;
822 my $prefix = _class2prefix($class);
823 $name = "$prefix/$name" if $prefix;
828 my $class = shift || '';
830 if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
832 $prefix =~ s/\:\:/\//g;
841 Sebastian Riedel, C<sri@cpan.org>
845 This program is free software, you can redistribute it and/or modify it under
846 the same terms as Perl itself.