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 blessed/;
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 = 27;
52 __PACKAGE__->mk_classdata($_)
53 for qw/components arguments dispatcher engine log dispatcher_class
54 engine_class context_class request_class response_class setup_finished/;
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.66';
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 If your plugin starts with a name other than C<Catalyst::Plugin::>, you can
182 fully qualify the name by using a unary plus:
186 +Fully::Qualified::Plugin::Name
189 Special flags like C<-Debug> and C<-Engine> can also be specified as
190 arguments when Catalyst is loaded:
192 use Catalyst qw/-Debug My::Module/;
194 The position of plugins and flags in the chain is important, because
195 they are loaded in exactly the order in which they appear.
197 The following flags are supported:
201 Enables debug output.
205 Forces Catalyst to use a specific engine. Omit the
206 C<Catalyst::Engine::> prefix of the engine name, i.e.:
208 use Catalyst qw/-Engine=CGI/;
212 Forces Catalyst to use a specific home directory, e.g.:
214 use Catalyst qw[-Home=/usr/sri];
222 =head2 INFORMATION ABOUT THE CURRENT REQUEST
226 Returns a L<Catalyst::Action> object for the current action, which
227 stringifies to the action name. See L<Catalyst::Action>.
231 Returns the namespace of the current action, i.e., the uri prefix
232 corresponding to the controller of the current action. For example:
234 # in Controller::Foo::Bar
235 $c->namespace; # returns 'foo/bar';
241 Returns the current L<Catalyst::Request> object. See
242 L<Catalyst::Request>.
244 =head2 PROCESSING AND RESPONSE TO THE CURRENT REQUEST
246 =head2 $c->forward( $action [, \@arguments ] )
248 =head2 $c->forward( $class, $method, [, \@arguments ] )
250 Forwards processing to a private action. If you give a class name but no
251 method, C<process()> is called. You may also optionally pass arguments
252 in an arrayref. The action will receive the arguments in C<@_> and
253 C<$c-E<gt>req-E<gt>args>. Upon returning from the function,
254 C<$c-E<gt>req-E<gt>args> will be restored to the previous values.
256 Any data C<return>ed from the action forwarded to, will be returned by the
259 my $foodata = $c->forward('/foo');
260 $c->forward('index');
261 $c->forward(qw/MyApp::Model::DBIC::Foo do_stuff/);
262 $c->forward('MyApp::View::TT');
266 sub forward { my $c = shift; $c->dispatcher->forward( $c, @_ ) }
268 =head2 $c->detach( $action [, \@arguments ] )
270 =head2 $c->detach( $class, $method, [, \@arguments ] )
272 The same as C<forward>, but doesn't return.
276 sub detach { my $c = shift; $c->dispatcher->detach( $c, @_ ) }
280 =head2 $c->error($error, ...)
282 =head2 $c->error($arrayref)
284 Returns an arrayref containing error messages. If Catalyst encounters an
285 error while processing a request, it stores the error in $c->error. This
286 method should not be used to store non-fatal error messages.
288 my @error = @{ $c->error };
292 $c->error('Something bad happened');
294 Clear errors. You probably don't want to clear the errors unless you are
295 implementing a custom error screen.
304 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
305 push @{ $c->{error} }, @$error;
307 elsif ( defined $_[0] ) { $c->{error} = undef }
308 return $c->{error} || [];
315 Returns the current L<Catalyst::Response> object.
319 Returns a hashref to the stash, which may be used to store data and pass
320 it between components during a request. You can also set hash keys by
321 passing arguments. The stash is automatically sent to the view. The
322 stash is cleared at the end of a request; it cannot be used for
325 $c->stash->{foo} = $bar;
326 $c->stash( { moose => 'majestic', qux => 0 } );
327 $c->stash( bar => 1, gorch => 2 ); # equivalent to passing a hashref
329 # stash is automatically passed to the view for use in a template
330 $c->forward( 'MyApp::V::TT' );
337 my $stash = @_ > 1 ? {@_} : $_[0];
338 while ( my ( $key, $val ) = each %$stash ) {
339 $c->{stash}->{$key} = $val;
347 Contains the return value of the last executed action.
353 my ($c, @names) = @_;
355 foreach my $name (@names) {
356 foreach my $component ( keys %{ $c->components } ) {
357 my $comp = $c->components->{$component} if $component =~ /$name/i;
359 if ( eval { $comp->can('ACCEPT_CONTEXT'); } ) {
360 return $comp->ACCEPT_CONTEXT($c);
362 else { return $comp }
370 # try explicit component names
372 my ($c, @names) = @_;
374 foreach my $try (@names) {
375 if ( exists $c->components->{$try} ) {
376 my $comp = $c->components->{$try};
377 if ( eval { $comp->can('ACCEPT_CONTEXT'); } ) {
378 return $comp->ACCEPT_CONTEXT($c);
380 else { return $comp }
387 # like component, but try just these prefixes before regex searching,
388 # and do not try to return "sort keys %{ $c->components }"
390 my ($c, $name, @prefixes) = @_;
392 my $appclass = ref $c || $c;
394 my @names = map { "${appclass}::${_}::${name}" } @prefixes;
396 my $comp = $c->_comp_explicit(@names);
397 return $comp if defined($comp);
398 $comp = $c->_comp_search($name);
402 # Return a component if only one matches.
404 my ($c, @prefixes) = @_;
406 my $appclass = ref $c || $c;
408 my ($comp,$rest) = map { $c->_comp_search("^${appclass}::${_}::") }
410 return $comp unless $rest;
413 =head2 COMPONENT ACCESSORS
415 =head2 $c->comp($name)
417 =head2 $c->component($name)
419 Gets a component object by name. This method is no longer recommended,
420 unless you want to get a specific component by full
421 class. C<$c-E<gt>controller>, C<$c-E<gt>model>, and C<$c-E<gt>view>
422 should be used instead.
433 my $appclass = ref $c || $c;
436 $name, "${appclass}::${name}",
437 map { "${appclass}::${_}::${name}" }
438 qw/Model M Controller C View V/
441 my $comp = $c->_comp_explicit(@names);
442 return $comp if defined($comp);
444 $comp = $c->_comp_search($name);
445 return $comp if defined($comp);
448 return sort keys %{ $c->components };
451 =head2 $c->controller($name)
453 Gets a L<Catalyst::Controller> instance by name.
455 $c->controller('Foo')->do_stuff;
457 If name is omitted, will return the controller for the dispatched action.
462 my ( $c, $name ) = @_;
463 return $c->_comp_prefixes($name, qw/Controller C/)
465 return $c->component($c->action->class);
468 =head2 $c->model($name)
470 Gets a L<Catalyst::Model> instance by name.
472 $c->model('Foo')->do_stuff;
474 If the name is omitted, it will look for a config setting 'default_model',
475 or check if there is only one model, and forward to it if that's the case.
480 my ( $c, $name ) = @_;
481 return $c->_comp_prefixes($name, qw/Model M/)
483 return $c->comp($c->config->{default_model})
484 if $c->config->{default_model};
485 return $c->_comp_singular(qw/Model M/);
489 =head2 $c->view($name)
491 Gets a L<Catalyst::View> instance by name.
493 $c->view('Foo')->do_stuff;
495 If the name is omitted, it will look for a config setting 'default_view',
496 or check if there is only one view, and forward to it if that's the case.
501 my ( $c, $name ) = @_;
502 return $c->_comp_prefixes($name, qw/View V/)
504 return $c->comp($c->config->{default_view})
505 if $c->config->{default_view};
506 return $c->_comp_singular(qw/View V/);
509 =head2 Class data and helper classes
513 Returns or takes a hashref containing the application's configuration.
515 __PACKAGE__->config( { db => 'dsn:SQLite:foo.db' } );
517 You can also use a L<YAML> config file like myapp.yml in your
518 applications home directory.
521 db: dsn:SQLite:foo.db
528 $c->log->warn("Setting config after setup has been run is not a good idea.")
529 if ( @_ and $c->setup_finished );
531 $c->NEXT::config(@_);
536 Overload to enable debug messages (same as -Debug option).
542 =head2 $c->dispatcher
544 Returns the dispatcher instance. Stringifies to class name. See
545 L<Catalyst::Dispatcher>.
549 Returns the engine instance. Stringifies to the class name. See
554 Returns the logging object instance. Unless it is already set, Catalyst sets
555 this up with a L<Catalyst::Log> object. To use your own log class, set the
556 logger with the C<< __PACKAGE__->log >> method prior to calling
557 C<< __PACKAGE__->setup >>.
559 __PACKAGE__->log( MyLogger->new );
564 $c->log->info( 'Now logging with my own logger!' );
566 Your log class should implement the methods described in the
567 L<Catalyst::Log> man page.
571 =head2 UTILITY METHODS
573 =head2 $c->path_to(@path)
575 Merges C<@path> with C<$c-E<gt>config-E<gt>{home}> and returns a
576 L<Path::Class> object.
580 $c->path_to( 'db', 'sqlite.db' );
585 my ( $c, @path ) = @_;
586 my $path = dir( $c->config->{home}, @path );
587 if ( -d $path ) { return $path }
588 else { return file( $c->config->{home}, @path ) }
591 =head2 $c->plugin( $name, $class, @args )
593 Helper method for plugins. It creates a classdata accessor/mutator and
594 loads and instantiates the given class.
596 MyApp->plugin( 'prototype', 'HTML::Prototype' );
598 $c->prototype->define_javascript_functions;
603 my ( $class, $name, $plugin, @args ) = @_;
604 $class->_register_plugin( $plugin, 1 );
606 eval { $plugin->import };
607 $class->mk_classdata($name);
609 eval { $obj = $plugin->new(@args) };
612 Catalyst::Exception->throw( message =>
613 qq/Couldn't instantiate instant plugin "$plugin", "$@"/ );
617 $class->log->debug(qq/Initialized instant plugin "$plugin" as "$name"/)
623 Initializes the dispatcher and engine, loads any plugins, and loads the
624 model, view, and controller components. You may also specify an array
625 of plugins to load here, if you choose to not load them in the C<use
629 MyApp->setup( qw/-Debug/ );
634 my ( $class, @arguments ) = @_;
636 unless ( $class->isa('Catalyst') ) {
638 Catalyst::Exception->throw(
639 message => qq/'$class' does not inherit from Catalyst/ );
642 if ( $class->arguments ) {
643 @arguments = ( @arguments, @{ $class->arguments } );
649 foreach (@arguments) {
653 ( $flags->{log} ) ? 'debug,' . $flags->{log} : 'debug';
655 elsif (/^-(\w+)=?(.*)$/) {
656 $flags->{ lc $1 } = $2;
659 push @{ $flags->{plugins} }, $_;
663 $class->setup_home( delete $flags->{home} );
665 $class->setup_log( delete $flags->{log} );
666 $class->setup_plugins( delete $flags->{plugins} );
667 $class->setup_dispatcher( delete $flags->{dispatcher} );
668 $class->setup_engine( delete $flags->{engine} );
670 for my $flag ( sort keys %{$flags} ) {
672 if ( my $code = $class->can( 'setup_' . $flag ) ) {
673 &$code( $class, delete $flags->{$flag} );
676 $class->log->warn(qq/Unknown flag "$flag"/);
681 <<"EOF") if ( $ENV{CATALYST_SCRIPT_GEN} && ( $ENV{CATALYST_SCRIPT_GEN} < $Catalyst::CATALYST_SCRIPT_GEN ) );
682 You are running an old script!
684 Please update by running (this will overwrite existing files):
685 catalyst.pl -force -scripts $class
687 or (this will not overwrite existing files):
688 catalyst.pl -scripts $class
691 if ( $class->debug ) {
698 map { $_ . ' ' . ( $_->VERSION || '' ) }
699 grep { /^Catalyst::Plugin/ } @{"$class\::ISA"};
703 my $t = Text::SimpleTable->new(76);
704 $t->row($_) for @plugins;
705 $class->log->debug( "Loaded plugins:\n" . $t->draw );
708 my $dispatcher = $class->dispatcher;
709 my $engine = $class->engine;
710 my $home = $class->config->{home};
712 $class->log->debug(qq/Loaded dispatcher "$dispatcher"/);
713 $class->log->debug(qq/Loaded engine "$engine"/);
717 ? $class->log->debug(qq/Found home "$home"/)
718 : $class->log->debug(qq/Home "$home" doesn't exist/)
719 : $class->log->debug(q/Couldn't find home/);
724 no warnings qw/redefine/;
725 local *setup = sub { };
729 # Initialize our data structure
730 $class->components( {} );
732 $class->setup_components;
734 if ( $class->debug ) {
735 my $t = Text::SimpleTable->new( [ 65, 'Class' ], [ 8, 'Type' ] );
736 for my $comp ( sort keys %{ $class->components } ) {
737 my $type = ref $class->components->{$comp} ? 'instance' : 'class';
738 $t->row( $comp, $type );
740 $class->log->debug( "Loaded components:\n" . $t->draw )
741 if ( keys %{ $class->components } );
744 # Add our self to components, since we are also a component
745 $class->components->{$class} = $class;
747 $class->setup_actions;
749 if ( $class->debug ) {
750 my $name = $class->config->{name} || 'Application';
751 $class->log->info("$name powered by Catalyst $Catalyst::VERSION");
753 $class->log->_flush() if $class->log->can('_flush');
755 $class->setup_finished(1);
758 =head2 $c->uri_for( $path, [ @args ] )
760 Merges path with C<$c-E<gt>request-E<gt>base> for absolute uri's and
761 with C<$c-E<gt>namespace> for relative uri's, then returns a
762 normalized L<URI> object. If any args are passed, they are added at the
763 end of the path. If the last argument to uri_for is a hash reference,
764 it is assumed to contain GET parameter key/value pairs, which will be
765 appended to the URI in standard fashion.
770 my ( $c, $path, @args ) = @_;
771 my $base = $c->request->base->clone;
772 my $basepath = $base->path;
773 $basepath =~ s/\/$//;
775 my $namespace = $c->namespace;
777 # massage namespace, empty if absolute path
778 $namespace =~ s/^\///;
779 $namespace .= '/' if $namespace;
781 $namespace = '' if $path =~ /^\//;
785 ( scalar @args && ref $args[$#args] eq 'HASH' ? pop @args : {} );
787 # join args with '/', or a blank string
788 my $args = ( scalar @args ? '/' . join( '/', @args ) : '' );
789 $args =~ s/^\/// unless $path;
791 URI->new_abs( URI->new_abs( "$path$args", "$basepath$namespace" ), $base )
793 $res->query_form(%$params);
797 =head2 $c->welcome_message
799 Returns the Catalyst welcome HTML page.
803 sub welcome_message {
805 my $name = $c->config->{name};
806 my $logo = $c->uri_for('/static/images/catalyst_logo.png');
807 my $prefix = Catalyst::Utils::appprefix( ref $c );
808 $c->response->content_type('text/html; charset=utf-8');
810 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
811 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
812 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
814 <meta http-equiv="Content-Language" content="en" />
815 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
816 <title>$name on Catalyst $VERSION</title>
817 <style type="text/css">
820 background-color: #eee;
829 background-color: #ccc;
830 border: 1px solid #aaa;
831 -moz-border-radius: 10px;
836 font-family: verdana, tahoma, sans-serif;
839 font-family: verdana, tahoma, sans-serif;
842 text-decoration: none;
844 border-bottom: 1px dotted #bbb;
846 :link:hover, :visited:hover {
859 background-color: #fff;
860 border: 1px solid #aaa;
861 -moz-border-radius: 10px;
887 <h1><span id="appname">$name</span> on <a href="http://catalyst.perl.org">Catalyst</a>
892 <img src="$logo" alt="Catalyst Logo" />
894 <p>Welcome to the wonderful world of Catalyst.
895 This <a href="http://en.wikipedia.org/wiki/MVC">MVC</a>
896 framework will make web development something you had
897 never expected it to be: Fun, rewarding, and quick.</p>
898 <h2>What to do now?</h2>
899 <p>That really depends on what <b>you</b> want to do.
900 We do, however, provide you with a few starting points.</p>
901 <p>If you want to jump right into web development with Catalyst
902 you might want to check out the documentation.</p>
903 <pre><code>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst/lib/Catalyst/Manual/Intro.pod">Catalyst::Manual::Intro</a>
904 perldoc <a href="http://cpansearch.perl.org/dist/Catalyst/lib/Catalyst/Manual/Tutorial.pod">Catalyst::Manual::Tutorial</a></code>
905 perldoc <a href="http://cpansearch.perl.org/dist/Catalyst/lib/Catalyst/Manual.pod">Catalyst::Manual</a></code></pre>
906 <h2>What to do next?</h2>
907 <p>Next it's time to write an actual application. Use the
908 helper scripts to generate <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AController%3A%3A&mode=all">controllers</a>,
909 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AModel%3A%3A&mode=all">models</a>, and
910 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AView%3A%3A&mode=all">views</a>;
911 they can save you a lot of work.</p>
912 <pre><code>script/${prefix}_create.pl -help</code></pre>
913 <p>Also, be sure to check out the vast and growing
914 collection of <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3APlugin%3A%3A&mode=all">plugins for Catalyst on CPAN</a>;
915 you are likely to find what you need there.
919 <p>Catalyst has a very active community. Here are the main places to
920 get in touch with us.</p>
923 <a href="http://dev.catalyst.perl.org">Wiki</a>
926 <a href="http://lists.rawmode.org/mailman/listinfo/catalyst">Mailing-List</a>
929 <a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
932 <h2>In conclusion</h2>
933 <p>The Catalyst team hopes you will enjoy using Catalyst as much
934 as we enjoyed making it. Please contact us if you have ideas
935 for improvement or other feedback.</p>
943 =head1 INTERNAL METHODS
945 These methods are not meant to be used by end users.
947 =head2 $c->components
949 Returns a hash of components.
951 =head2 $c->context_class
953 Returns or sets the context class.
957 Returns a hashref containing coderefs and execution counts (needed for
958 deep recursion detection).
962 Returns the number of actions on the current internal execution stack.
966 Dispatches a request to actions.
970 sub dispatch { my $c = shift; $c->dispatcher->dispatch( $c, @_ ) }
972 =head2 $c->dispatcher_class
974 Returns or sets the dispatcher class.
976 =head2 $c->dump_these
978 Returns a list of 2-element array references (name, structure) pairs
979 that will be dumped on the error page in debug mode.
985 [ Request => $c->req ], [ Response => $c->res ], [ Stash => $c->stash ],;
988 =head2 $c->engine_class
990 Returns or sets the engine class.
992 =head2 $c->execute( $class, $coderef )
994 Execute a coderef in given class and catch exceptions. Errors are available
1000 my ( $c, $class, $code ) = @_;
1001 $class = $c->component($class) || $class;
1004 if ($c->depth >= $RECURSION) {
1005 my $action = "$code";
1006 $action = "/$action" unless $action =~ /\-\>/;
1007 my $error = qq/Deep recursion detected calling "$action"/;
1008 $c->log->error($error);
1016 my $action = "$code";
1017 $action = "/$action" unless $action =~ /\-\>/;
1018 $c->counter->{"$code"}++;
1020 # determine if the call was the result of a forward
1021 # this is done by walking up the call stack and looking for a calling
1022 # sub of Catalyst::forward before the eval
1024 for my $index ( 1 .. 10 ) {
1026 if ( ( caller($index) )[0] eq 'Catalyst'
1027 && ( caller($index) )[3] eq '(eval)' );
1029 if ( ( caller($index) )[3] =~ /forward$/ ) {
1030 $callsub = ( caller($index) )[3];
1031 $action = "-> $action";
1036 my $node = Tree::Simple->new(
1039 elapsed => undef, # to be filled in later
1042 $node->setUID( "$code" . $c->counter->{"$code"} );
1044 unless ( ( $code->name =~ /^_.*/ )
1045 && ( !$c->config->{show_internal_actions} ) )
1048 # is this a root-level call or a forwarded call?
1049 if ( $callsub =~ /forward$/ ) {
1051 # forward, locate the caller
1052 if ( my $parent = $c->stack->[-1] ) {
1053 my $visitor = Tree::Simple::Visitor::FindByUID->new;
1054 $visitor->searchForUID(
1055 "$parent" . $c->counter->{"$parent"} );
1056 $c->{stats}->accept($visitor);
1057 if ( my $result = $visitor->getResult ) {
1058 $result->addChild($node);
1063 # forward with no caller may come from a plugin
1064 $c->{stats}->addChild($node);
1070 $c->{stats}->addChild($node);
1075 push( @{ $c->stack }, $code );
1078 $start = [gettimeofday] if $c->debug;
1079 eval { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) };
1080 $elapsed = tv_interval($start) if $c->debug;
1083 unless ( ( $code->name =~ /^_.*/ )
1084 && ( !$c->config->{show_internal_actions} ) )
1087 # FindByUID uses an internal die, so we save the existing error
1090 # locate the node in the tree and update the elapsed time
1091 my $visitor = Tree::Simple::Visitor::FindByUID->new;
1092 $visitor->searchForUID( "$code" . $c->counter->{"$code"} );
1093 $c->{stats}->accept($visitor);
1094 if ( my $result = $visitor->getResult ) {
1095 my $value = $result->getNodeValue;
1096 $value->{elapsed} = sprintf( '%fs', $elapsed );
1097 $result->setNodeValue($value);
1101 $@ = $error || undef;
1104 my $last = ${ $c->stack }[-1];
1105 pop( @{ $c->stack } );
1107 if ( my $error = $@ ) {
1108 if ( $error eq $DETACH ) { die $DETACH if $c->depth > 1 }
1110 unless ( ref $error ) {
1112 my $class = $last->class;
1113 my $name = $last->name;
1114 $error = qq/Caught exception in $class->$name "$error"/;
1125 Finalizes the request.
1132 for my $error ( @{ $c->error } ) {
1133 $c->log->error($error);
1136 $c->finalize_uploads;
1139 if ( $#{ $c->error } >= 0 ) {
1143 $c->finalize_headers;
1146 if ( $c->request->method eq 'HEAD' ) {
1147 $c->response->body('');
1152 return $c->response->status;
1155 =head2 $c->finalize_body
1161 sub finalize_body { my $c = shift; $c->engine->finalize_body( $c, @_ ) }
1163 =head2 $c->finalize_cookies
1169 sub finalize_cookies { my $c = shift; $c->engine->finalize_cookies( $c, @_ ) }
1171 =head2 $c->finalize_error
1177 sub finalize_error { my $c = shift; $c->engine->finalize_error( $c, @_ ) }
1179 =head2 $c->finalize_headers
1185 sub finalize_headers {
1188 # Check if we already finalized headers
1189 return if $c->response->{_finalized_headers};
1192 if ( my $location = $c->response->redirect ) {
1193 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
1194 $c->response->header( Location => $location );
1198 if ( $c->response->body && !$c->response->content_length ) {
1200 # get the length from a filehandle
1201 if ( blessed($c->response->body) && $c->response->body->can('read') ) {
1202 if ( my $stat = stat $c->response->body ) {
1203 $c->response->content_length( $stat->size );
1206 $c->log->warn('Serving filehandle without a content-length');
1210 $c->response->content_length( bytes::length( $c->response->body ) );
1215 if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
1216 $c->response->headers->remove_header("Content-Length");
1217 $c->response->body('');
1220 $c->finalize_cookies;
1222 $c->engine->finalize_headers( $c, @_ );
1225 $c->response->{_finalized_headers} = 1;
1228 =head2 $c->finalize_output
1230 An alias for finalize_body.
1232 =head2 $c->finalize_read
1234 Finalizes the input after reading is complete.
1238 sub finalize_read { my $c = shift; $c->engine->finalize_read( $c, @_ ) }
1240 =head2 $c->finalize_uploads
1242 Finalizes uploads. Cleans up any temporary files.
1246 sub finalize_uploads { my $c = shift; $c->engine->finalize_uploads( $c, @_ ) }
1248 =head2 $c->get_action( $action, $namespace )
1250 Gets an action in a given namespace.
1254 sub get_action { my $c = shift; $c->dispatcher->get_action(@_) }
1256 =head2 $c->get_actions( $action, $namespace )
1258 Gets all actions of a given name in a namespace and all parent
1263 sub get_actions { my $c = shift; $c->dispatcher->get_actions( $c, @_ ) }
1265 =head2 $c->handle_request( $class, @arguments )
1267 Called to handle each HTTP request.
1271 sub handle_request {
1272 my ( $class, @arguments ) = @_;
1274 # Always expect worst case!
1277 my $stats = ( $class->debug ) ? Tree::Simple->new: q{};
1280 my $c = $class->prepare(@arguments);
1281 $c->{stats} = $stats;
1283 return $c->finalize;
1286 if ( $class->debug ) {
1287 my $start = [gettimeofday];
1288 $status = &$handler;
1289 my $elapsed = tv_interval $start;
1290 $elapsed = sprintf '%f', $elapsed;
1291 my $av = sprintf '%.3f',
1292 ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
1293 my $t = Text::SimpleTable->new( [ 64, 'Action' ], [ 9, 'Time' ] );
1298 my $stat = $action->getNodeValue;
1299 $t->row( ( q{ } x $action->getDepth ) . $stat->{action},
1300 $stat->{elapsed} || '??' );
1305 "Request took ${elapsed}s ($av/s)\n" . $t->draw );
1307 else { $status = &$handler }
1311 if ( my $error = $@ ) {
1313 $class->log->error(qq/Caught exception in engine "$error"/);
1317 $class->log->_flush() if $class->log->can('_flush');
1321 =head2 $c->prepare( @arguments )
1323 Creates a Catalyst context from an engine-specific request (Apache, CGI,
1329 my ( $class, @arguments ) = @_;
1331 $class->context_class( ref $class || $class ) unless $class->context_class;
1332 my $c = $class->context_class->new(
1336 request => $class->request_class->new(
1339 body_parameters => {},
1341 headers => HTTP::Headers->new,
1343 query_parameters => {},
1349 response => $class->response_class->new(
1353 headers => HTTP::Headers->new(),
1362 # For on-demand data
1363 $c->request->{_context} = $c;
1364 $c->response->{_context} = $c;
1365 weaken( $c->request->{_context} );
1366 weaken( $c->response->{_context} );
1369 my $secs = time - $START || 1;
1370 my $av = sprintf '%.3f', $COUNT / $secs;
1371 $c->log->debug('**********************************');
1372 $c->log->debug("* Request $COUNT ($av/s) [$$]");
1373 $c->log->debug('**********************************');
1374 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
1377 $c->prepare_request(@arguments);
1378 $c->prepare_connection;
1379 $c->prepare_query_parameters;
1380 $c->prepare_headers;
1381 $c->prepare_cookies;
1385 $c->prepare_body unless $c->config->{parse_on_demand};
1387 my $method = $c->req->method || '';
1388 my $path = $c->req->path || '';
1389 my $address = $c->req->address || '';
1391 $c->log->debug(qq/"$method" request for "$path" from "$address"/)
1399 =head2 $c->prepare_action
1405 sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
1407 =head2 $c->prepare_body
1409 Prepares message body.
1416 # Do we run for the first time?
1417 return if defined $c->request->{_body};
1419 # Initialize on-demand data
1420 $c->engine->prepare_body( $c, @_ );
1421 $c->prepare_parameters;
1422 $c->prepare_uploads;
1424 if ( $c->debug && keys %{ $c->req->body_parameters } ) {
1425 my $t = Text::SimpleTable->new( [ 37, 'Key' ], [ 36, 'Value' ] );
1426 for my $key ( sort keys %{ $c->req->body_parameters } ) {
1427 my $param = $c->req->body_parameters->{$key};
1428 my $value = defined($param) ? $param : '';
1430 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1432 $c->log->debug( "Body Parameters are:\n" . $t->draw );
1436 =head2 $c->prepare_body_chunk( $chunk )
1438 Prepares a chunk of data before sending it to L<HTTP::Body>.
1442 sub prepare_body_chunk {
1444 $c->engine->prepare_body_chunk( $c, @_ );
1447 =head2 $c->prepare_body_parameters
1449 Prepares body parameters.
1453 sub prepare_body_parameters {
1455 $c->engine->prepare_body_parameters( $c, @_ );
1458 =head2 $c->prepare_connection
1460 Prepares connection.
1464 sub prepare_connection {
1466 $c->engine->prepare_connection( $c, @_ );
1469 =head2 $c->prepare_cookies
1475 sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
1477 =head2 $c->prepare_headers
1483 sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
1485 =head2 $c->prepare_parameters
1487 Prepares parameters.
1491 sub prepare_parameters {
1493 $c->prepare_body_parameters;
1494 $c->engine->prepare_parameters( $c, @_ );
1497 =head2 $c->prepare_path
1499 Prepares path and base.
1503 sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
1505 =head2 $c->prepare_query_parameters
1507 Prepares query parameters.
1511 sub prepare_query_parameters {
1514 $c->engine->prepare_query_parameters( $c, @_ );
1516 if ( $c->debug && keys %{ $c->request->query_parameters } ) {
1517 my $t = Text::SimpleTable->new( [ 37, 'Key' ], [ 36, 'Value' ] );
1518 for my $key ( sort keys %{ $c->req->query_parameters } ) {
1519 my $param = $c->req->query_parameters->{$key};
1520 my $value = defined($param) ? $param : '';
1522 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1524 $c->log->debug( "Query Parameters are:\n" . $t->draw );
1528 =head2 $c->prepare_read
1530 Prepares the input for reading.
1534 sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
1536 =head2 $c->prepare_request
1538 Prepares the engine request.
1542 sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
1544 =head2 $c->prepare_uploads
1550 sub prepare_uploads {
1553 $c->engine->prepare_uploads( $c, @_ );
1555 if ( $c->debug && keys %{ $c->request->uploads } ) {
1556 my $t = Text::SimpleTable->new(
1562 for my $key ( sort keys %{ $c->request->uploads } ) {
1563 my $upload = $c->request->uploads->{$key};
1564 for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
1565 $t->row( $key, $u->filename, $u->type, $u->size );
1568 $c->log->debug( "File Uploads are:\n" . $t->draw );
1572 =head2 $c->prepare_write
1574 Prepares the output for writing.
1578 sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
1580 =head2 $c->request_class
1582 Returns or sets the request class.
1584 =head2 $c->response_class
1586 Returns or sets the response class.
1588 =head2 $c->read( [$maxlength] )
1590 Reads a chunk of data from the request body. This method is designed to
1591 be used in a while loop, reading C<$maxlength> bytes on every call.
1592 C<$maxlength> defaults to the size of the request if not specified.
1594 You have to set C<MyApp-E<gt>config-E<gt>{parse_on_demand}> to use this
1599 sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
1607 sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
1609 =head2 $c->set_action( $action, $code, $namespace, $attrs )
1611 Sets an action in a given namespace.
1615 sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
1617 =head2 $c->setup_actions($component)
1619 Sets up actions for a component.
1623 sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
1625 =head2 $c->setup_components
1631 sub setup_components {
1634 my $callback = sub {
1635 my ( $component, $context ) = @_;
1637 unless ( $component->can('COMPONENT') ) {
1641 my $suffix = Catalyst::Utils::class2classsuffix($component);
1642 my $config = $class->config->{$suffix} || {};
1646 eval { $instance = $component->COMPONENT( $context, $config ); };
1648 if ( my $error = $@ ) {
1652 Catalyst::Exception->throw( message =>
1653 qq/Couldn't instantiate component "$component", "$error"/ );
1656 Catalyst::Exception->throw( message =>
1657 qq/Couldn't instantiate component "$component", "COMPONENT() didn't return a object"/
1659 unless ref $instance;
1663 eval "package $class;\n" . q!Module::Pluggable::Fast->import(
1664 name => '_catalyst_components',
1666 "$class\::Controller", "$class\::C",
1667 "$class\::Model", "$class\::M",
1668 "$class\::View", "$class\::V"
1670 callback => $callback
1674 if ( my $error = $@ ) {
1678 Catalyst::Exception->throw(
1679 message => qq/Couldn't load components "$error"/ );
1682 for my $component ( $class->_catalyst_components($class) ) {
1683 $class->components->{ ref $component || $component } = $component;
1687 =head2 $c->setup_dispatcher
1693 sub setup_dispatcher {
1694 my ( $class, $dispatcher ) = @_;
1697 $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
1700 if ( $ENV{CATALYST_DISPATCHER} ) {
1701 $dispatcher = 'Catalyst::Dispatcher::' . $ENV{CATALYST_DISPATCHER};
1704 if ( $ENV{ uc($class) . '_DISPATCHER' } ) {
1706 'Catalyst::Dispatcher::' . $ENV{ uc($class) . '_DISPATCHER' };
1709 unless ($dispatcher) {
1710 $dispatcher = $class->dispatcher_class;
1713 $dispatcher->require;
1716 Catalyst::Exception->throw(
1717 message => qq/Couldn't load dispatcher "$dispatcher", "$@"/ );
1720 # dispatcher instance
1721 $class->dispatcher( $dispatcher->new );
1724 =head2 $c->setup_engine
1731 my ( $class, $engine ) = @_;
1734 $engine = 'Catalyst::Engine::' . $engine;
1737 if ( $ENV{CATALYST_ENGINE} ) {
1738 $engine = 'Catalyst::Engine::' . $ENV{CATALYST_ENGINE};
1741 if ( $ENV{ uc($class) . '_ENGINE' } ) {
1742 $engine = 'Catalyst::Engine::' . $ENV{ uc($class) . '_ENGINE' };
1745 if ( $ENV{MOD_PERL} ) {
1747 # create the apache method
1750 *{"$class\::apache"} = sub { shift->engine->apache };
1753 my ( $software, $version ) =
1754 $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
1757 $version =~ s/(\.[^.]+)\./$1/g;
1759 if ( $software eq 'mod_perl' ) {
1763 if ( $version >= 1.99922 ) {
1764 $engine = 'Catalyst::Engine::Apache2::MP20';
1767 elsif ( $version >= 1.9901 ) {
1768 $engine = 'Catalyst::Engine::Apache2::MP19';
1771 elsif ( $version >= 1.24 ) {
1772 $engine = 'Catalyst::Engine::Apache::MP13';
1776 Catalyst::Exception->throw( message =>
1777 qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
1782 # install the correct mod_perl handler
1783 if ( $version >= 1.9901 ) {
1784 *handler = sub : method {
1785 shift->handle_request(@_);
1789 *handler = sub ($$) { shift->handle_request(@_) };
1794 elsif ( $software eq 'Zeus-Perl' ) {
1795 $engine = 'Catalyst::Engine::Zeus';
1799 Catalyst::Exception->throw(
1800 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
1805 $engine = $class->engine_class;
1811 Catalyst::Exception->throw( message =>
1812 qq/Couldn't load engine "$engine" (maybe you forgot to install it?), "$@"/
1816 # check for old engines that are no longer compatible
1818 if ( $engine->isa('Catalyst::Engine::Apache')
1819 && !Catalyst::Engine::Apache->VERSION )
1824 elsif ( $engine->isa('Catalyst::Engine::Server::Base')
1825 && Catalyst::Engine::Server->VERSION le '0.02' )
1830 elsif ($engine->isa('Catalyst::Engine::HTTP::POE')
1831 && $engine->VERSION eq '0.01' )
1836 elsif ($engine->isa('Catalyst::Engine::Zeus')
1837 && $engine->VERSION eq '0.01' )
1843 Catalyst::Exception->throw( message =>
1844 qq/Engine "$engine" is not supported by this version of Catalyst/
1849 $class->engine( $engine->new );
1852 =head2 $c->setup_home
1854 Sets up the home directory.
1859 my ( $class, $home ) = @_;
1861 if ( $ENV{CATALYST_HOME} ) {
1862 $home = $ENV{CATALYST_HOME};
1865 if ( $ENV{ uc($class) . '_HOME' } ) {
1866 $home = $ENV{ uc($class) . '_HOME' };
1870 $home = Catalyst::Utils::home($class);
1874 $class->config->{home} ||= $home;
1875 $class->config->{root} ||= dir($home)->subdir('root');
1879 =head2 $c->setup_log
1886 my ( $class, $debug ) = @_;
1888 unless ( $class->log ) {
1889 $class->log( Catalyst::Log->new );
1892 my $app_flag = Catalyst::Utils::class2env($class) . '_DEBUG';
1895 ( defined( $ENV{CATALYST_DEBUG} ) || defined( $ENV{$app_flag} ) )
1896 ? ( $ENV{CATALYST_DEBUG} || $ENV{$app_flag} )
1901 *{"$class\::debug"} = sub { 1 };
1902 $class->log->debug('Debug messages enabled');
1906 =head2 $c->setup_plugins
1912 =head2 $c->registered_plugins
1914 Returns a sorted list of the plugins which have either been stated in the
1915 import list or which have been added via C<< MyApp->plugin(@args); >>.
1917 If passed a given plugin name, it will report a boolean value indicating
1918 whether or not that plugin is loaded. A fully qualified name is required if
1919 the plugin name does not begin with C<Catalyst::Plugin::>.
1921 if ($c->registered_plugins('Some::Plugin')) {
1929 sub registered_plugins {
1931 return sort keys %{$proto->_plugins} unless @_;
1933 return 1 if exists $proto->_plugins->{$plugin};
1934 return exists $proto->_plugins->{"Catalyst::Plugin::$plugin"};
1937 sub _register_plugin {
1938 my ( $proto, $plugin, $instant ) = @_;
1939 my $class = ref $proto || $proto;
1943 if ( my $error = $@ ) {
1944 my $type = $instant ? "instant " : '';
1945 Catalyst::Exception->throw(
1946 message => qq/Couldn't load ${type}plugin "$plugin", $error/ );
1949 $proto->_plugins->{$plugin} = 1;
1952 unshift @{"$class\::ISA"}, $plugin;
1958 my ( $class, $plugins ) = @_;
1960 $class->_plugins( {} ) unless $class->_plugins;
1962 for my $plugin ( reverse @$plugins ) {
1964 unless ( $plugin =~ s/\A\+// ) {
1965 $plugin = "Catalyst::Plugin::$plugin";
1968 $class->_register_plugin($plugin);
1975 Returns an arrayref of the internal execution stack (actions that are currently
1978 =head2 $c->write( $data )
1980 Writes $data to the output stream. When using this method directly, you
1981 will need to manually set the C<Content-Length> header to the length of
1982 your output data, if known.
1989 # Finalize headers if someone manually writes output
1990 $c->finalize_headers;
1992 return $c->engine->write( $c, @_ );
1997 Returns the Catalyst version number. Mostly useful for "powered by"
1998 messages in template systems.
2002 sub version { return $Catalyst::VERSION }
2004 =head1 INTERNAL ACTIONS
2006 Catalyst uses internal actions like C<_DISPATCH>, C<_BEGIN>, C<_AUTO>,
2007 C<_ACTION>, and C<_END>. These are by default not shown in the private
2008 action table, but you can make them visible with a config parameter.
2010 MyApp->config->{show_internal_actions} = 1;
2012 =head1 CASE SENSITIVITY
2014 By default Catalyst is not case sensitive, so C<MyApp::C::FOO::Bar> is
2015 mapped to C</foo/bar>. You can activate case sensitivity with a config
2018 MyApp->config->{case_sensitive} = 1;
2020 This causes C<MyApp::C::Foo::Bar> to map to C</Foo/Bar>.
2022 =head1 ON-DEMAND PARSER
2024 The request body is usually parsed at the beginning of a request,
2025 but if you want to handle input yourself or speed things up a bit,
2026 you can enable on-demand parsing with a config parameter.
2028 MyApp->config->{parse_on_demand} = 1;
2030 =head1 PROXY SUPPORT
2032 Many production servers operate using the common double-server approach,
2033 with a lightweight frontend web server passing requests to a larger
2034 backend server. An application running on the backend server must deal
2035 with two problems: the remote user always appears to be C<127.0.0.1> and
2036 the server's hostname will appear to be C<localhost> regardless of the
2037 virtual host that the user connected through.
2039 Catalyst will automatically detect this situation when you are running
2040 the frontend and backend servers on the same machine. The following
2041 changes are made to the request.
2043 $c->req->address is set to the user's real IP address, as read from
2044 the HTTP X-Forwarded-For header.
2046 The host value for $c->req->base and $c->req->uri is set to the real
2047 host, as read from the HTTP X-Forwarded-Host header.
2049 Obviously, your web server must support these headers for this to work.
2051 In a more complex server farm environment where you may have your
2052 frontend proxy server(s) on different machines, you will need to set a
2053 configuration option to tell Catalyst to read the proxied data from the
2056 MyApp->config->{using_frontend_proxy} = 1;
2058 If you do not wish to use the proxy support at all, you may set:
2060 MyApp->config->{ignore_frontend_proxy} = 1;
2062 =head1 THREAD SAFETY
2064 Catalyst has been tested under Apache 2's threading mpm_worker, mpm_winnt,
2065 and the standalone forking HTTP server on Windows. We believe the Catalyst
2066 core to be thread-safe.
2068 If you plan to operate in a threaded environment, remember that all other
2069 modules you are using must also be thread-safe. Some modules, most notably
2070 L<DBD::SQLite>, are not thread-safe.
2076 Join #catalyst on irc.perl.org.
2080 http://lists.rawmode.org/mailman/listinfo/catalyst
2081 http://lists.rawmode.org/mailman/listinfo/catalyst-dev
2085 http://catalyst.perl.org
2089 http://dev.catalyst.perl.org
2093 =head2 L<Task::Catalyst> - All you need to start with Catalyst
2095 =head2 L<Catalyst::Manual> - The Catalyst Manual
2097 =head2 L<Catalyst::Component>, L<Catalyst::Base> - Base classes for components
2099 =head2 L<Catalyst::Engine> - Core engine
2101 =head2 L<Catalyst::Log> - Log class.
2103 =head2 L<Catalyst::Request> - Request object
2105 =head2 L<Catalyst::Response> - Response object
2107 =head2 L<Catalyst::Test> - The test suite.
2179 Sebastian Riedel, C<sri@oook.de>
2183 This library is free software, you can redistribute it and/or modify it under
2184 the same terms as Perl itself.