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 ) }[-1] )
378 $c->state( $c->execute( @{ $result->[0] } ) );
379 last unless $default;
381 for my $end ( reverse @{ $c->get_action( 'end', $namespace ) } )
383 $c->state( $c->execute( @{ $end->[0] } ) );
387 my $path = $c->req->path;
389 ? qq/Unknown resource "$path"/
390 : "No default action defined";
391 $c->log->error($error) if $c->debug;
396 if ( $class->debug ) {
398 ( $elapsed, $status ) = $class->benchmark($handler);
399 $elapsed = sprintf '%f', $elapsed;
400 my $av = sprintf '%.3f', 1 / $elapsed;
401 $class->log->info( "Request took $elapsed" . "s ($av/s)" );
403 else { $status = &$handler }
405 if ( my $error = $@ ) {
407 $class->log->error(qq/Caught exception in engine "$error"/);
413 =item $c->prepare($r)
415 Turns the engine-specific request( Apache, CGI ... )
416 into a Catalyst context .
421 my ( $class, $r ) = @_;
423 request => Catalyst::Request->new(
427 headers => HTTP::Headers->new,
433 response => Catalyst::Response->new(
434 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
440 my $secs = time - $START || 1;
441 my $av = sprintf '%.3f', $COUNT / $secs;
442 $c->log->debug('********************************');
443 $c->log->debug("* Request $COUNT ($av/s) [$$]");
444 $c->log->debug('********************************');
445 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
447 $c->prepare_request($r);
451 $c->prepare_connection;
452 my $method = $c->req->method || '';
453 my $path = $c->req->path || '';
454 my $hostname = $c->req->hostname || '';
455 my $address = $c->req->address || '';
456 $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
459 $c->prepare_parameters;
461 if ( $c->debug && keys %{ $c->req->params } ) {
463 for my $key ( keys %{ $c->req->params } ) {
464 my $value = $c->req->params->{$key} || '';
465 push @params, "$key=$value";
467 $c->log->debug( 'Parameters are "' . join( ' ', @params ) . '"' );
473 =item $c->prepare_action
481 my $path = $c->req->path;
482 my @path = split /\//, $c->req->path;
483 $c->req->args( \my @args );
485 $path = join '/', @path;
486 if ( my $result = ${ $c->get_action($path) }[0] ) {
490 my $match = $result->[1];
491 my @snippets = @{ $result->[2] };
492 $c->log->debug(qq/Requested action "$path" matched "$match"/)
495 'Snippets are "' . join( ' ', @snippets ) . '"' )
496 if ( $c->debug && @snippets );
497 $c->req->action($match);
498 $c->req->snippets( \@snippets );
501 $c->req->action($path);
502 $c->log->debug(qq/Requested action "$path"/) if $c->debug;
504 $c->req->match($path);
507 unshift @args, pop @path;
509 unless ( $c->req->action ) {
510 $c->req->action('default');
513 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
514 if ( $c->debug && @args );
517 =item $c->prepare_connection
523 sub prepare_connection { }
525 =item $c->prepare_cookies
531 sub prepare_cookies { }
533 =item $c->prepare_headers
539 sub prepare_headers { }
541 =item $c->prepare_parameters
547 sub prepare_parameters { }
549 =item $c->prepare_path
551 Prepare path and base.
557 =item $c->prepare_request
559 Prepare the engine request.
563 sub prepare_request { }
565 =item $c->prepare_uploads
571 sub prepare_uploads { }
573 =item $c->execute($class, $coderef)
575 Execute a coderef in given class and catch exceptions.
576 Errors are available via $c->error.
581 my ( $c, $class, $code ) = @_;
582 $class = $c->comp($class) || $class;
587 my $action = $c->actions->{reverse}->{"$code"} || "$code";
588 my ( $elapsed, @state ) =
589 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
590 $c->log->info( sprintf qq/Processing "$action" took %fs/, $elapsed )
594 else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
596 if ( my $error = $@ ) {
598 $error = qq/Caught exception "$error"/;
599 $c->log->error($error);
600 $c->error($error) if $c->debug;
618 Returns a C<Catalyst::Request> object.
626 Returns a C<Catalyst::Response> object.
630 =item $c->set_action( $action, $code, $namespace, $attrs )
632 Set an action in a given namespace.
637 my ( $c, $method, $code, $namespace, $attrs ) = @_;
639 my $prefix = _class2prefix($namespace) || '';
642 for my $attr ( @{$attrs} ) {
643 if ( $attr =~ /^(Local|Relative)$/ ) { $flags{local}++ }
644 elsif ( $attr =~ /^(Global|Absolute)$/ ) { $flags{global}++ }
645 elsif ( $attr =~ /^Path\((.+)\)$/i ) { $flags{path} = $1 }
646 elsif ( $attr =~ /^Private$/i ) { $flags{private}++ }
647 elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
650 return unless keys %flags;
652 my $parent = $c->tree;
653 my $visitor = Tree::Simple::Visitor::FindByPath->new;
654 for my $part ( split '/', $prefix ) {
655 $visitor->setSearchPath($part);
656 $parent->accept($visitor);
657 my $child = $visitor->getResult;
659 $child = $parent->addChild( Tree::Simple->new($part) );
660 $visitor->setSearchPath($part);
661 $parent->accept($visitor);
662 $child = $visitor->getResult;
666 my $uid = $parent->getUID;
667 $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
668 my $forward = $prefix ? "$prefix/$method" : $method;
669 $c->log->debug(qq|Private "/$forward" is "$namespace->$method"|)
672 if ( $flags{path} ) {
673 $flags{path} =~ s/^\w+//;
674 $flags{path} =~ s/\w+$//;
675 if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
676 if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
678 if ( $flags{regex} ) {
679 $flags{regex} =~ s/^\w+//;
680 $flags{regex} =~ s/\w+$//;
681 if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
682 if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
685 my $reverse = $prefix ? "$method ($prefix)" : $method;
687 if ( $flags{local} || $flags{global} || $flags{path} ) {
688 my $path = $flags{path} || $method;
690 if ( $path =~ /^\/(.+)/ ) {
694 $absolute = 1 if $flags{global};
695 my $name = $absolute ? $path : "$prefix/$path";
696 $c->actions->{plain}->{$name} = [ $namespace, $code ];
697 $c->log->debug(qq|Public "/$name" is "/$forward"|) if $c->debug;
699 if ( my $regex = $flags{regex} ) {
700 push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
701 $c->actions->{regex}->{$regex} = [ $namespace, $code ];
702 $c->log->debug(qq|Public "$regex" is "/$forward"|) if $c->debug;
705 $c->actions->{reverse}->{"$code"} = $reverse;
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_actions($component)
727 Setup actions for a component.
732 my ( $self, $comp ) = @_;
733 $comp = ref $comp || $comp;
734 for my $action ( @{ $comp->_cache } ) {
735 my ( $code, $attrs ) = @{$action};
738 my @cache = ( $comp, @{"$comp\::ISA"} );
741 while ( my $namespace = shift @cache ) {
742 push @namespaces, $namespace;
743 for my $isa ( @{"$comp\::ISA"} ) {
749 for my $namespace (@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);
793 $self->log->debug( 'Initialized components "'
794 . join( ' ', keys %{ $self->components } )
801 Returns a hashref containing all your data.
803 $c->stash->{foo} ||= 'yada';
804 print $c->stash->{foo};
811 my $stash = $_[1] ? {@_} : $_[0];
812 while ( my ( $key, $val ) = each %$stash ) {
813 $self->{stash}->{$key} = $val;
816 return $self->{stash};
820 my ( $class, $name ) = @_;
821 my $prefix = _class2prefix($class);
822 $name = "$prefix/$name" if $prefix;
827 my $class = shift || '';
829 if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
831 $prefix =~ s/\:\:/\//g;
840 Sebastian Riedel, C<sri@cpan.org>
844 This program is free software, you can redistribute it and/or modify it under
845 the same terms as Perl itself.