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->action( $name => $coderef, ... )
53 Add one or more actions.
55 $c->action( '!foo' => sub { $_[1]->res->output('Foo!') } );
57 It also automatically calls setup() if needed.
59 See L<Catalyst::Manual::Intro> for more informations about actions.
65 $self->setup unless $self->components;
66 $self->actions( {} ) unless $self->actions;
68 $_[1] ? ( $action = {@_} ) : ( $action = shift );
69 if ( ref $action eq 'HASH' ) {
70 while ( my ( $name, $code ) = each %$action ) {
71 $self->set_action( $name, $code, caller(0) );
77 =item $c->get_action( $action, $namespace )
79 Get an action in a given namespace.
84 my ( $c, $action, $namespace ) = @_;
86 if ( $action =~ /^\!(.*)/ ) {
88 my $parent = $c->tree;
90 my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
91 push @results, [$result] if $result;
92 my $visitor = Tree::Simple::Visitor::FindByPath->new;
93 for my $part ( split '/', $namespace ) {
94 $visitor->setSearchPath($part);
95 $parent->accept($visitor);
96 my $child = $visitor->getResult;
97 my $uid = $child->getUID if $child;
98 my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
99 push @results, [$match] if $match;
100 $parent = $child if $child;
104 elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
105 elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
107 for my $regex ( keys %{ $c->actions->{compiled} } ) {
108 my $name = $c->actions->{compiled}->{$regex};
109 if ( $action =~ $regex ) {
111 for my $i ( 1 .. 9 ) {
114 push @snippets, ${$i};
116 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
123 =item $c->set_action( $action, $code, $namespace )
125 Set an action in a given namespace.
130 my ( $c, $action, $code, $namespace ) = @_;
133 if ( $action =~ /^\?(.*)$/ ) {
134 my $prefix = $1 || '';
136 $action = $prefix . _prefix( $namespace, $action );
137 $c->actions->{plain}->{$action} = [ $namespace, $code ];
139 if ( $action =~ /^\/(.*)\/$/ ) {
141 $c->actions->{compiled}->{qr#$regex#} = $action;
142 $c->actions->{regex}->{$action} = [ $namespace, $code ];
144 elsif ( $action =~ /^\!(.*)$/ ) {
146 my $parent = $c->tree;
147 my $visitor = Tree::Simple::Visitor::FindByPath->new;
148 $prefix = _class2prefix($namespace);
149 for my $part ( split '/', $prefix ) {
150 $visitor->setSearchPath($part);
151 $parent->accept($visitor);
152 my $child = $visitor->getResult;
154 $child = $parent->addChild( Tree::Simple->new($part) );
155 $visitor->setSearchPath($part);
156 $parent->accept($visitor);
157 $child = $visitor->getResult;
161 my $uid = $parent->getUID;
162 $c->actions->{private}->{$uid}->{$action} = [ $namespace, $code ];
163 $action = "!$action";
166 $c->actions->{plain}->{$action} = [ $namespace, $code ]
169 my $reverse = $prefix ? "$action ($prefix)" : $action;
170 $c->actions->{reverse}->{"$code"} = $reverse;
172 $c->log->debug(qq/"$namespace" defined "$action" as "$code"/)
176 =item $c->benchmark($coderef)
178 Takes a coderef with arguments and returns elapsed time as float.
180 my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
181 $c->log->info( sprintf "Processing took %f seconds", $elapsed );
188 my $time = [gettimeofday];
189 my @return = &$code(@_);
190 my $elapsed = tv_interval $time;
191 return wantarray ? ( $elapsed, @return ) : $elapsed;
194 =item $c->comp($name)
196 =item $c->component($name)
198 Get a component object by name.
200 $c->comp('MyApp::Model::MyModel')->do_stuff;
202 Regex search for a component.
204 $c->comp('mymodel')->do_stuff;
209 my ( $c, $name ) = @_;
210 if ( my $component = $c->components->{$name} ) {
214 for my $component ( keys %{ $c->components } ) {
215 return $c->components->{$component} if $component =~ /$name/i;
222 =item $c->errors($error, ...)
224 =item $c->errors($arrayref)
226 Returns an arrayref containing errors messages.
228 my @errors = @{ $c->errors };
232 $c->errors('Something bad happened');
238 my $errors = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
239 push @{ $c->{errors} }, @$errors;
252 if ( my $location = $c->res->redirect ) {
253 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
254 $c->res->headers->header( Location => $location );
255 $c->res->status(302);
258 if ( !$c->res->output || $#{ $c->errors } >= 0 ) {
259 $c->res->headers->content_type('text/html');
260 my $name = $c->config->{name} || 'Catalyst Application';
261 my ( $title, $errors, $infos );
263 $errors = join '<br/>', @{ $c->errors };
264 $errors ||= 'No output';
265 $title = $name = "$name on Catalyst $Catalyst::VERSION";
266 my $req = encode_entities Dumper $c->req;
267 my $res = encode_entities Dumper $c->res;
268 my $stash = encode_entities Dumper $c->stash;
271 <b><u>Request</u></b><br/>
273 <b><u>Response</u></b><br/>
275 <b><u>Stash</u></b><br/>
284 (en) Please come back later
285 (de) Bitte versuchen sie es spaeter nocheinmal
286 (nl) Gelieve te komen later terug
287 (no) Vennligst prov igjen senere
288 (fr) Veuillez revenir plus tard
289 (es) Vuelto por favor mas adelante
290 (pt) Voltado por favor mais tarde
291 (it) Ritornato prego piĆ¹ successivamente
296 $c->res->{output} = <<"";
299 <title>$title</title>
300 <style type="text/css">
302 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
303 Tahoma, Arial, helvetica, sans-serif;
305 background-color: #eee;
310 background-color: #ccc;
311 border: 1px solid #aaa;
314 -moz-border-radius: 10px;
317 background-color: #977;
318 border: 1px solid #755;
322 -moz-border-radius: 10px;
325 background-color: #797;
326 border: 1px solid #575;
330 -moz-border-radius: 10px;
333 background-color: #779;
334 border: 1px solid #557;
337 -moz-border-radius: 10px;
343 <div class="errors">$errors</div>
344 <div class="infos">$infos</div>
345 <div class="name">$name</div>
351 $c->res->headers->content_length( length $c->res->output );
352 my $status = $c->finalize_headers;
357 =item $c->finalize_headers
363 sub finalize_headers { }
365 =item $c->finalize_output
371 sub finalize_output { }
373 =item $c->forward($command)
375 Forward processing to a private/public action or a method from a class.
376 If you define a class without method it will default to process().
379 $c->forward('index.html');
380 $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
381 $c->forward('MyApp::View::TT');
389 $c->log->debug('Nothing to forward to') if $c->debug;
392 my $caller = caller(0);
393 if ( $command =~ /^\?(.*)$/ ) {
395 $command = _prefix( $caller, $command );
398 if ( $command =~ /^\!/ ) {
399 $namespace = _class2prefix($caller);
401 if ( my $results = $c->get_action( $command, $namespace ) ) {
402 if ( $command =~ /^\!/ ) {
403 for my $result ( @{$results} ) {
404 my ( $class, $code ) = @{ $result->[0] };
405 $c->state( $c->process( $class, $code ) );
409 return 0 unless my $result = $results->[0];
410 if ( $result->[2] ) {
411 $c->log->debug(qq/Couldn't forward "$command" to regex action/)
415 my ( $class, $code ) = @{ $result->[0] };
416 $class = $c->components->{$class} || $class;
417 $c->state( $c->process( $class, $code ) );
421 my $class = $command;
422 if ( $class =~ /[^\w\:]/ ) {
423 $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
426 my $method = shift || 'process';
427 if ( my $code = $class->can($method) ) {
428 $c->actions->{reverse}->{"$code"} = "$class->$method";
429 $c->state( $c->process( $class, $code ) );
432 $c->log->debug(qq/Couldn't forward to "$class->$method"/)
440 =item $c->handler($r)
447 my ( $class, $r ) = @_;
449 # Always expect worst case!
453 my $c = $class->prepare($r);
454 my $action = $c->req->action;
456 $namespace = join '/', @{ $c->req->args } if $action eq '!default';
457 unless ($namespace) {
458 if ( my $result = $c->get_action($action) ) {
459 $namespace = _class2prefix( $result->[0]->[0]->[0] );
462 my $results = $c->get_action( $action, $namespace );
464 for my $begin ( @{ $c->get_action( '!begin', $namespace ) } ) {
465 $c->state( $c->process( @{ $begin->[0] } ) );
467 for my $result ( @{ $c->get_action( $action, $namespace ) } ) {
468 $c->state( $c->process( @{ $result->[0] } ) );
470 for my $end ( @{ $c->get_action( '!end', $namespace ) } ) {
471 $c->state( $c->process( @{ $end->[0] } ) );
475 my $path = $c->req->path;
477 ? qq/Unknown resource "$path"/
478 : "No default action defined";
479 $c->log->error($error) if $c->debug;
484 if ( $class->debug ) {
486 ( $elapsed, $status ) = $class->benchmark($handler);
487 $elapsed = sprintf '%f', $elapsed;
488 my $av = sprintf '%.3f', 1 / $elapsed;
489 $class->log->info( "Request took $elapsed" . "s ($av/s)" );
491 else { $status = &$handler }
493 if ( my $error = $@ ) {
495 $class->log->error(qq/Caught exception in engine "$error"/);
501 =item $c->prepare($r)
503 Turns the engine-specific request (Apache, CGI...) into a Catalyst context.
508 my ( $class, $r ) = @_;
510 request => Catalyst::Request->new(
514 headers => HTTP::Headers->new,
520 response => Catalyst::Response->new(
521 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
527 my $secs = time - $START || 1;
528 my $av = sprintf '%.3f', $COUNT / $secs;
529 $c->log->debug('********************************');
530 $c->log->debug("* Request $COUNT ($av/s) [$$]");
531 $c->log->debug('********************************');
532 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
534 $c->prepare_request($r);
538 $c->prepare_connection;
539 my $method = $c->req->method || '';
540 my $path = $c->req->path || '';
541 my $hostname = $c->req->hostname || '';
542 my $address = $c->req->address || '';
543 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
546 $c->prepare_parameters;
548 if ( $c->debug && keys %{ $c->req->params } ) {
550 for my $key ( keys %{ $c->req->params } ) {
551 my $value = $c->req->params->{$key} || '';
552 push @params, "$key=$value";
554 $c->log->debug( 'Parameters are "' . join( ' ', @params ) . '"' );
560 =item $c->prepare_action
568 my $path = $c->req->path;
569 my @path = split /\//, $c->req->path;
570 $c->req->args( \my @args );
572 $path = join '/', @path;
573 if ( my $result = ${ $c->get_action($path) }[0] ) {
577 my $match = $result->[1];
578 my @snippets = @{ $result->[2] };
579 $c->log->debug(qq/Requested action "$path" matched "$match"/)
582 'Snippets are "' . join( ' ', @snippets ) . '"' )
583 if ( $c->debug && @snippets );
584 $c->req->action($match);
585 $c->req->snippets( \@snippets );
588 $c->req->action($path);
589 $c->log->debug(qq/Requested action "$path"/) if $c->debug;
591 $c->req->match($path);
594 unshift @args, pop @path;
596 unless ( $c->req->action ) {
597 $c->req->action('!default');
600 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
601 if ( $c->debug && @args );
604 =item $c->prepare_connection;
610 sub prepare_connection { }
612 =item $c->prepare_cookies;
618 sub prepare_cookies { }
620 =item $c->prepare_headers
626 sub prepare_headers { }
628 =item $c->prepare_parameters
634 sub prepare_parameters { }
636 =item $c->prepare_path
638 Prepare path and base.
644 =item $c->prepare_request
646 Prepare the engine request.
650 sub prepare_request { }
652 =item $c->prepare_uploads
658 sub prepare_uploads { }
660 =item $c->process($class, $coderef)
662 Process a coderef in given class and catch exceptions.
663 Errors are available via $c->errors.
668 my ( $c, $class, $code ) = @_;
673 my $action = $c->actions->{reverse}->{"$code"} || "$code";
675 ( $elapsed, $status ) =
676 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
677 $c->log->info( sprintf qq/Processing "$action" took %fs/, $elapsed )
680 else { $status = &$code( $class, $c, @{ $c->req->args } ) }
682 if ( my $error = $@ ) {
684 $error = qq/Caught exception "$error"/;
685 $c->log->error($error);
686 $c->errors($error) if $c->debug;
696 Returns a C<Catalyst::Request> object.
704 Returns a C<Catalyst::Response> object.
718 $self->setup_components;
719 if ( $self->debug ) {
720 my $name = $self->config->{name} || 'Application';
721 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
725 =item $class->setup_components
731 sub setup_components {
735 my $class = ref $self || $self;
738 import Module::Pluggable::Fast
739 name => '_components',
741 '$class\::Controller', '$class\::C',
742 '$class\::Model', '$class\::M',
743 '$class\::View', '$class\::V'
746 if ( my $error = $@ ) {
749 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
751 $self->components( {} );
752 for my $component ( $self->_components($self) ) {
753 $self->components->{ ref $component } = $component;
755 $self->log->debug( 'Initialized components "'
756 . join( ' ', keys %{ $self->components } )
763 Returns a hashref containing all your data.
765 $c->stash->{foo} ||= 'yada';
766 print $c->stash->{foo};
773 my $stash = $_[1] ? {@_} : $_[0];
774 while ( my ( $key, $val ) = each %$stash ) {
775 $self->{stash}->{$key} = $val;
778 return $self->{stash};
782 my ( $class, $name ) = @_;
783 my $prefix = _class2prefix($class);
784 $name = "$prefix/$name" if $prefix;
789 my $class = shift || '';
790 $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/;
791 my $prefix = lc $2 || '';
792 $prefix =~ s/\:\:/\//g;
800 Sebastian Riedel, C<sri@cpan.org>
804 This program is free software, you can redistribute it and/or modify it under
805 the same terms as Perl itself.