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->status(302);
133 if ( !$c->res->output || $#{ $c->error } >= 0 ) {
134 $c->res->headers->content_type('text/html');
135 my $name = $c->config->{name} || 'Catalyst Application';
136 my ( $title, $error, $infos );
138 $error = join '<br/>', @{ $c->error };
139 $error ||= 'No output';
140 $title = $name = "$name on Catalyst $Catalyst::VERSION";
141 my $req = encode_entities Dumper $c->req;
142 my $res = encode_entities Dumper $c->res;
143 my $stash = encode_entities Dumper $c->stash;
146 <b><u>Request</u></b><br/>
148 <b><u>Response</u></b><br/>
150 <b><u>Stash</u></b><br/>
159 (en) Please come back later
160 (de) Bitte versuchen sie es spaeter nocheinmal
161 (nl) Gelieve te komen later terug
162 (no) Vennligst prov igjen senere
163 (fr) Veuillez revenir plus tard
164 (es) Vuelto por favor mas adelante
165 (pt) Voltado por favor mais tarde
166 (it) Ritornato prego piĆ¹ successivamente
171 $c->res->{output} = <<"";
174 <title>$title</title>
175 <style type="text/css">
177 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
178 Tahoma, Arial, helvetica, sans-serif;
180 background-color: #eee;
185 background-color: #ccc;
186 border: 1px solid #aaa;
189 -moz-border-radius: 10px;
192 background-color: #977;
193 border: 1px solid #755;
197 -moz-border-radius: 10px;
200 background-color: #797;
201 border: 1px solid #575;
205 -moz-border-radius: 10px;
208 background-color: #779;
209 border: 1px solid #557;
212 -moz-border-radius: 10px;
218 <div class="error">$error</div>
219 <div class="infos">$infos</div>
220 <div class="name">$name</div>
226 $c->res->headers->content_length( length $c->res->output );
227 my $status = $c->finalize_headers;
232 =item $c->finalize_headers
238 sub finalize_headers { }
240 =item $c->finalize_output
246 sub finalize_output { }
248 =item $c->forward($command)
250 Forward processing to a private action or a method from a class.
251 If you define a class without method it will default to process().
254 $c->forward('index');
255 $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
256 $c->forward('MyApp::View::TT');
264 $c->log->debug('Nothing to forward to') if $c->debug;
267 my $caller = caller(0);
269 if ( $command =~ /^\/(.*)$/ ) { $command = $1 }
270 else { $namespace = _class2prefix($caller) || '/' }
271 my $results = $c->get_action( $command, $namespace );
272 unless ( @{$results} ) {
273 my $class = $command;
274 if ( $class =~ /[^\w\:]/ ) {
275 $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
278 my $method = shift || 'process';
279 if ( my $code = $class->can($method) ) {
280 $c->actions->{reverse}->{"$code"} = "$class->$method";
281 $results = [ [ [ $class, $code ] ] ];
284 $c->log->debug(qq/Couldn't forward to "$class->$method"/)
289 for my $result ( @{$results} ) {
290 $c->state( $c->execute( @{ $result->[0] } ) );
295 =item $c->get_action( $action, $namespace )
297 Get an action in a given namespace.
302 my ( $c, $action, $namespace ) = @_;
305 $namespace = '' if $namespace eq '/';
306 my $parent = $c->tree;
308 my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
309 push @results, [$result] if $result;
310 my $visitor = Tree::Simple::Visitor::FindByPath->new;
311 for my $part ( split '/', $namespace ) {
312 $visitor->setSearchPath($part);
313 $parent->accept($visitor);
314 my $child = $visitor->getResult;
315 my $uid = $child->getUID if $child;
316 my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
317 push @results, [$match] if $match;
318 $parent = $child if $child;
322 elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
323 elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
325 for my $i ( 0 .. $#{ $c->actions->{compiled} } ) {
326 my $name = $c->actions->{compiled}->[$i]->[0];
327 my $regex = $c->actions->{compiled}->[$i]->[1];
328 if ( $action =~ $regex ) {
330 for my $i ( 1 .. 9 ) {
333 push @snippets, ${$i};
335 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
342 =item $c->handler( $class, $r )
349 my ( $class, $r ) = @_;
351 # Always expect worst case!
355 my $c = $class->prepare($r);
356 my $action = $c->req->action;
358 $namespace = ( join( '/', @{ $c->req->args } ) || '/' )
359 if $action eq 'default';
360 unless ($namespace) {
361 if ( my $result = $c->get_action($action) ) {
362 $namespace = _class2prefix( $result->[0]->[0]->[0] );
365 my $default = $action eq 'default' ? $namespace : undef;
366 my $results = $c->get_action( $action, $default );
369 for my $begin ( @{ $c->get_action( 'begin', $namespace ) } ) {
370 $c->state( $c->execute( @{ $begin->[0] } ) );
372 for my $result ( @{ $c->get_action( $action, $default ) } ) {
373 $c->state( $c->execute( @{ $result->[0] } ) );
374 last unless $default;
376 for my $end ( @{ $c->get_action( 'end', $namespace ) } ) {
377 $c->state( $c->execute( @{ $end->[0] } ) );
381 my $path = $c->req->path;
383 ? qq/Unknown resource "$path"/
384 : "No default action defined";
385 $c->log->error($error) if $c->debug;
390 if ( $class->debug ) {
392 ( $elapsed, $status ) = $class->benchmark($handler);
393 $elapsed = sprintf '%f', $elapsed;
394 my $av = sprintf '%.3f', 1 / $elapsed;
395 $class->log->info( "Request took $elapsed" . "s ($av/s)" );
397 else { $status = &$handler }
399 if ( my $error = $@ ) {
401 $class->log->error(qq/Caught exception in engine "$error"/);
407 =item $c->prepare($r)
409 Turns the engine-specific request( Apache, CGI ... )
410 into a Catalyst context .
415 my ( $class, $r ) = @_;
417 request => Catalyst::Request->new(
421 headers => HTTP::Headers->new,
427 response => Catalyst::Response->new(
428 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
434 my $secs = time - $START || 1;
435 my $av = sprintf '%.3f', $COUNT / $secs;
436 $c->log->debug('********************************');
437 $c->log->debug("* Request $COUNT ($av/s) [$$]");
438 $c->log->debug('********************************');
439 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
441 $c->prepare_request($r);
445 $c->prepare_connection;
446 my $method = $c->req->method || '';
447 my $path = $c->req->path || '';
448 my $hostname = $c->req->hostname || '';
449 my $address = $c->req->address || '';
450 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
453 $c->prepare_parameters;
455 if ( $c->debug && keys %{ $c->req->params } ) {
457 for my $key ( keys %{ $c->req->params } ) {
458 my $value = $c->req->params->{$key} || '';
459 push @params, "$key=$value";
461 $c->log->debug( 'Parameters are "' . join( ' ', @params ) . '"' );
467 =item $c->prepare_action
475 my $path = $c->req->path;
476 my @path = split /\//, $c->req->path;
477 $c->req->args( \my @args );
479 $path = join '/', @path;
480 if ( my $result = ${ $c->get_action($path) }[0] ) {
484 my $match = $result->[1];
485 my @snippets = @{ $result->[2] };
486 $c->log->debug(qq/Requested action "$path" matched "$match"/)
489 'Snippets are "' . join( ' ', @snippets ) . '"' )
490 if ( $c->debug && @snippets );
491 $c->req->action($match);
492 $c->req->snippets( \@snippets );
495 $c->req->action($path);
496 $c->log->debug(qq/Requested action "$path"/) if $c->debug;
498 $c->req->match($path);
501 unshift @args, pop @path;
503 unless ( $c->req->action ) {
504 $c->req->action('default');
507 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
508 if ( $c->debug && @args );
511 =item $c->prepare_connection
517 sub prepare_connection { }
519 =item $c->prepare_cookies
525 sub prepare_cookies { }
527 =item $c->prepare_headers
533 sub prepare_headers { }
535 =item $c->prepare_parameters
541 sub prepare_parameters { }
543 =item $c->prepare_path
545 Prepare path and base.
551 =item $c->prepare_request
553 Prepare the engine request.
557 sub prepare_request { }
559 =item $c->prepare_uploads
565 sub prepare_uploads { }
567 =item $c->execute($class, $coderef)
569 Execute a coderef in given class and catch exceptions.
570 Errors are available via $c->error.
575 my ( $c, $class, $code ) = @_;
576 $class = $c->comp($class) || $class;
581 my $action = $c->actions->{reverse}->{"$code"} || "$code";
582 my ( $elapsed, @state ) =
583 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
584 $c->log->info( sprintf qq/Processing "$action" took %fs/, $elapsed )
588 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
590 if ( my $error = $@ ) {
592 $error = qq/Caught exception "$error"/;
593 $c->log->error($error);
594 $c->error($error) if $c->debug;
612 Returns a C<Catalyst::Request> object.
620 Returns a C<Catalyst::Response> object.
624 =item $c->set_action( $action, $code, $namespace, $attrs )
626 Set an action in a given namespace.
631 my ( $c, $method, $code, $namespace, $attrs ) = @_;
633 my $prefix = _class2prefix($namespace) || '';
640 for my $attr ( @{$attrs} ) {
641 if ( $attr =~ /^Action$/ ) {
645 elsif ( $attr =~ /^Path\((.+)\)$/i ) {
649 elsif ( $attr =~ /^Public$/i ) {
652 elsif ( $attr =~ /^Private$/i ) {
655 elsif ( $attr =~ /Regex(?:\((.+)\))?$/i ) {
660 elsif ( $attr =~ /Absolute(?:\((.+)\))?$/i ) {
666 elsif ( $attr =~ /Relative(?:\((.+)\))?$/i ) {
673 return unless $action;
675 my $parent = $c->tree;
676 my $visitor = Tree::Simple::Visitor::FindByPath->new;
677 for my $part ( split '/', $prefix ) {
678 $visitor->setSearchPath($part);
679 $parent->accept($visitor);
680 my $child = $visitor->getResult;
682 $child = $parent->addChild( Tree::Simple->new($part) );
683 $visitor->setSearchPath($part);
684 $parent->accept($visitor);
685 $child = $visitor->getResult;
689 my $uid = $parent->getUID;
690 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
691 my $forward = $prefix ? "$prefix/$method" : $method;
692 $c->log->debug(qq|Private "/$forward" is "$namespace->$method"|)
697 if ( $arg =~ /^'(.*)'$/ ) { $arg = $1 }
698 if ( $arg =~ /^"(.*)"$/ ) { $arg = $1 }
700 my $reverse = $prefix ? "$method ($prefix)" : $method;
704 $is_absolute = 1 if $absolute;
705 if ( $arg =~ /^\/(.+)/ ) {
710 $is_absolute ? ( $arg || $method ) : "$prefix/" . ( $arg || $method );
711 $c->actions->{plain}->{$name} = [ $namespace, $code ];
712 $c->log->debug(qq|Public "/$name" is "/$forward"|) if $c->debug;
715 push @{ $c->actions->{compiled} }, [ $arg, qr#$arg# ];
716 $c->actions->{regex}->{$arg} = [ $namespace, $code ];
717 $c->log->debug(qq|Public "$arg" is "/$forward"|) if $c->debug;
720 $c->actions->{reverse}->{"$code"} = $reverse;
733 $self->setup_components;
734 if ( $self->debug ) {
735 my $name = $self->config->{name} || 'Application';
736 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
740 =item $class->setup_actions($component)
742 Setup actions for a component.
747 my ( $self, $comp ) = @_;
748 $comp = ref $comp || $comp;
749 for my $action ( @{ $comp->_cache } ) {
750 my ( $code, $attrs ) = @{$action};
753 for my $sym ( values %{ $comp . '::' } ) {
754 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
755 $name = *{$sym}{NAME};
756 $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 || '';
829 $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/;
830 my $prefix = lc $2 || '';
831 $prefix =~ s/\:\:/\//g;
839 Sebastian Riedel, C<sri@cpan.org>
843 This program is free software, you can redistribute it and/or modify it under
844 the same terms as Perl itself.