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/;
11 use Catalyst::Request;
12 use Catalyst::Response;
14 require Module::Pluggable::Fast;
16 $Data::Dumper::Terse = 1;
18 __PACKAGE__->mk_classdata($_) for qw/actions components/;
19 __PACKAGE__->mk_accessors(qw/request response/);
22 { plain => {}, regex => {}, compiled => {}, reverse => {} } );
33 Catalyst::Engine - The Catalyst Engine
45 Add one or more actions.
47 $c->action( '!foo' => sub { $_[1]->res->output('Foo!') } );
49 Get an action's class and coderef.
51 my ($class, $code) = @{ $c->action('foo') };
53 Get a list of available actions.
55 my @actions = $c->action;
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 my $class = B::svref_2object($code)->STASH->NAME;
72 my $caller = caller(0);
73 if ( $name =~ /^\/(.*)\/$/ ) {
75 $self->actions->{compiled}->{qr/$regex/} = $name;
76 $self->actions->{regex}->{$name} = [ $class, $code ];
78 elsif ( $name =~ /^\?(.*)$/ ) {
80 $name = _prefix( $caller, $name );
81 $self->actions->{plain}->{$name} = [ $class, $code ];
83 elsif ( $name =~ /^\!\?(.*)$/ ) {
85 $name = _prefix( $caller, $name );
87 $self->actions->{plain}->{$name} = [ $class, $code ];
89 else { $self->actions->{plain}->{$name} = [ $class, $code ] }
90 $self->actions->{reverse}->{"$code"} = $name;
92 qq/"$caller" defined "$name" as "$code" from "$class"/)
97 if ( my $p = $self->actions->{plain}->{$action} ) { return [$p] }
98 elsif ( my $r = $self->actions->{regex}->{$action} ) { return [$r] }
100 while ( my ( $regex, $name ) =
101 each %{ $self->actions->{compiled} } )
103 if ( $action =~ $regex ) {
105 for my $i ( 1 .. 9 ) {
108 push @snippets, ${$i};
110 return [ $name, \@snippets ];
118 keys %{ $self->actions->{plain} },
119 keys %{ $self->actions->{regex} }
126 Takes a coderef with arguments and returns elapsed time as float.
128 my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
129 $c->log->info( sprintf "Processing took %f seconds", $elapsed );
136 my $time = [gettimeofday];
137 my @return = &$code(@_);
138 my $elapsed = tv_interval $time;
139 return wantarray ? ( $elapsed, @return ) : $elapsed;
142 =head3 component (comp)
144 Get a component object by name.
146 $c->comp('MyApp::Model::MyModel')->do_stuff;
148 Regex search for a component.
150 $c->comp('mymodel')->do_stuff;
155 my ( $c, $name ) = @_;
156 if ( my $component = $c->components->{$name} ) {
160 for my $component ( keys %{ $c->components } ) {
161 return $c->components->{$component} if $component =~ /$name/i;
168 Returns an arrayref containing errors messages.
170 my @errors = @{ $c->errors };
174 $c->errors('Something bad happened');
180 my $errors = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
181 push @{ $c->{errors} }, @$errors;
193 if ( !$c->res->output || $#{ $c->errors } >= 0 ) {
194 $c->res->headers->content_type('text/html');
195 my $name = $c->config->{name} || 'Catalyst Application';
196 my ( $title, $errors, $infos );
198 $errors = join '<br/>', @{ $c->errors };
199 $errors ||= 'No output';
200 $title = $name = "$name on Catalyst $Catalyst::VERSION";
201 my $req = encode_entities Dumper $c->req;
202 my $res = encode_entities Dumper $c->res;
203 my $stash = encode_entities Dumper $c->stash;
206 <b><u>Request</u></b><br/>
208 <b><u>Response</u></b><br/>
210 <b><u>Stash</u></b><br/>
219 (en) Please come back later
220 (de) Bitte versuchen sie es spaeter nocheinmal
221 (nl) Gelieve te komen later terug
222 (no) Vennligst prov igjen senere
223 (fr) Veuillez revenir plus tard
224 (es) Vuelto por favor mas adelante
225 (pt) Voltado por favor mais tarde
226 (it) Ritornato prego piĆ¹ successivamente
231 $c->res->{output} = <<"";
234 <title>$title</title>
235 <style type="text/css">
237 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
238 Tahoma, Arial, helvetica, sans-serif;
240 background-color: #eee;
245 background-color: #ccc;
246 border: 1px solid #aaa;
249 -moz-border-radius: 10px;
252 background-color: #977;
253 border: 1px solid #755;
257 -moz-border-radius: 10px;
260 background-color: #797;
261 border: 1px solid #575;
265 -moz-border-radius: 10px;
268 background-color: #779;
269 border: 1px solid #557;
272 -moz-border-radius: 10px;
278 <div class="errors">$errors</div>
279 <div class="infos">$infos</div>
280 <div class="name">$name</div>
286 if ( my $location = $c->res->redirect ) {
287 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
288 $c->res->headers->header( Location => $location );
289 $c->res->status(302);
291 $c->res->headers->content_length( length $c->res->output );
292 my $status = $c->finalize_headers;
297 =head3 finalize_headers
303 sub finalize_headers { }
305 =head3 finalize_output
311 sub finalize_output { }
315 Forward processing to a private/public action or a method from a class.
316 If you define a class without method it will default to process().
319 $c->forward('index.html');
320 $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
321 $c->forward('MyApp::View::TT');
329 $c->log->debug('Nothing to forward to') if $c->debug;
332 if ( $command =~ /^\?(.*)$/ ) {
334 my $caller = caller(0);
335 $command = _prefix( $caller, $command );
337 elsif ( $command =~ /^\!\?(.*)$/ ) {
339 my $caller = caller(0);
340 $command = _prefix( $caller, $command );
341 $command = "\!$command";
343 my ( $class, $code );
344 if ( my $action = $c->action($command) ) {
345 ( $class, $code ) = @{ $action->[0] };
349 if ( $class =~ /[^\w\:]/ ) {
350 $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
353 my $method = shift || 'process';
354 if ( $code = $class->can($method) ) {
355 $c->actions->{reverse}->{"$code"} = "$class->$method";
358 $c->log->debug(qq/Couldn't forward to "$class->$method"/)
363 $class = $c->components->{$class} || $class;
364 return $c->process( $class, $code );
374 my ( $class, $r ) = @_;
376 # Always expect worst case!
380 my $c = $class->prepare($r);
381 if ( $c->req->action ) {
383 if ( my $prefix = $c->req->args->[0] ) {
384 if ( $c->actions->{plain}->{"\!$prefix/begin"} ) {
385 $begin = "\!$prefix/begin";
387 elsif ( $c->actions->{plain}->{'!begin'} ) {
390 if ( $c->actions->{plain}->{"\!$prefix/end"} ) {
391 $end = "\!$prefix/end";
393 elsif ( $c->actions->{plain}->{'!end'} ) { $end = '!end' }
395 $c->forward($begin) if $begin;
396 $c->forward( $c->req->action ) if $c->req->action;
397 $c->forward($end) if $end;
400 my $action = $c->req->path;
402 ? qq/Unknown resource "$action"/
403 : "Congratulations, you're on Catalyst!";
404 $c->log->error($error) if $c->debug;
409 if ( $class->debug ) {
411 ( $elapsed, $status ) = $class->benchmark($handler);
412 $elapsed = sprintf '%f', $elapsed;
413 my $av = sprintf '%.3f', 1 / $elapsed;
414 $class->log->info( "Request took $elapsed" . "s ($av/s)" );
416 else { $status = &$handler }
418 if ( my $error = $@ ) {
420 $class->log->error(qq/Caught exception in engine "$error"/);
428 Turns the request (Apache, CGI...) into a Catalyst context.
433 my ( $class, $r ) = @_;
435 request => Catalyst::Request->new(
439 headers => HTTP::Headers->new,
445 response => Catalyst::Response->new(
446 { cookies => {}, headers => HTTP::Headers->new, status => 200 }
451 my $secs = time - $START || 1;
452 my $av = sprintf '%.3f', $COUNT / $secs;
453 $c->log->debug('********************************');
454 $c->log->debug("* Request $COUNT ($av/s) [$$]");
455 $c->log->debug('********************************');
456 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
458 $c->prepare_request($r);
460 my $path = $c->request->path;
461 $c->log->debug(qq/Requested path "$path"/) if $c->debug;
465 $c->prepare_parameters;
470 =head3 prepare_action
478 my $path = $c->req->path;
479 my @path = split /\//, $c->req->path;
480 $c->req->args( \my @args );
482 my $path = join '/', @path;
483 if ( my $result = $c->action($path) ) {
487 my $match = $result->[0];
488 my @snippets = @{ $result->[1] };
489 $c->log->debug(qq/Requested action "$path" matched "$match"/)
492 'Snippets are "' . join( ' ', @snippets ) . '"' )
493 if ( $c->debug && @snippets );
494 $c->req->action($match);
495 $c->req->snippets( \@snippets );
498 $c->req->action($path);
499 $c->log->debug(qq/Requested action "$path"/) if $c->debug;
501 $c->req->match($path);
502 $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
503 if ( $c->debug && @args );
506 unshift @args, pop @path;
508 unless ( $c->req->action ) {
509 my $prefix = $c->req->args->[0];
510 if ( $prefix && $c->actions->{plain}->{"\!$prefix/default"} ) {
512 $c->req->action("\!$prefix/default");
513 $c->log->debug('Using prefixed default action') if $c->debug;
515 elsif ( $c->actions->{plain}->{'!default'} ) {
517 $c->req->action('!default');
518 $c->log->debug('Using default action') if $c->debug;
523 =head3 prepare_cookies;
529 sub prepare_cookies { }
531 =head3 prepare_headers
537 sub prepare_headers { }
539 =head3 prepare_parameters
545 sub prepare_parameters { }
549 Prepare path and base.
555 =head3 prepare_request
557 Prepare the engine request.
561 sub prepare_request { }
563 =head3 prepare_uploads
569 sub prepare_uploads { }
573 Process a coderef in given class and catch exceptions.
574 Errors are available via $c->errors.
579 my ( $c, $class, $code ) = @_;
584 my $action = $c->actions->{reverse}->{"$code"} || "$code";
586 ( $elapsed, $status ) =
587 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
588 $c->log->info( sprintf qq/Processing "$action" took %fs/, $elapsed )
591 else { $status = &$code( $class, $c, @{ $c->req->args } ) }
593 if ( my $error = $@ ) {
595 $error = qq/Caught exception "$error"/;
596 $c->log->error($error);
597 $c->errors($error) if $c->debug;
607 $c->remove_action('!foo');
612 my ( $self, $action ) = @_;
613 if ( delete $self->actions->{regex}->{$action} ) {
614 while ( my ( $regex, $name ) = each %{ $self->actions->{compiled} } ) {
615 if ( $name eq $action ) {
616 delete $self->actions->{compiled}->{$regex};
622 delete $self->actions->{plain}->{$action};
628 Returns a C<Catalyst::Request> object.
632 =head3 response (res)
634 Returns a C<Catalyst::Response> object.
648 $self->setup_components;
649 if ( $self->debug ) {
650 my $name = $self->config->{name} || 'Application';
651 $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
655 =head3 setup_components
661 sub setup_components {
665 my $class = ref $self || $self;
668 import Module::Pluggable::Fast
669 name => '_components',
671 '$class\::Controller', '$class\::C',
672 '$class\::Model', '$class\::M',
673 '$class\::View', '$class\::V'
676 if ( my $error = $@ ) {
679 qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
681 $self->components( {} );
682 for my $component ( $self->_components($self) ) {
683 $self->components->{ ref $component } = $component;
685 $self->log->debug( 'Initialized components "'
686 . join( ' ', keys %{ $self->components } )
693 Returns a hashref containing all your data.
695 $c->stash->{foo} ||= 'yada';
696 print $c->stash->{foo};
703 my $stash = $_[1] ? {@_} : $_[0];
704 while ( my ( $key, $val ) = each %$stash ) {
705 $self->{stash}->{$key} = $val;
708 return $self->{stash};
712 my ( $class, $name ) = @_;
713 $class =~ /^.*::[(M)(Model)(V)(View)(C)(Controller)]+::(.*)$/;
714 my $prefix = lc $1 || '';
715 $prefix =~ s/\:\:/_/g;
716 $name = "$prefix/$name" if $prefix;
722 Sebastian Riedel, C<sri@cpan.org>
726 This program is free software, you can redistribute it and/or modify it under
727 the same terms as Perl itself.