4 use base 'Catalyst::Component';
6 use UNIVERSAL::require;
7 use Catalyst::Exception;
10 use Catalyst::Request::Upload;
11 use Catalyst::Response;
13 use Catalyst::Controller;
16 use Text::SimpleTable;
18 use Time::HiRes qw/gettimeofday tv_interval/;
20 use Scalar::Util qw/weaken/;
21 use Tree::Simple qw/use_weak_refs/;
22 use Tree::Simple::Visitor::FindByUID;
25 __PACKAGE__->mk_accessors(
26 qw/counter request response state action stack namespace/
29 attributes->import( __PACKAGE__, \&namespace, 'lvalue' );
31 sub depth { scalar @{ shift->stack || [] }; }
38 # For backwards compatibility
39 *finalize_output = \&finalize_body;
44 our $RECURSION = 1000;
45 our $DETACH = "catalyst_detach\n";
47 require Module::Pluggable::Fast;
49 # Helper script generation
50 our $CATALYST_SCRIPT_GEN = 26;
52 __PACKAGE__->mk_classdata($_)
53 for qw/components arguments dispatcher engine log dispatcher_class
54 engine_class context_class request_class response_class/;
56 __PACKAGE__->dispatcher_class('Catalyst::Dispatcher');
57 __PACKAGE__->engine_class('Catalyst::Engine::CGI');
58 __PACKAGE__->request_class('Catalyst::Request');
59 __PACKAGE__->response_class('Catalyst::Response');
61 our $VERSION = '5.64';
64 my ( $class, @arguments ) = @_;
66 # We have to limit $class to Catalyst to avoid pushing Catalyst upon every
68 return unless $class eq 'Catalyst';
70 my $caller = caller(0);
72 unless ( $caller->isa('Catalyst') ) {
74 push @{"$caller\::ISA"}, $class, 'Catalyst::Controller';
77 $caller->arguments( [@arguments] );
83 Catalyst - The Elegant MVC Web Application Framework
87 # use the helper to start a new application
90 # add models, views, controllers
91 script/myapp_create.pl model Database DBIC dbi:SQLite:/path/to/db
92 script/myapp_create.pl view TT TT
93 script/myapp_create.pl controller Search
95 # built in testserver -- use -r to restart automatically on changes
96 script/myapp_server.pl
98 # command line testing interface
99 script/myapp_test.pl /yada
102 use Catalyst qw/-Debug/; # include plugins here as well
104 sub foo : Global { # called for /foo, /foo/1, /foo/1/2, etc.
105 my ( $self, $c, @args ) = @_; # args are qw/1 2/ for /foo/1/2
106 $c->stash->{template} = 'foo.tt'; # set the template
107 # lookup something from db -- stash vars are passed to TT
109 MyApp::Model::Database::Foo->search( { country => $args[0] } );
110 if ( $c->req->params->{bar} ) { # access GET or POST parameters
111 $c->forward( 'bar' ); # process another action
112 # do something else after forward returns
116 # The foo.tt TT template can use the stash data from the database
117 [% WHILE (item = data.next) %]
121 # called for /bar/of/soap, /bar/of/soap/10, etc.
122 sub bar : Path('/bar/of/soap') { ... }
124 # called for all actions, from the top-most controller downwards
126 my ( $self, $c ) = @_;
128 $c->res->redirect( '/login' ); # require login
129 return 0; # abort request and go immediately to end()
131 return 1; # success; carry on to next action
134 # called after all actions are finished
136 my ( $self, $c ) = @_;
137 if ( scalar @{ $c->error } ) { ... } # handle errors
138 return if $c->res->body; # already have a response
139 $c->forward( 'MyApp::View::TT' ); # render template
142 ### in MyApp/Controller/Foo.pm
143 # called for /foo/bar
144 sub bar : Local { ... }
146 # called for /blargle
147 sub blargle : Global { ... }
149 # an index action matches /foo, but not /foo/1, etc.
150 sub index : Private { ... }
152 ### in MyApp/Controller/Foo/Bar.pm
153 # called for /foo/bar/baz
154 sub baz : Local { ... }
156 # first MyApp auto is called, then Foo auto, then this
157 sub auto : Private { ... }
159 # powerful regular expression paths are also possible
160 sub details : Regex('^product/(\w+)/details$') {
161 my ( $self, $c ) = @_;
162 # extract the (\w+) from the URI
163 my $product = $c->req->snippets->[0];
166 See L<Catalyst::Manual::Intro> for additional information.
170 The key concept of Catalyst is DRY (Don't Repeat Yourself).
172 See L<Catalyst::Manual> for more documentation.
174 Catalyst plugins can be loaded by naming them as arguments to the "use
175 Catalyst" statement. Omit the C<Catalyst::Plugin::> prefix from the
176 plugin name, i.e., C<Catalyst::Plugin::My::Module> becomes
179 use Catalyst qw/My::Module/;
181 Special flags like C<-Debug> and C<-Engine> can also be specified as
182 arguments when Catalyst is loaded:
184 use Catalyst qw/-Debug My::Module/;
186 The position of plugins and flags in the chain is important, because
187 they are loaded in exactly the order in which they appear.
189 The following flags are supported:
193 Enables debug output.
197 Forces Catalyst to use a specific engine. Omit the
198 C<Catalyst::Engine::> prefix of the engine name, i.e.:
200 use Catalyst qw/-Engine=CGI/;
204 Forces Catalyst to use a specific home directory, e.g.:
206 use Catalyst qw[-Home=/usr/sri];
214 =head2 Information about the current request
218 Returns a L<Catalyst::Action> object for the current action, which
219 stringifies to the action name. See L<Catalyst::Action>.
223 Returns the namespace of the current action, i.e., the uri prefix
224 corresponding to the controller of the current action. For example:
226 # in Controller::Foo::Bar
227 $c->namespace; # returns 'foo/bar';
233 Returns the current L<Catalyst::Request> object. See
234 L<Catalyst::Request>.
236 =head2 Processing and response to the current request
238 =head2 $c->forward( $action [, \@arguments ] )
240 =head2 $c->forward( $class, $method, [, \@arguments ] )
242 Forwards processing to a private action. If you give a class name but no
243 method, C<process()> is called. You may also optionally pass arguments
244 in an arrayref. The action will receive the arguments in C<@_> and
245 C<$c-E<gt>req-E<gt>args>. Upon returning from the function,
246 C<$c-E<gt>req-E<gt>args> will be restored to the previous values.
248 Any data C<return>ed from the action forwarded to, will be returned by the
251 my $foodata = $c->forward('/foo');
252 $c->forward('index');
253 $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
254 $c->forward('MyApp::View::TT');
258 sub forward { my $c = shift; $c->dispatcher->forward( $c, @_ ) }
260 =head2 $c->detach( $action [, \@arguments ] )
262 =head2 $c->detach( $class, $method, [, \@arguments ] )
264 The same as C<forward>, but doesn't return.
268 sub detach { my $c = shift; $c->dispatcher->detach( $c, @_ ) }
272 =head2 $c->error($error, ...)
274 =head2 $c->error($arrayref)
276 Returns an arrayref containing error messages. If Catalyst encounters an
277 error while processing a request, it stores the error in $c->error. This
278 method should not be used to store non-fatal error messages.
280 my @error = @{ $c->error };
284 $c->error('Something bad happened');
286 Clear errors. You probably don't want to clear the errors unless you are
287 implementing a custom error screen.
296 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
297 push @{ $c->{error} }, @$error;
299 elsif ( defined $_[0] ) { $c->{error} = undef }
300 return $c->{error} || [];
307 Returns the current L<Catalyst::Response> object.
311 Returns a hashref to the stash, which may be used to store data and pass
312 it between components during a request. You can also set hash keys by
313 passing arguments. The stash is automatically sent to the view. The
314 stash is cleared at the end of a request; it cannot be used for
317 $c->stash->{foo} = $bar;
318 $c->stash( { moose => 'majestic', qux => 0 } );
319 $c->stash( bar => 1, gorch => 2 ); # equivalent to passing a hashref
321 # stash is automatically passed to the view for use in a template
322 $c->forward( 'MyApp::V::TT' );
329 my $stash = @_ > 1 ? {@_} : $_[0];
330 while ( my ( $key, $val ) = each %$stash ) {
331 $c->{stash}->{$key} = $val;
339 Contains the return value of the last executed action.
341 =head2 Component Accessors
343 =head2 $c->comp($name)
345 =head2 $c->component($name)
347 Gets a component object by name. This method is no longer recommended,
348 unless you want to get a specific component by full
349 class. C<$c-E<gt>controller>, C<$c-E<gt>model>, and C<$c-E<gt>view>
350 should be used instead.
361 my $appclass = ref $c || $c;
364 $name, "${appclass}::${name}",
365 map { "${appclass}::${_}::${name}" }
366 qw/Model M Controller C View V/
369 foreach my $try (@names) {
371 if ( exists $c->components->{$try} ) {
373 my $comp = $c->components->{$try};
374 if ( eval { $comp->can('ACCEPT_CONTEXT'); } ) {
375 return $comp->ACCEPT_CONTEXT($c);
377 else { return $comp }
381 foreach my $component ( keys %{ $c->components } ) {
383 $comp = $c->components->{$component} if $component =~ /$name/i;
385 if ( ref $comp && $comp->can('ACCEPT_CONTEXT') ) {
386 return $comp->ACCEPT_CONTEXT($c);
388 else { return $comp }
394 return sort keys %{ $c->components };
397 =head2 $c->controller($name)
399 Gets a L<Catalyst::Controller> instance by name.
401 $c->controller('Foo')->do_stuff;
406 my ( $c, $name ) = @_;
407 my $controller = $c->comp("Controller::$name");
408 return $controller if defined $controller;
409 return $c->comp("C::$name");
412 =head2 $c->model($name)
414 Gets a L<Catalyst::Model> instance by name.
416 $c->model('Foo')->do_stuff;
421 my ( $c, $name ) = @_;
422 my $model = $c->comp("Model::$name");
423 return $model if defined $model;
424 return $c->comp("M::$name");
427 =head2 $c->view($name)
429 Gets a L<Catalyst::View> instance by name.
431 $c->view('Foo')->do_stuff;
436 my ( $c, $name ) = @_;
437 my $view = $c->comp("View::$name");
438 return $view if defined $view;
439 return $c->comp("V::$name");
442 =head2 Class data and helper classes
446 Returns or takes a hashref containing the application's configuration.
448 __PACKAGE__->config( { db => 'dsn:SQLite:foo.db' } );
452 Overload to enable debug messages (same as -Debug option).
458 =head2 $c->dispatcher
460 Returns the dispatcher instance. Stringifies to class name. See
461 L<Catalyst::Dispatcher>.
465 Returns the engine instance. Stringifies to the class name. See
470 Returns the logging object instance. Unless it is already set, Catalyst sets
471 this up with a L<Catalyst::Log> object. To use your own log class, set the
472 logger with the C<< __PACKAGE__->log >> method prior to calling
473 C<< __PACKAGE__->setup >>.
475 __PACKAGE__->log( MyLogger->new );
480 $c->log->info( 'Now logging with my own logger!' );
482 Your log class should implement the methods described in the
483 L<Catalyst::Log> man page.
487 =head2 Utility methods
489 =head2 $c->path_to(@path)
491 Merges C<@path> with C<$c-E<gt>config-E<gt>{home}> and returns a
492 L<Path::Class> object.
496 $c->path_to( 'db', 'sqlite.db' );
501 my ( $c, @path ) = @_;
502 my $path = dir( $c->config->{home}, @path );
503 if ( -d $path ) { return $path }
504 else { return file( $c->config->{home}, @path ) }
507 =head2 $c->plugin( $name, $class, @args )
509 Helper method for plugins. It creates a classdata accessor/mutator and
510 loads and instantiates the given class.
512 MyApp->plugin( 'prototype', 'HTML::Prototype' );
514 $c->prototype->define_javascript_functions;
519 my ( $class, $name, $plugin, @args ) = @_;
522 if ( my $error = $UNIVERSAL::require::ERROR ) {
523 Catalyst::Exception->throw(
524 message => qq/Couldn't load instant plugin "$plugin", "$error"/ );
527 eval { $plugin->import };
528 $class->mk_classdata($name);
530 eval { $obj = $plugin->new(@args) };
533 Catalyst::Exception->throw( message =>
534 qq/Couldn't instantiate instant plugin "$plugin", "$@"/ );
538 $class->log->debug(qq/Initialized instant plugin "$plugin" as "$name"/)
544 Initializes the dispatcher and engine, loads any plugins, and loads the
545 model, view, and controller components. You may also specify an array
546 of plugins to load here, if you choose to not load them in the C<use
550 MyApp->setup( qw/-Debug/ );
555 my ( $class, @arguments ) = @_;
557 unless ( $class->isa('Catalyst') ) {
559 Catalyst::Exception->throw(
560 message => qq/'$class' does not inherit from Catalyst/ );
563 if ( $class->arguments ) {
564 @arguments = ( @arguments, @{ $class->arguments } );
570 foreach (@arguments) {
574 ( $flags->{log} ) ? 'debug,' . $flags->{log} : 'debug';
576 elsif (/^-(\w+)=?(.*)$/) {
577 $flags->{ lc $1 } = $2;
580 push @{ $flags->{plugins} }, $_;
584 $class->setup_home( delete $flags->{home} );
586 $class->setup_log( delete $flags->{log} );
587 $class->setup_plugins( delete $flags->{plugins} );
588 $class->setup_dispatcher( delete $flags->{dispatcher} );
589 $class->setup_engine( delete $flags->{engine} );
591 for my $flag ( sort keys %{$flags} ) {
593 if ( my $code = $class->can( 'setup_' . $flag ) ) {
594 &$code( $class, delete $flags->{$flag} );
597 $class->log->warn(qq/Unknown flag "$flag"/);
602 <<"EOF") if ( $ENV{CATALYST_SCRIPT_GEN} && ( $ENV{CATALYST_SCRIPT_GEN} < $Catalyst::CATALYST_SCRIPT_GEN ) );
603 You are running an old script!
605 Please update by running (this will overwrite existing files):
606 catalyst.pl -force -scripts $class
608 or (this will not overwrite existing files):
609 catalyst.pl -scripts $class
612 if ( $class->debug ) {
619 map { $_ . ' ' . ( $_->VERSION || '' ) }
620 grep { /^Catalyst::Plugin/ } @{"$class\::ISA"};
624 my $t = Text::SimpleTable->new(76);
625 $t->row($_) for @plugins;
626 $class->log->debug( "Loaded plugins:\n" . $t->draw );
629 my $dispatcher = $class->dispatcher;
630 my $engine = $class->engine;
631 my $home = $class->config->{home};
633 $class->log->debug(qq/Loaded dispatcher "$dispatcher"/);
634 $class->log->debug(qq/Loaded engine "$engine"/);
638 ? $class->log->debug(qq/Found home "$home"/)
639 : $class->log->debug(qq/Home "$home" doesn't exist/)
640 : $class->log->debug(q/Couldn't find home/);
645 no warnings qw/redefine/;
646 local *setup = sub { };
650 # Initialize our data structure
651 $class->components( {} );
653 $class->setup_components;
655 if ( $class->debug ) {
656 my $t = Text::SimpleTable->new( [ 65, 'Class' ], [ 8, 'Type' ] );
657 for my $comp ( sort keys %{ $class->components } ) {
658 my $type = ref $class->components->{$comp} ? 'instance' : 'class';
659 $t->row( $comp, $type );
661 $class->log->debug( "Loaded components:\n" . $t->draw )
662 if ( keys %{ $class->components } );
665 # Add our self to components, since we are also a component
666 $class->components->{$class} = $class;
668 $class->setup_actions;
670 if ( $class->debug ) {
671 my $name = $class->config->{name} || 'Application';
672 $class->log->info("$name powered by Catalyst $Catalyst::VERSION");
674 $class->log->_flush() if $class->log->can('_flush');
677 =head2 $c->uri_for( $path, [ @args ] )
679 Merges path with C<$c-E<gt>request-E<gt>base> for absolute uri's and
680 with C<$c-E<gt>namespace> for relative uri's, then returns a
681 normalized L<URI> object. If any args are passed, they are added at the
687 my ( $c, $path, @args ) = @_;
688 my $base = $c->request->base->clone;
689 my $basepath = $base->path;
690 $basepath =~ s/\/$//;
692 my $namespace = $c->namespace;
694 # massage namespace, empty if absolute path
695 $namespace =~ s/^\///;
696 $namespace .= '/' if $namespace;
698 $namespace = '' if $path =~ /^\//;
701 # join args with '/', or a blank string
702 my $args = ( scalar @args ? '/' . join( '/', @args ) : '' );
703 $args =~ s/^\/// unless $path;
705 URI->new_abs( URI->new_abs( "$path$args", "$basepath$namespace" ), $base )
710 =head2 $c->welcome_message
712 Returns the Catalyst welcome HTML page.
716 sub welcome_message {
718 my $name = $c->config->{name};
719 my $logo = $c->uri_for('/static/images/catalyst_logo.png');
720 my $prefix = Catalyst::Utils::appprefix( ref $c );
721 $c->response->content_type('text/html; charset=utf-8');
723 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
724 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
725 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
727 <meta http-equiv="Content-Language" content="en" />
728 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
729 <title>$name on Catalyst $VERSION</title>
730 <style type="text/css">
733 background-color: #eee;
742 background-color: #ccc;
743 border: 1px solid #aaa;
744 -moz-border-radius: 10px;
749 font-family: verdana, tahoma, sans-serif;
752 font-family: verdana, tahoma, sans-serif;
755 text-decoration: none;
757 border-bottom: 1px dotted #bbb;
759 :link:hover, :visited:hover {
772 background-color: #fff;
773 border: 1px solid #aaa;
774 -moz-border-radius: 10px;
800 <h1><span id="appname">$name</span> on <a href="http://catalyst.perl.org">Catalyst</a>
805 <img src="$logo" alt="Catalyst Logo" />
807 <p>Welcome to the wonderful world of Catalyst.
808 This <a href="http://en.wikipedia.org/wiki/MVC">MVC</a>
809 framework will make web development something you had
810 never expected it to be: Fun, rewarding, and quick.</p>
811 <h2>What to do now?</h2>
812 <p>That really depends on what <b>you</b> want to do.
813 We do, however, provide you with a few starting points.</p>
814 <p>If you want to jump right into web development with Catalyst
815 you might want to check out the documentation.</p>
816 <pre><code>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst/lib/Catalyst/Manual/Intro.pod">Catalyst::Manual::Intro</a>
817 perldoc <a href="http://cpansearch.perl.org/dist/Catalyst/lib/Catalyst/Manual/Tutorial.pod">Catalyst::Manual::Tutorial</a></code>
818 perldoc <a href="http://cpansearch.perl.org/dist/Catalyst/lib/Catalyst/Manual.pod">Catalyst::Manual</a></code></pre>
819 <h2>What to do next?</h2>
820 <p>Next it's time to write an actual application. Use the
821 helper scripts to generate <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AController%3A%3A&mode=all">controllers</a>,
822 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AModel%3A%3A&mode=all">models</a>, and
823 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AView%3A%3A&mode=all">views</a>;
824 they can save you a lot of work.</p>
825 <pre><code>script/${prefix}_create.pl -help</code></pre>
826 <p>Also, be sure to check out the vast and growing
827 collection of <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3APlugin%3A%3A&mode=all">plugins for Catalyst on CPAN</a>;
828 you are likely to find what you need there.
832 <p>Catalyst has a very active community. Here are the main places to
833 get in touch with us.</p>
836 <a href="http://dev.catalyst.perl.org">Wiki</a>
839 <a href="http://lists.rawmode.org/mailman/listinfo/catalyst">Mailing-List</a>
842 <a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
845 <h2>In conclusion</h2>
846 <p>The Catalyst team hopes you will enjoy using Catalyst as much
847 as we enjoyed making it. Please contact us if you have ideas
848 for improvement or other feedback.</p>
856 =head1 INTERNAL METHODS
858 These methods are not meant to be used by end users.
860 =head2 $c->components
862 Returns a hash of components.
864 =head2 $c->context_class
866 Returns or sets the context class.
870 Returns a hashref containing coderefs and execution counts (needed for
871 deep recursion detection).
875 Returns the number of actions on the current internal execution stack.
879 Dispatches a request to actions.
883 sub dispatch { my $c = shift; $c->dispatcher->dispatch( $c, @_ ) }
885 =head2 $c->dispatcher_class
887 Returns or sets the dispatcher class.
889 =head2 $c->dump_these
891 Returns a list of 2-element array references (name, structure) pairs
892 that will be dumped on the error page in debug mode.
898 [ Request => $c->req ], [ Response => $c->res ], [ Stash => $c->stash ],;
901 =head2 $c->engine_class
903 Returns or sets the engine class.
905 =head2 $c->execute( $class, $coderef )
907 Execute a coderef in given class and catch exceptions. Errors are available
913 my ( $c, $class, $code ) = @_;
914 $class = $c->component($class) || $class;
918 my $action = "$code";
919 $action = "/$action" unless $action =~ /\-\>/;
920 $c->counter->{"$code"}++;
922 if ( $c->counter->{"$code"} > $RECURSION ) {
923 my $error = qq/Deep recursion detected in "$action"/;
924 $c->log->error($error);
930 # determine if the call was the result of a forward
931 # this is done by walking up the call stack and looking for a calling
932 # sub of Catalyst::forward before the eval
934 for my $index ( 1 .. 10 ) {
936 if ( ( caller($index) )[0] eq 'Catalyst'
937 && ( caller($index) )[3] eq '(eval)' );
939 if ( ( caller($index) )[3] =~ /forward$/ ) {
940 $callsub = ( caller($index) )[3];
941 $action = "-> $action";
946 my $node = Tree::Simple->new(
949 elapsed => undef, # to be filled in later
952 $node->setUID( "$code" . $c->counter->{"$code"} );
954 unless ( ( $code->name =~ /^_.*/ )
955 && ( !$c->config->{show_internal_actions} ) )
958 # is this a root-level call or a forwarded call?
959 if ( $callsub =~ /forward$/ ) {
961 # forward, locate the caller
962 if ( my $parent = $c->stack->[-1] ) {
963 my $visitor = Tree::Simple::Visitor::FindByUID->new;
964 $visitor->searchForUID(
965 "$parent" . $c->counter->{"$parent"} );
966 $c->{stats}->accept($visitor);
967 if ( my $result = $visitor->getResult ) {
968 $result->addChild($node);
973 # forward with no caller may come from a plugin
974 $c->{stats}->addChild($node);
980 $c->{stats}->addChild($node);
985 push( @{ $c->stack }, $code );
988 $start = [gettimeofday] if $c->debug;
989 eval { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) };
990 $elapsed = tv_interval($start) if $c->debug;
993 unless ( ( $code->name =~ /^_.*/ )
994 && ( !$c->config->{show_internal_actions} ) )
997 # FindByUID uses an internal die, so we save the existing error
1000 # locate the node in the tree and update the elapsed time
1001 my $visitor = Tree::Simple::Visitor::FindByUID->new;
1002 $visitor->searchForUID( "$code" . $c->counter->{"$code"} );
1003 $c->{stats}->accept($visitor);
1004 if ( my $result = $visitor->getResult ) {
1005 my $value = $result->getNodeValue;
1006 $value->{elapsed} = sprintf( '%fs', $elapsed );
1007 $result->setNodeValue($value);
1011 $@ = $error || undef;
1014 my $last = ${ $c->stack }[-1];
1015 pop( @{ $c->stack } );
1017 if ( my $error = $@ ) {
1018 if ( $error eq $DETACH ) { die $DETACH if $c->depth > 1 }
1020 unless ( ref $error ) {
1022 my $class = $last->class;
1023 my $name = $last->name;
1024 $error = qq/Caught exception in $class->$name "$error"/;
1035 Finalizes the request.
1042 for my $error ( @{ $c->error } ) {
1043 $c->log->error($error);
1046 $c->finalize_uploads;
1049 if ( $#{ $c->error } >= 0 ) {
1053 $c->finalize_headers;
1056 if ( $c->request->method eq 'HEAD' ) {
1057 $c->response->body('');
1062 return $c->response->status;
1065 =head2 $c->finalize_body
1071 sub finalize_body { my $c = shift; $c->engine->finalize_body( $c, @_ ) }
1073 =head2 $c->finalize_cookies
1079 sub finalize_cookies { my $c = shift; $c->engine->finalize_cookies( $c, @_ ) }
1081 =head2 $c->finalize_error
1087 sub finalize_error { my $c = shift; $c->engine->finalize_error( $c, @_ ) }
1089 =head2 $c->finalize_headers
1095 sub finalize_headers {
1098 # Check if we already finalized headers
1099 return if $c->response->{_finalized_headers};
1102 if ( my $location = $c->response->redirect ) {
1103 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
1104 $c->response->header( Location => $location );
1108 if ( $c->response->body && !$c->response->content_length ) {
1110 # get the length from a filehandle
1111 if ( ref $c->response->body && $c->response->body->can('read') ) {
1112 if ( my $stat = stat $c->response->body ) {
1113 $c->response->content_length( $stat->size );
1116 $c->log->warn('Serving filehandle without a content-length');
1120 $c->response->content_length( bytes::length( $c->response->body ) );
1125 if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
1126 $c->response->headers->remove_header("Content-Length");
1127 $c->response->body('');
1130 $c->finalize_cookies;
1132 $c->engine->finalize_headers( $c, @_ );
1135 $c->response->{_finalized_headers} = 1;
1138 =head2 $c->finalize_output
1140 An alias for finalize_body.
1142 =head2 $c->finalize_read
1144 Finalizes the input after reading is complete.
1148 sub finalize_read { my $c = shift; $c->engine->finalize_read( $c, @_ ) }
1150 =head2 $c->finalize_uploads
1152 Finalizes uploads. Cleans up any temporary files.
1156 sub finalize_uploads { my $c = shift; $c->engine->finalize_uploads( $c, @_ ) }
1158 =head2 $c->get_action( $action, $namespace )
1160 Gets an action in a given namespace.
1164 sub get_action { my $c = shift; $c->dispatcher->get_action(@_) }
1166 =head2 $c->get_actions( $action, $namespace )
1168 Gets all actions of a given name in a namespace and all parent
1173 sub get_actions { my $c = shift; $c->dispatcher->get_actions( $c, @_ ) }
1175 =head2 handle_request( $class, @arguments )
1177 Called to handle each HTTP request.
1181 sub handle_request {
1182 my ( $class, @arguments ) = @_;
1184 # Always expect worst case!
1187 my $stats = ( $class->debug ) ? Tree::Simple->new: q{};
1190 my $c = $class->prepare(@arguments);
1191 $c->{stats} = $stats;
1193 return $c->finalize;
1196 if ( $class->debug ) {
1197 my $start = [gettimeofday];
1198 $status = &$handler;
1199 my $elapsed = tv_interval $start;
1200 $elapsed = sprintf '%f', $elapsed;
1201 my $av = sprintf '%.3f',
1202 ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
1203 my $t = Text::SimpleTable->new( [ 64, 'Action' ], [ 9, 'Time' ] );
1208 my $stat = $action->getNodeValue;
1209 $t->row( ( q{ } x $action->getDepth ) . $stat->{action},
1210 $stat->{elapsed} || '??' );
1215 "Request took ${elapsed}s ($av/s)\n" . $t->draw );
1217 else { $status = &$handler }
1221 if ( my $error = $@ ) {
1223 $class->log->error(qq/Caught exception in engine "$error"/);
1227 $class->log->_flush() if $class->log->can('_flush');
1231 =head2 $c->prepare( @arguments )
1233 Creates a Catalyst context from an engine-specific request (Apache, CGI,
1239 my ( $class, @arguments ) = @_;
1241 $class->context_class( ref $class || $class ) unless $class->context_class;
1242 my $c = $class->context_class->new(
1246 request => $class->request_class->new(
1249 body_parameters => {},
1251 headers => HTTP::Headers->new,
1253 query_parameters => {},
1259 response => $class->response_class->new(
1263 headers => HTTP::Headers->new(),
1272 # For on-demand data
1273 $c->request->{_context} = $c;
1274 $c->response->{_context} = $c;
1275 weaken( $c->request->{_context} );
1276 weaken( $c->response->{_context} );
1279 my $secs = time - $START || 1;
1280 my $av = sprintf '%.3f', $COUNT / $secs;
1281 $c->log->debug('**********************************');
1282 $c->log->debug("* Request $COUNT ($av/s) [$$]");
1283 $c->log->debug('**********************************');
1284 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
1287 $c->prepare_request(@arguments);
1288 $c->prepare_connection;
1289 $c->prepare_query_parameters;
1290 $c->prepare_headers;
1291 $c->prepare_cookies;
1295 $c->prepare_body unless $c->config->{parse_on_demand};
1297 my $method = $c->req->method || '';
1298 my $path = $c->req->path || '';
1299 my $address = $c->req->address || '';
1301 $c->log->debug(qq/"$method" request for "$path" from "$address"/)
1309 =head2 $c->prepare_action
1315 sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
1317 =head2 $c->prepare_body
1319 Prepares message body.
1326 # Do we run for the first time?
1327 return if defined $c->request->{_body};
1329 # Initialize on-demand data
1330 $c->engine->prepare_body( $c, @_ );
1331 $c->prepare_parameters;
1332 $c->prepare_uploads;
1334 if ( $c->debug && keys %{ $c->req->body_parameters } ) {
1335 my $t = Text::SimpleTable->new( [ 37, 'Key' ], [ 36, 'Value' ] );
1336 for my $key ( sort keys %{ $c->req->body_parameters } ) {
1337 my $param = $c->req->body_parameters->{$key};
1338 my $value = defined($param) ? $param : '';
1340 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1342 $c->log->debug( "Body Parameters are:\n" . $t->draw );
1346 =head2 $c->prepare_body_chunk( $chunk )
1348 Prepares a chunk of data before sending it to L<HTTP::Body>.
1352 sub prepare_body_chunk {
1354 $c->engine->prepare_body_chunk( $c, @_ );
1357 =head2 $c->prepare_body_parameters
1359 Prepares body parameters.
1363 sub prepare_body_parameters {
1365 $c->engine->prepare_body_parameters( $c, @_ );
1368 =head2 $c->prepare_connection
1370 Prepares connection.
1374 sub prepare_connection {
1376 $c->engine->prepare_connection( $c, @_ );
1379 =head2 $c->prepare_cookies
1385 sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
1387 =head2 $c->prepare_headers
1393 sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
1395 =head2 $c->prepare_parameters
1397 Prepares parameters.
1401 sub prepare_parameters {
1403 $c->prepare_body_parameters;
1404 $c->engine->prepare_parameters( $c, @_ );
1407 =head2 $c->prepare_path
1409 Prepares path and base.
1413 sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
1415 =head2 $c->prepare_query_parameters
1417 Prepares query parameters.
1421 sub prepare_query_parameters {
1424 $c->engine->prepare_query_parameters( $c, @_ );
1426 if ( $c->debug && keys %{ $c->request->query_parameters } ) {
1427 my $t = Text::SimpleTable->new( [ 37, 'Key' ], [ 36, 'Value' ] );
1428 for my $key ( sort keys %{ $c->req->query_parameters } ) {
1429 my $param = $c->req->query_parameters->{$key};
1430 my $value = defined($param) ? $param : '';
1432 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1434 $c->log->debug( "Query Parameters are:\n" . $t->draw );
1438 =head2 $c->prepare_read
1440 Prepares the input for reading.
1444 sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
1446 =head2 $c->prepare_request
1448 Prepares the engine request.
1452 sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
1454 =head2 $c->prepare_uploads
1460 sub prepare_uploads {
1463 $c->engine->prepare_uploads( $c, @_ );
1465 if ( $c->debug && keys %{ $c->request->uploads } ) {
1466 my $t = Text::SimpleTable->new(
1472 for my $key ( sort keys %{ $c->request->uploads } ) {
1473 my $upload = $c->request->uploads->{$key};
1474 for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
1475 $t->row( $key, $u->filename, $u->type, $u->size );
1478 $c->log->debug( "File Uploads are:\n" . $t->draw );
1482 =head2 $c->prepare_write
1484 Prepares the output for writing.
1488 sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
1490 =head2 $c->request_class
1492 Returns or sets the request class.
1494 =head2 $c->response_class
1496 Returns or sets the response class.
1498 =head2 $c->read( [$maxlength] )
1500 Reads a chunk of data from the request body. This method is designed to
1501 be used in a while loop, reading C<$maxlength> bytes on every call.
1502 C<$maxlength> defaults to the size of the request if not specified.
1504 You have to set C<MyApp-E<gt>config-E<gt>{parse_on_demand}> to use this
1509 sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
1517 sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
1519 =head2 $c->set_action( $action, $code, $namespace, $attrs )
1521 Sets an action in a given namespace.
1525 sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
1527 =head2 $c->setup_actions($component)
1529 Sets up actions for a component.
1533 sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
1535 =head2 $c->setup_components
1541 sub setup_components {
1544 my $callback = sub {
1545 my ( $component, $context ) = @_;
1547 unless ( $component->can('COMPONENT') ) {
1551 my $suffix = Catalyst::Utils::class2classsuffix($component);
1552 my $config = $class->config->{$suffix} || {};
1556 eval { $instance = $component->COMPONENT( $context, $config ); };
1558 if ( my $error = $@ ) {
1562 Catalyst::Exception->throw( message =>
1563 qq/Couldn't instantiate component "$component", "$error"/ );
1566 Catalyst::Exception->throw( message =>
1567 qq/Couldn't instantiate component "$component", "COMPONENT() didn't return a object"/
1569 unless ref $instance;
1573 eval "package $class;\n" . q!Module::Pluggable::Fast->import(
1574 name => '_catalyst_components',
1576 "$class\::Controller", "$class\::C",
1577 "$class\::Model", "$class\::M",
1578 "$class\::View", "$class\::V"
1580 callback => $callback
1584 if ( my $error = $@ ) {
1588 Catalyst::Exception->throw(
1589 message => qq/Couldn't load components "$error"/ );
1592 for my $component ( $class->_catalyst_components($class) ) {
1593 $class->components->{ ref $component || $component } = $component;
1597 =head2 $c->setup_dispatcher
1603 sub setup_dispatcher {
1604 my ( $class, $dispatcher ) = @_;
1607 $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
1610 if ( $ENV{CATALYST_DISPATCHER} ) {
1611 $dispatcher = 'Catalyst::Dispatcher::' . $ENV{CATALYST_DISPATCHER};
1614 if ( $ENV{ uc($class) . '_DISPATCHER' } ) {
1616 'Catalyst::Dispatcher::' . $ENV{ uc($class) . '_DISPATCHER' };
1619 unless ($dispatcher) {
1620 $dispatcher = $class->dispatcher_class;
1623 $dispatcher->require;
1626 Catalyst::Exception->throw(
1627 message => qq/Couldn't load dispatcher "$dispatcher", "$@"/ );
1630 # dispatcher instance
1631 $class->dispatcher( $dispatcher->new );
1634 =head2 $c->setup_engine
1641 my ( $class, $engine ) = @_;
1644 $engine = 'Catalyst::Engine::' . $engine;
1647 if ( $ENV{CATALYST_ENGINE} ) {
1648 $engine = 'Catalyst::Engine::' . $ENV{CATALYST_ENGINE};
1651 if ( $ENV{ uc($class) . '_ENGINE' } ) {
1652 $engine = 'Catalyst::Engine::' . $ENV{ uc($class) . '_ENGINE' };
1655 if ( $ENV{MOD_PERL} ) {
1657 # create the apache method
1660 *{"$class\::apache"} = sub { shift->engine->apache };
1663 my ( $software, $version ) =
1664 $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
1667 $version =~ s/(\.[^.]+)\./$1/g;
1669 if ( $software eq 'mod_perl' ) {
1673 if ( $version >= 1.99922 ) {
1674 $engine = 'Catalyst::Engine::Apache2::MP20';
1677 elsif ( $version >= 1.9901 ) {
1678 $engine = 'Catalyst::Engine::Apache2::MP19';
1681 elsif ( $version >= 1.24 ) {
1682 $engine = 'Catalyst::Engine::Apache::MP13';
1686 Catalyst::Exception->throw( message =>
1687 qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
1692 # install the correct mod_perl handler
1693 if ( $version >= 1.9901 ) {
1694 *handler = sub : method {
1695 shift->handle_request(@_);
1699 *handler = sub ($$) { shift->handle_request(@_) };
1704 elsif ( $software eq 'Zeus-Perl' ) {
1705 $engine = 'Catalyst::Engine::Zeus';
1709 Catalyst::Exception->throw(
1710 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
1715 $engine = $class->engine_class;
1721 Catalyst::Exception->throw( message =>
1722 qq/Couldn't load engine "$engine" (maybe you forgot to install it?), "$@"/
1726 # check for old engines that are no longer compatible
1728 if ( $engine->isa('Catalyst::Engine::Apache')
1729 && !Catalyst::Engine::Apache->VERSION )
1734 elsif ( $engine->isa('Catalyst::Engine::Server::Base')
1735 && Catalyst::Engine::Server->VERSION le '0.02' )
1740 elsif ($engine->isa('Catalyst::Engine::HTTP::POE')
1741 && $engine->VERSION eq '0.01' )
1746 elsif ($engine->isa('Catalyst::Engine::Zeus')
1747 && $engine->VERSION eq '0.01' )
1753 Catalyst::Exception->throw( message =>
1754 qq/Engine "$engine" is not supported by this version of Catalyst/
1759 $class->engine( $engine->new );
1762 =head2 $c->setup_home
1764 Sets up the home directory.
1769 my ( $class, $home ) = @_;
1771 if ( $ENV{CATALYST_HOME} ) {
1772 $home = $ENV{CATALYST_HOME};
1775 if ( $ENV{ uc($class) . '_HOME' } ) {
1776 $home = $ENV{ uc($class) . '_HOME' };
1780 $home = Catalyst::Utils::home($class);
1784 $class->config->{home} ||= $home;
1785 $class->config->{root} ||= dir($home)->subdir('root');
1789 =head2 $c->setup_log
1796 my ( $class, $debug ) = @_;
1798 unless ( $class->log ) {
1799 $class->log( Catalyst::Log->new );
1802 my $app_flag = Catalyst::Utils::class2env($class) . '_DEBUG';
1805 ( defined( $ENV{CATALYST_DEBUG} ) || defined( $ENV{$app_flag} ) )
1806 ? ( $ENV{CATALYST_DEBUG} || $ENV{$app_flag} )
1811 *{"$class\::debug"} = sub { 1 };
1812 $class->log->debug('Debug messages enabled');
1816 =head2 $c->setup_plugins
1823 my ( $class, $plugins ) = @_;
1826 for my $plugin ( reverse @$plugins ) {
1828 $plugin = "Catalyst::Plugin::$plugin";
1833 Catalyst::Exception->throw(
1834 message => qq/Couldn't load plugin "$plugin", "$@"/ );
1839 unshift @{"$class\::ISA"}, $plugin;
1848 =head2 $c->write( $data )
1850 Writes $data to the output stream. When using this method directly, you
1851 will need to manually set the C<Content-Length> header to the length of
1852 your output data, if known.
1859 # Finalize headers if someone manually writes output
1860 $c->finalize_headers;
1862 return $c->engine->write( $c, @_ );
1867 Returns the Catalyst version number. Mostly useful for "powered by"
1868 messages in template systems.
1872 sub version { return $Catalyst::VERSION }
1874 =head1 INTERNAL ACTIONS
1876 Catalyst uses internal actions like C<_DISPATCH>, C<_BEGIN>, C<_AUTO>,
1877 C<_ACTION>, and C<_END>. These are by default not shown in the private
1878 action table, but you can make them visible with a config parameter.
1880 MyApp->config->{show_internal_actions} = 1;
1882 =head1 CASE SENSITIVITY
1884 By default Catalyst is not case sensitive, so C<MyApp::C::FOO::Bar> is
1885 mapped to C</foo/bar>. You can activate case sensitivity with a config
1888 MyApp->config->{case_sensitive} = 1;
1890 This causes C<MyApp::C::Foo::Bar> to map to C</Foo/Bar>.
1892 =head1 ON-DEMAND PARSER
1894 The request body is usually parsed at the beginning of a request,
1895 but if you want to handle input yourself or speed things up a bit,
1896 you can enable on-demand parsing with a config parameter.
1898 MyApp->config->{parse_on_demand} = 1;
1900 =head1 PROXY SUPPORT
1902 Many production servers operate using the common double-server approach,
1903 with a lightweight frontend web server passing requests to a larger
1904 backend server. An application running on the backend server must deal
1905 with two problems: the remote user always appears to be C<127.0.0.1> and
1906 the server's hostname will appear to be C<localhost> regardless of the
1907 virtual host that the user connected through.
1909 Catalyst will automatically detect this situation when you are running
1910 the frontend and backend servers on the same machine. The following
1911 changes are made to the request.
1913 $c->req->address is set to the user's real IP address, as read from
1914 the HTTP X-Forwarded-For header.
1916 The host value for $c->req->base and $c->req->uri is set to the real
1917 host, as read from the HTTP X-Forwarded-Host header.
1919 Obviously, your web server must support these headers for this to work.
1921 In a more complex server farm environment where you may have your
1922 frontend proxy server(s) on different machines, you will need to set a
1923 configuration option to tell Catalyst to read the proxied data from the
1926 MyApp->config->{using_frontend_proxy} = 1;
1928 If you do not wish to use the proxy support at all, you may set:
1930 MyApp->config->{ignore_frontend_proxy} = 1;
1932 =head1 THREAD SAFETY
1934 Catalyst has been tested under Apache 2's threading mpm_worker, mpm_winnt,
1935 and the standalone forking HTTP server on Windows. We believe the Catalyst
1936 core to be thread-safe.
1938 If you plan to operate in a threaded environment, remember that all other
1939 modules you are using must also be thread-safe. Some modules, most notably
1940 L<DBD::SQLite>, are not thread-safe.
1946 Join #catalyst on irc.perl.org.
1950 http://lists.rawmode.org/mailman/listinfo/catalyst
1951 http://lists.rawmode.org/mailman/listinfo/catalyst-dev
1955 http://catalyst.perl.org
1959 http://dev.catalyst.perl.org
1963 =head2 L<Task::Catalyst> - All you need to start with Catalyst
1965 =head2 L<Catalyst::Manual> - The Catalyst Manual
1967 =head2 L<Catalyst::Component>, L<Catalyst::Base> - Base classes for components
1969 =head2 L<Catalyst::Engine> - Core engine
1971 =head2 L<Catalyst::Log> - Log class.
1973 =head2 L<Catalyst::Request> - Request object
1975 =head2 L<Catalyst::Response> - Response object
1977 =head2 L<Catalyst::Test> - The test suite.
2047 Sebastian Riedel, C<sri@oook.de>
2051 This library is free software, you can redistribute it and/or modify it under
2052 the same terms as Perl itself.