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 =~ /^\/$/ ) {
270 $command =~ /^(.*)\/(\w+)$/;
271 $namespace = $1 || '/';
274 else { $namespace = _class2prefix($caller) || '/' }
275 my $results = $c->get_action( $command, $namespace );
276 unless ( @{$results} ) {
277 my $class = $command;
278 if ( $class =~ /[^\w\:]/ ) {
279 $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
282 my $method = shift || 'process';
283 if ( my $code = $class->can($method) ) {
284 $c->actions->{reverse}->{"$code"} = "$class->$method";
285 $results = [ [ [ $class, $code ] ] ];
288 $c->log->debug(qq/Couldn't forward to "$class->$method"/)
293 for my $result ( @{$results} ) {
294 $c->state( $c->execute( @{ $result->[0] } ) );
299 =item $c->get_action( $action, $namespace )
301 Get an action in a given namespace.
306 my ( $c, $action, $namespace ) = @_;
309 $namespace = '' if $namespace eq '/';
310 my $parent = $c->tree;
312 my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
313 push @results, [$result] if $result;
314 my $visitor = Tree::Simple::Visitor::FindByPath->new;
315 for my $part ( split '/', $namespace ) {
316 $visitor->setSearchPath($part);
317 $parent->accept($visitor);
318 my $child = $visitor->getResult;
319 my $uid = $child->getUID if $child;
320 my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
321 push @results, [$match] if $match;
322 $parent = $child if $child;
326 elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
327 elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
329 for my $i ( 0 .. $#{ $c->actions->{compiled} } ) {
330 my $name = $c->actions->{compiled}->[$i]->[0];
331 my $regex = $c->actions->{compiled}->[$i]->[1];
332 if ( $action =~ $regex ) {
334 for my $i ( 1 .. 9 ) {
337 push @snippets, ${$i};
339 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
346 =item $c->handler( $class, $r )
353 my ( $class, $r ) = @_;
355 # Always expect worst case!
359 my $c = $class->prepare($r);
360 my $action = $c->req->action;
362 $namespace = ( join( '/', @{ $c->req->args } ) || '/' )
363 if $action eq 'default';
364 unless ($namespace) {
365 if ( my $result = $c->get_action($action) ) {
366 $namespace = _class2prefix( $result->[0]->[0]->[0] );
369 my $default = $action eq 'default' ? $namespace : undef;
370 my $results = $c->get_action( $action, $default );
373 for my $begin ( @{ $c->get_action( 'begin', $namespace ) } ) {
374 $c->state( $c->execute( @{ $begin->[0] } ) );
376 for my $result ( @{ $c->get_action( $action, $default ) } ) {
377 $c->state( $c->execute( @{ $result->[0] } ) );
378 last unless $default;
380 for my $end ( @{ $c->get_action( 'end', $namespace ) } ) {
381 $c->state( $c->execute( @{ $end->[0] } ) );
385 my $path = $c->req->path;
387 ? qq/Unknown resource "$path"/
388 : "No default action defined";
389 $c->log->error($error) if $c->debug;
394 if ( $class->debug ) {
396 ( $elapsed, $status ) = $class->benchmark($handler);
397 $elapsed = sprintf '%f', $elapsed;
398 my $av = sprintf '%.3f', 1 / $elapsed;
399 $class->log->info( "Request took $elapsed" . "s ($av/s)" );
401 else { $status = &$handler }
403 if ( my $error = $@ ) {
405 $class->log->error(qq/Caught exception in engine "$error"/);
411 =item $c->prepare($r)
413 Turns the engine-specific request( Apache, CGI ... )
414 into a Catalyst context .
419 my ( $class, $r ) = @_;
421 request => Catalyst::Request->new(
425 headers => HTTP::Headers->new,
431 response => Catalyst::Response->new(
432 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
438 my $secs = time - $START || 1;
439 my $av = sprintf '%.3f', $COUNT / $secs;
440 $c->log->debug('********************************');
441 $c->log->debug("* Request $COUNT ($av/s) [$$]");
442 $c->log->debug('********************************');
443 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
445 $c->prepare_request($r);
449 $c->prepare_connection;
450 my $method = $c->req->method || '';
451 my $path = $c->req->path || '';
452 my $hostname = $c->req->hostname || '';
453 my $address = $c->req->address || '';
454 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
457 $c->prepare_parameters;
459 if ( $c->debug && keys %{ $c->req->params } ) {
461 for my $key ( keys %{ $c->req->params } ) {
462 my $value = $c->req->params->{$key} || '';
463 push @params, "$key=$value";
465 $c->log->debug( 'Parameters are "' . join( ' ', @params ) . '"' );
471 =item $c->prepare_action
479 my $path = $c->req->path;
480 my @path = split /\//, $c->req->path;
481 $c->req->args( \my @args );
483 $path = join '/', @path;
484 if ( my $result = ${ $c->get_action($path) }[0] ) {
488 my $match = $result->[1];
489 my @snippets = @{ $result->[2] };
490 $c->log->debug(qq/Requested action "$path" matched "$match"/)
493 'Snippets are "' . join( ' ', @snippets ) . '"' )
494 if ( $c->debug && @snippets );
495 $c->req->action($match);
496 $c->req->snippets( \@snippets );
499 $c->req->action($path);
500 $c->log->debug(qq/Requested action "$path"/) if $c->debug;
502 $c->req->match($path);
505 unshift @args, pop @path;
507 unless ( $c->req->action ) {
508 $c->req->action('default');
511 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
512 if ( $c->debug && @args );
515 =item $c->prepare_connection
521 sub prepare_connection { }
523 =item $c->prepare_cookies
529 sub prepare_cookies { }
531 =item $c->prepare_headers
537 sub prepare_headers { }
539 =item $c->prepare_parameters
545 sub prepare_parameters { }
547 =item $c->prepare_path
549 Prepare path and base.
555 =item $c->prepare_request
557 Prepare the engine request.
561 sub prepare_request { }
563 =item $c->prepare_uploads
569 sub prepare_uploads { }
571 =item $c->execute($class, $coderef)
573 Execute a coderef in given class and catch exceptions.
574 Errors are available via $c->error.
579 my ( $c, $class, $code ) = @_;
580 $class = $c->comp($class) || $class;
585 my $action = $c->actions->{reverse}->{"$code"} || "$code";
586 my ( $elapsed, @state ) =
587 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
588 $c->log->info( sprintf qq/Processing "$action" took %fs/, $elapsed )
592 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
594 if ( my $error = $@ ) {
596 $error = qq/Caught exception "$error"/;
597 $c->log->error($error);
598 $c->error($error) if $c->debug;
616 Returns a C<Catalyst::Request> object.
624 Returns a C<Catalyst::Response> object.
628 =item $c->set_action( $action, $code, $namespace, $attrs )
630 Set an action in a given namespace.
635 my ( $c, $method, $code, $namespace, $attrs ) = @_;
637 my $prefix = _class2prefix($namespace) || '';
640 for my $attr ( @{$attrs} ) {
641 if ( $attr =~ /^Local$/ ) { $flags{local}++ }
642 elsif ( $attr =~ /^Global$/ ) { $flags{global}++ }
643 elsif ( $attr =~ /^Path\((.+)\)$/i ) { $flags{path} = $1 }
644 elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
645 elsif ( $attr =~ /Regex\((.+)\)$/i ) { $flags{regex} = $1 }
648 return unless keys %flags;
650 my $parent = $c->tree;
651 my $visitor = Tree::Simple::Visitor::FindByPath->new;
652 for my $part ( split '/', $prefix ) {
653 $visitor->setSearchPath($part);
654 $parent->accept($visitor);
655 my $child = $visitor->getResult;
657 $child = $parent->addChild( Tree::Simple->new($part) );
658 $visitor->setSearchPath($part);
659 $parent->accept($visitor);
660 $child = $visitor->getResult;
664 my $uid = $parent->getUID;
665 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
666 my $forward = $prefix ? "$prefix/$method" : $method;
667 $c->log->debug(qq|Private "/$forward" is "$namespace->$method"|)
670 if ( $flags{path} ) {
671 $flags{path} =~ s/^\w+//;
672 $flags{path} =~ s/\w+$//;
673 if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
674 if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
676 if ( $flags{regex} ) {
677 $flags{regex} =~ s/^\w+//;
678 $flags{regex} =~ s/\w+$//;
679 if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
680 if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
683 my $reverse = $prefix ? "$method ($prefix)" : $method;
685 if ( $flags{local} || $flags{global} || $flags{path} ) {
686 my $path = $flags{path} || $method;
688 if ( $path =~ /^\/(.+)/ ) {
692 my $name = $absolute ? $path : "$prefix/$path";
693 $c->actions->{plain}->{$name} = [ $namespace, $code ];
694 $c->log->debug(qq|Public "/$name" is "/$forward"|) if $c->debug;
696 if ( my $regex = $flags{regex} ) {
697 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
698 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
699 $c->log->debug(qq|Public "$regex" is "/$forward"|) if $c->debug;
702 $c->actions->{reverse}->{"$code"} = $reverse;
715 $self->setup_components;
716 if ( $self->debug ) {
717 my $name = $self->config->{name} || 'Application';
718 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
722 =item $class->setup_actions($component)
724 Setup actions for a component.
729 my ( $self, $comp ) = @_;
730 $comp = ref $comp || $comp;
731 for my $action ( @{ $comp->_cache } ) {
732 my ( $code, $attrs ) = @{$action};
735 for my $sym ( values %{ $comp . '::' } ) {
736 if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
737 $name = *{$sym}{NAME};
738 $self->set_action( $name, $code, $comp, $attrs );
744 =item $class->setup_components
750 sub setup_components {
754 my $class = ref $self || $self;
757 import Module::Pluggable::Fast
758 name => '_components',
760 '$class\::Controller', '$class\::C',
761 '$class\::Model', '$class\::M',
762 '$class\::View', '$class\::V'
765 if ( my $error = $@ ) {
768 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
770 $self->setup_actions($self);
771 $self->components( {} );
772 for my $comp ( $self->_components($self) ) {
773 $self->components->{ ref $comp } = $comp;
774 $self->setup_actions($comp);
776 $self->log->debug( 'Initialized components "'
777 . join( ' ', keys %{ $self->components } )
784 Returns a hashref containing all your data.
786 $c->stash->{foo} ||= 'yada';
787 print $c->stash->{foo};
794 my $stash = $_[1] ? {@_} : $_[0];
795 while ( my ( $key, $val ) = each %$stash ) {
796 $self->{stash}->{$key} = $val;
799 return $self->{stash};
803 my ( $class, $name ) = @_;
804 my $prefix = _class2prefix($class);
805 $name = "$prefix/$name" if $prefix;
810 my $class = shift || '';
811 $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/;
812 my $prefix = lc $2 || '';
813 $prefix =~ s/\:\:/\//g;
821 Sebastian Riedel, C<sri@cpan.org>
825 This program is free software, you can redistribute it and/or modify it under
826 the same terms as Perl itself.