4 use base 'Catalyst::Base';
6 use UNIVERSAL::require;
7 use Catalyst::Exception;
10 use Catalyst::Request::Upload;
11 use Catalyst::Response;
15 use Text::SimpleTable;
17 use Time::HiRes qw/gettimeofday tv_interval/;
19 use Scalar::Util qw/weaken/;
20 use Tree::Simple qw/use_weak_refs/;
21 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 = 25;
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.62';
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;
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.
249 $c->forward('index');
250 $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
251 $c->forward('MyApp::View::TT');
255 sub forward { my $c = shift; $c->dispatcher->forward( $c, @_ ) }
257 =head2 $c->detach( $action [, \@arguments ] )
259 =head2 $c->detach( $class, $method, [, \@arguments ] )
261 The same as C<forward>, but doesn't return.
265 sub detach { my $c = shift; $c->dispatcher->detach( $c, @_ ) }
269 =head2 $c->error($error, ...)
271 =head2 $c->error($arrayref)
273 Returns an arrayref containing error messages. If Catalyst encounters an
274 error while processing a request, it stores the error in $c->error. This
275 method should not be used to store non-fatal error messages.
277 my @error = @{ $c->error };
281 $c->error('Something bad happened');
283 Clear errors. You probably don't want to clear the errors unless you are
284 implementing a custom error screen.
293 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
294 push @{ $c->{error} }, @$error;
296 elsif ( defined $_[0] ) { $c->{error} = undef }
297 return $c->{error} || [];
304 Returns the current L<Catalyst::Response> object.
308 Returns a hashref to the stash, which may be used to store data and pass
309 it between components during a request. You can also set hash keys by
310 passing arguments. The stash is automatically sent to the view. The
311 stash is cleared at the end of a request; it cannot be used for
314 $c->stash->{foo} = $bar;
315 $c->stash( { moose => 'majestic', qux => 0 } );
316 $c->stash( bar => 1, gorch => 2 ); # equivalent to passing a hashref
318 # stash is automatically passed to the view for use in a template
319 $c->forward( 'MyApp::V::TT' );
326 my $stash = @_ > 1 ? {@_} : $_[0];
327 while ( my ( $key, $val ) = each %$stash ) {
328 $c->{stash}->{$key} = $val;
336 Contains the return value of the last executed action.
338 =head2 Component Accessors
340 =head2 $c->comp($name)
342 =head2 $c->component($name)
344 Gets a component object by name. This method is no longer recommended,
345 unless you want to get a specific component by full
346 class. C<$c-E<gt>controller>, C<$c-E<gt>model>, and C<$c-E<gt>view>
347 should be used instead.
358 my $appclass = ref $c || $c;
361 $name, "${appclass}::${name}",
362 map { "${appclass}::${_}::${name}" }
363 qw/Model M Controller C View V/
366 foreach my $try (@names) {
368 if ( exists $c->components->{$try} ) {
370 my $comp = $c->components->{$try};
371 if ( ref $comp && $comp->can('ACCEPT_CONTEXT') ) {
372 return $comp->ACCEPT_CONTEXT($c);
374 else { return $comp }
378 foreach my $component ( keys %{ $c->components } ) {
380 $comp = $c->components->{$component} if $component =~ /$name/i;
382 if ( ref $comp && $comp->can('ACCEPT_CONTEXT') ) {
383 return $comp->ACCEPT_CONTEXT($c);
385 else { return $comp }
391 return sort keys %{ $c->components };
394 =head2 $c->controller($name)
396 Gets a L<Catalyst::Controller> instance by name.
398 $c->controller('Foo')->do_stuff;
403 my ( $c, $name ) = @_;
404 my $controller = $c->comp("Controller::$name");
405 return $controller if defined $controller;
406 return $c->comp("C::$name");
409 =head2 $c->model($name)
411 Gets a L<Catalyst::Model> instance by name.
413 $c->model('Foo')->do_stuff;
418 my ( $c, $name ) = @_;
419 my $model = $c->comp("Model::$name");
420 return $model if defined $model;
421 return $c->comp("M::$name");
424 =head2 $c->view($name)
426 Gets a L<Catalyst::View> instance by name.
428 $c->view('Foo')->do_stuff;
433 my ( $c, $name ) = @_;
434 my $view = $c->comp("View::$name");
435 return $view if defined $view;
436 return $c->comp("V::$name");
439 =head2 Class data and helper classes
443 Returns or takes a hashref containing the application's configuration.
445 __PACKAGE__->config({ db => 'dsn:SQLite:foo.db' });
449 Overload to enable debug messages (same as -Debug option).
455 =head2 $c->dispatcher
457 Returns the dispatcher instance. Stringifies to class name. See
458 L<Catalyst::Dispatcher>.
462 Returns the engine instance. Stringifies to the class name. See
467 Returns the logging object instance. Unless it is already set, Catalyst
468 sets this up with a L<Catalyst::Log> object. To use your own log class:
470 $c->log( MyLogger->new );
471 $c->log->info( 'Now logging with my own logger!' );
473 Your log class should implement the methods described in the
474 L<Catalyst::Log> man page.
478 =head2 Utility methods
480 =head2 $c->path_to(@path)
482 Merges C<@path> with C<$c-E<gt>config-E<gt>{home}> and returns a
483 L<Path::Class> object.
487 $c->path_to( 'db', 'sqlite.db' );
492 my ( $c, @path ) = @_;
493 my $path = dir( $c->config->{home}, @path );
494 if ( -d $path ) { return $path }
495 else { return file( $c->config->{home}, @path ) }
498 =head2 $c->plugin( $name, $class, @args )
500 Helper method for plugins. It creates a classdata accessor/mutator and
501 loads and instantiates the given class.
503 MyApp->plugin( 'prototype', 'HTML::Prototype' );
505 $c->prototype->define_javascript_functions;
510 my ( $class, $name, $plugin, @args ) = @_;
513 if ( my $error = $UNIVERSAL::require::ERROR ) {
514 Catalyst::Exception->throw(
515 message => qq/Couldn't load instant plugin "$plugin", "$error"/ );
518 eval { $plugin->import };
519 $class->mk_classdata($name);
521 eval { $obj = $plugin->new(@args) };
524 Catalyst::Exception->throw( message =>
525 qq/Couldn't instantiate instant plugin "$plugin", "$@"/ );
529 $class->log->debug(qq/Initialized instant plugin "$plugin" as "$name"/)
535 Initializes the dispatcher and engine, loads any plugins, and loads the
536 model, view, and controller components. You may also specify an array
537 of plugins to load here, if you choose to not load them in the C<use
541 MyApp->setup( qw/-Debug/ );
546 my ( $class, @arguments ) = @_;
548 unless ( $class->isa('Catalyst') ) {
550 Catalyst::Exception->throw(
551 message => qq/'$class' does not inherit from Catalyst/ );
554 if ( $class->arguments ) {
555 @arguments = ( @arguments, @{ $class->arguments } );
561 foreach (@arguments) {
565 ( $flags->{log} ) ? 'debug,' . $flags->{log} : 'debug';
567 elsif (/^-(\w+)=?(.*)$/) {
568 $flags->{ lc $1 } = $2;
571 push @{ $flags->{plugins} }, $_;
575 $class->setup_home( delete $flags->{home} );
577 # YAML config support
580 Catalyst::Utils::appprefix( ref $class || $class ) . '.yml' );
582 $conf = YAML::LoadFile($confpath) if -f $confpath;
583 my $oldconf = $class->config;
584 $class->config( { %$oldconf, %$conf } );
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.pod">Catalyst::Manual</a></code></pre>
818 <h2>What to do next?</h2>
819 <p>Next it's time to write an actual application. Use the
820 helper scripts to generate <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AController%3A%3A&mode=all">controllers</a>,
821 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AModel%3A%3A&mode=all">models</a>, and
822 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AView%3A%3A&mode=all">views</a>;
823 they can save you a lot of work.</p>
824 <pre><code>script/${prefix}_create.pl -help</code></pre>
825 <p>Also, be sure to check out the vast and growing
826 collection of <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3APlugin%3A%3A&mode=all">plugins for Catalyst on CPAN</a>;
827 you are likely to find what you need there.
831 <p>Catalyst has a very active community. Here are the main places to
832 get in touch with us.</p>
835 <a href="http://dev.catalyst.perl.org">Wiki</a>
838 <a href="http://lists.rawmode.org/mailman/listinfo/catalyst">Mailing-List</a>
841 <a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
844 <h2>In conclusion</h2>
845 <p>The Catalyst team hopes you will enjoy using Catalyst as much
846 as we enjoyed making it. Please contact us if you have ideas
847 for improvement or other feedback.</p>
855 =head1 INTERNAL METHODS
857 These methods are not meant to be used by end users.
859 =head2 $c->components
861 Returns a hash of components.
863 =head2 $c->context_class
865 Returns or sets the context class.
869 Returns a hashref containing coderefs and execution counts (needed for
870 deep recursion detection).
874 Returns the number of actions on the current internal execution stack.
878 Dispatches a request to actions.
882 sub dispatch { my $c = shift; $c->dispatcher->dispatch( $c, @_ ) }
884 =head2 $c->dispatcher_class
886 Returns or sets the dispatcher class.
888 =head2 $c->dump_these
890 Returns a list of 2-element array references (name, structure) pairs
891 that will be dumped on the error page in debug mode.
897 [ Request => $c->req ], [ Response => $c->res ], [ Stash => $c->stash ],;
900 =head2 $c->engine_class
902 Returns or sets the engine class.
904 =head2 $c->execute( $class, $coderef )
906 Execute a coderef in given class and catch exceptions. Errors are available
912 my ( $c, $class, $code ) = @_;
913 $class = $c->components->{$class} || $class;
917 my $action = "$code";
918 $action = "/$action" unless $action =~ /\-\>/;
919 $c->counter->{"$code"}++;
921 if ( $c->counter->{"$code"} > $RECURSION ) {
922 my $error = qq/Deep recursion detected in "$action"/;
923 $c->log->error($error);
929 # determine if the call was the result of a forward
930 my $callsub_index = ( caller(0) )[0]->isa('Catalyst::Action') ? 2 : 1;
931 if ( ( caller($callsub_index) )[3] =~ /^NEXT/ ) {
933 # work around NEXT if execute was extended by a plugin
936 my $callsub = ( caller($callsub_index) )[3];
938 $action = "-> $action" if $callsub =~ /forward$/;
940 my $node = Tree::Simple->new(
943 elapsed => undef, # to be filled in later
946 $node->setUID( "$code" . $c->counter->{"$code"} );
948 unless ( ( $code->name =~ /^_.*/ )
949 && ( !$c->config->{show_internal_actions} ) )
952 # is this a root-level call or a forwarded call?
953 if ( $callsub =~ /forward$/ ) {
955 # forward, locate the caller
956 if ( my $parent = $c->stack->[-1] ) {
957 my $visitor = Tree::Simple::Visitor::FindByUID->new;
958 $visitor->searchForUID(
959 "$parent" . $c->counter->{"$parent"} );
960 $c->{stats}->accept($visitor);
961 if ( my $result = $visitor->getResult ) {
962 $result->addChild($node);
967 # forward with no caller may come from a plugin
968 $c->{stats}->addChild($node);
974 $c->{stats}->addChild($node);
979 push( @{ $c->stack }, $code );
982 $start = [gettimeofday] if $c->debug;
983 eval { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) };
984 $elapsed = tv_interval($start) if $c->debug;
987 unless ( ( $code->name =~ /^_.*/ )
988 && ( !$c->config->{show_internal_actions} ) )
991 # FindByUID uses an internal die, so we save the existing error
994 # locate the node in the tree and update the elapsed time
995 my $visitor = Tree::Simple::Visitor::FindByUID->new;
996 $visitor->searchForUID( "$code" . $c->counter->{"$code"} );
997 $c->{stats}->accept($visitor);
998 if ( my $result = $visitor->getResult ) {
999 my $value = $result->getNodeValue;
1000 $value->{elapsed} = sprintf( '%fs', $elapsed );
1001 $result->setNodeValue($value);
1005 $@ = $error || undef;
1008 my $last = ${ $c->stack }[-1];
1009 pop( @{ $c->stack } );
1011 if ( my $error = $@ ) {
1012 if ( $error eq $DETACH ) { die $DETACH if $c->depth > 1 }
1014 unless ( ref $error ) {
1016 my $class = $last->class;
1017 my $name = $last->name;
1018 $error = qq/Caught exception in $class->$name "$error"/;
1029 Finalizes the request.
1036 for my $error ( @{ $c->error } ) {
1037 $c->log->error($error);
1040 $c->finalize_uploads;
1043 if ( $#{ $c->error } >= 0 ) {
1047 $c->finalize_headers;
1050 if ( $c->request->method eq 'HEAD' ) {
1051 $c->response->body('');
1056 return $c->response->status;
1059 =head2 $c->finalize_body
1065 sub finalize_body { my $c = shift; $c->engine->finalize_body( $c, @_ ) }
1067 =head2 $c->finalize_cookies
1073 sub finalize_cookies { my $c = shift; $c->engine->finalize_cookies( $c, @_ ) }
1075 =head2 $c->finalize_error
1081 sub finalize_error { my $c = shift; $c->engine->finalize_error( $c, @_ ) }
1083 =head2 $c->finalize_headers
1089 sub finalize_headers {
1092 # Check if we already finalized headers
1093 return if $c->response->{_finalized_headers};
1096 if ( my $location = $c->response->redirect ) {
1097 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
1098 $c->response->header( Location => $location );
1102 if ( $c->response->body && !$c->response->content_length ) {
1104 # get the length from a filehandle
1105 if ( ref $c->response->body && $c->response->body->can('read') ) {
1106 if ( my $stat = stat $c->response->body ) {
1107 $c->response->content_length( $stat->size );
1110 $c->log->warn('Serving filehandle without a content-length');
1114 $c->response->content_length( bytes::length( $c->response->body ) );
1119 if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
1120 $c->response->headers->remove_header("Content-Length");
1121 $c->response->body('');
1124 $c->finalize_cookies;
1126 $c->engine->finalize_headers( $c, @_ );
1129 $c->response->{_finalized_headers} = 1;
1132 =head2 $c->finalize_output
1134 An alias for finalize_body.
1136 =head2 $c->finalize_read
1138 Finalizes the input after reading is complete.
1142 sub finalize_read { my $c = shift; $c->engine->finalize_read( $c, @_ ) }
1144 =head2 $c->finalize_uploads
1146 Finalizes uploads. Cleans up any temporary files.
1150 sub finalize_uploads { my $c = shift; $c->engine->finalize_uploads( $c, @_ ) }
1152 =head2 $c->get_action( $action, $namespace )
1154 Gets an action in a given namespace.
1158 sub get_action { my $c = shift; $c->dispatcher->get_action(@_) }
1160 =head2 $c->get_actions( $action, $namespace )
1162 Gets all actions of a given name in a namespace and all parent
1167 sub get_actions { my $c = shift; $c->dispatcher->get_actions( $c, @_ ) }
1169 =head2 handle_request( $class, @arguments )
1171 Called to handle each HTTP request.
1175 sub handle_request {
1176 my ( $class, @arguments ) = @_;
1178 # Always expect worst case!
1181 my $stats = ( $class->debug ) ? Tree::Simple->new: q{};
1184 my $c = $class->prepare(@arguments);
1185 $c->{stats} = $stats;
1187 return $c->finalize;
1190 if ( $class->debug ) {
1191 my $start = [gettimeofday];
1192 $status = &$handler;
1193 my $elapsed = tv_interval $start;
1194 $elapsed = sprintf '%f', $elapsed;
1195 my $av = sprintf '%.3f',
1196 ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
1197 my $t = Text::SimpleTable->new( [ 64, 'Action' ], [ 9, 'Time' ] );
1202 my $stat = $action->getNodeValue;
1203 $t->row( ( q{ } x $action->getDepth ) . $stat->{action},
1204 $stat->{elapsed} || '??' );
1209 "Request took ${elapsed}s ($av/s)\n" . $t->draw );
1211 else { $status = &$handler }
1215 if ( my $error = $@ ) {
1217 $class->log->error(qq/Caught exception in engine "$error"/);
1221 $class->log->_flush() if $class->log->can('_flush');
1225 =head2 $c->prepare( @arguments )
1227 Creates a Catalyst context from an engine-specific request (Apache, CGI,
1233 my ( $class, @arguments ) = @_;
1235 $class->context_class( ref $class || $class ) unless $class->context_class;
1236 my $c = $class->context_class->new(
1240 request => $class->request_class->new(
1243 body_parameters => {},
1245 headers => HTTP::Headers->new,
1247 query_parameters => {},
1253 response => $class->response_class->new(
1257 headers => HTTP::Headers->new(),
1266 # For on-demand data
1267 $c->request->{_context} = $c;
1268 $c->response->{_context} = $c;
1269 weaken( $c->request->{_context} );
1270 weaken( $c->response->{_context} );
1273 my $secs = time - $START || 1;
1274 my $av = sprintf '%.3f', $COUNT / $secs;
1275 $c->log->debug('**********************************');
1276 $c->log->debug("* Request $COUNT ($av/s) [$$]");
1277 $c->log->debug('**********************************');
1278 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
1281 $c->prepare_request(@arguments);
1282 $c->prepare_connection;
1283 $c->prepare_query_parameters;
1284 $c->prepare_headers;
1285 $c->prepare_cookies;
1289 $c->prepare_body unless $c->config->{parse_on_demand};
1291 my $method = $c->req->method || '';
1292 my $path = $c->req->path || '';
1293 my $address = $c->req->address || '';
1295 $c->log->debug(qq/"$method" request for "$path" from "$address"/)
1303 =head2 $c->prepare_action
1309 sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
1311 =head2 $c->prepare_body
1313 Prepares message body.
1320 # Do we run for the first time?
1321 return if defined $c->request->{_body};
1323 # Initialize on-demand data
1324 $c->engine->prepare_body( $c, @_ );
1325 $c->prepare_parameters;
1326 $c->prepare_uploads;
1328 if ( $c->debug && keys %{ $c->req->body_parameters } ) {
1329 my $t = Text::SimpleTable->new( [ 37, 'Key' ], [ 36, 'Value' ] );
1330 for my $key ( sort keys %{ $c->req->body_parameters } ) {
1331 my $param = $c->req->body_parameters->{$key};
1332 my $value = defined($param) ? $param : '';
1334 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1336 $c->log->debug( "Body Parameters are:\n" . $t->draw );
1340 =head2 $c->prepare_body_chunk( $chunk )
1342 Prepares a chunk of data before sending it to L<HTTP::Body>.
1346 sub prepare_body_chunk {
1348 $c->engine->prepare_body_chunk( $c, @_ );
1351 =head2 $c->prepare_body_parameters
1353 Prepares body parameters.
1357 sub prepare_body_parameters {
1359 $c->engine->prepare_body_parameters( $c, @_ );
1362 =head2 $c->prepare_connection
1364 Prepares connection.
1368 sub prepare_connection {
1370 $c->engine->prepare_connection( $c, @_ );
1373 =head2 $c->prepare_cookies
1379 sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
1381 =head2 $c->prepare_headers
1387 sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
1389 =head2 $c->prepare_parameters
1391 Prepares parameters.
1395 sub prepare_parameters {
1397 $c->prepare_body_parameters;
1398 $c->engine->prepare_parameters( $c, @_ );
1401 =head2 $c->prepare_path
1403 Prepares path and base.
1407 sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
1409 =head2 $c->prepare_query_parameters
1411 Prepares query parameters.
1415 sub prepare_query_parameters {
1418 $c->engine->prepare_query_parameters( $c, @_ );
1420 if ( $c->debug && keys %{ $c->request->query_parameters } ) {
1421 my $t = Text::SimpleTable->new( [ 37, 'Key' ], [ 36, 'Value' ] );
1422 for my $key ( sort keys %{ $c->req->query_parameters } ) {
1423 my $param = $c->req->query_parameters->{$key};
1424 my $value = defined($param) ? $param : '';
1426 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1428 $c->log->debug( "Query Parameters are:\n" . $t->draw );
1432 =head2 $c->prepare_read
1434 Prepares the input for reading.
1438 sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
1440 =head2 $c->prepare_request
1442 Prepares the engine request.
1446 sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
1448 =head2 $c->prepare_uploads
1454 sub prepare_uploads {
1457 $c->engine->prepare_uploads( $c, @_ );
1459 if ( $c->debug && keys %{ $c->request->uploads } ) {
1460 my $t = Text::SimpleTable->new(
1466 for my $key ( sort keys %{ $c->request->uploads } ) {
1467 my $upload = $c->request->uploads->{$key};
1468 for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
1469 $t->row( $key, $u->filename, $u->type, $u->size );
1472 $c->log->debug( "File Uploads are:\n" . $t->draw );
1476 =head2 $c->prepare_write
1478 Prepares the output for writing.
1482 sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
1484 =head2 $c->request_class
1486 Returns or sets the request class.
1488 =head2 $c->response_class
1490 Returns or sets the response class.
1492 =head2 $c->read( [$maxlength] )
1494 Reads a chunk of data from the request body. This method is designed to
1495 be used in a while loop, reading C<$maxlength> bytes on every call.
1496 C<$maxlength> defaults to the size of the request if not specified.
1498 You have to set C<MyApp-E<gt>config-E<gt>{parse_on_demand}> to use this
1503 sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
1511 sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
1513 =head2 $c->set_action( $action, $code, $namespace, $attrs )
1515 Sets an action in a given namespace.
1519 sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
1521 =head2 $c->setup_actions($component)
1523 Sets up actions for a component.
1527 sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
1529 =head2 $c->setup_components
1535 sub setup_components {
1538 my $callback = sub {
1539 my ( $component, $context ) = @_;
1541 unless ( $component->isa('Catalyst::Component') ) {
1545 my $suffix = Catalyst::Utils::class2classsuffix($component);
1546 my $config = $class->config->{$suffix} || {};
1550 eval { $instance = $component->COMPONENT( $context, $config ); };
1552 if ( my $error = $@ ) {
1556 Catalyst::Exception->throw( message =>
1557 qq/Couldn't instantiate component "$component", "$error"/ );
1560 Catalyst::Exception->throw( message =>
1561 qq/Couldn't instantiate component "$component", "new() didn't return a object"/
1563 unless ref $instance;
1567 eval "package $class;\n" . q!Module::Pluggable::Fast->import(
1568 name => '_catalyst_components',
1570 "$class\::Controller", "$class\::C",
1571 "$class\::Model", "$class\::M",
1572 "$class\::View", "$class\::V"
1574 callback => $callback
1578 if ( my $error = $@ ) {
1582 Catalyst::Exception->throw(
1583 message => qq/Couldn't load components "$error"/ );
1586 for my $component ( $class->_catalyst_components($class) ) {
1587 $class->components->{ ref $component || $component } = $component;
1591 =head2 $c->setup_dispatcher
1597 sub setup_dispatcher {
1598 my ( $class, $dispatcher ) = @_;
1601 $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
1604 if ( $ENV{CATALYST_DISPATCHER} ) {
1605 $dispatcher = 'Catalyst::Dispatcher::' . $ENV{CATALYST_DISPATCHER};
1608 if ( $ENV{ uc($class) . '_DISPATCHER' } ) {
1610 'Catalyst::Dispatcher::' . $ENV{ uc($class) . '_DISPATCHER' };
1613 unless ($dispatcher) {
1614 $dispatcher = $class->dispatcher_class;
1617 $dispatcher->require;
1620 Catalyst::Exception->throw(
1621 message => qq/Couldn't load dispatcher "$dispatcher", "$@"/ );
1624 # dispatcher instance
1625 $class->dispatcher( $dispatcher->new );
1628 =head2 $c->setup_engine
1635 my ( $class, $engine ) = @_;
1638 $engine = 'Catalyst::Engine::' . $engine;
1641 if ( $ENV{CATALYST_ENGINE} ) {
1642 $engine = 'Catalyst::Engine::' . $ENV{CATALYST_ENGINE};
1645 if ( $ENV{ uc($class) . '_ENGINE' } ) {
1646 $engine = 'Catalyst::Engine::' . $ENV{ uc($class) . '_ENGINE' };
1649 if ( $ENV{MOD_PERL} ) {
1651 # create the apache method
1654 *{"$class\::apache"} = sub { shift->engine->apache };
1657 my ( $software, $version ) =
1658 $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
1661 $version =~ s/(\.[^.]+)\./$1/g;
1663 if ( $software eq 'mod_perl' ) {
1667 if ( $version >= 1.99922 ) {
1668 $engine = 'Catalyst::Engine::Apache2::MP20';
1671 elsif ( $version >= 1.9901 ) {
1672 $engine = 'Catalyst::Engine::Apache2::MP19';
1675 elsif ( $version >= 1.24 ) {
1676 $engine = 'Catalyst::Engine::Apache::MP13';
1680 Catalyst::Exception->throw( message =>
1681 qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
1686 # install the correct mod_perl handler
1687 if ( $version >= 1.9901 ) {
1688 *handler = sub : method {
1689 shift->handle_request(@_);
1693 *handler = sub ($$) { shift->handle_request(@_) };
1698 elsif ( $software eq 'Zeus-Perl' ) {
1699 $engine = 'Catalyst::Engine::Zeus';
1703 Catalyst::Exception->throw(
1704 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
1709 $engine = $class->engine_class;
1715 Catalyst::Exception->throw( message =>
1716 qq/Couldn't load engine "$engine" (maybe you forgot to install it?), "$@"/
1720 # check for old engines that are no longer compatible
1722 if ( $engine->isa('Catalyst::Engine::Apache')
1723 && !Catalyst::Engine::Apache->VERSION )
1728 elsif ( $engine->isa('Catalyst::Engine::Server::Base')
1729 && Catalyst::Engine::Server->VERSION le '0.02' )
1734 elsif ($engine->isa('Catalyst::Engine::HTTP::POE')
1735 && $engine->VERSION eq '0.01' )
1740 elsif ($engine->isa('Catalyst::Engine::Zeus')
1741 && $engine->VERSION eq '0.01' )
1747 Catalyst::Exception->throw( message =>
1748 qq/Engine "$engine" is not supported by this version of Catalyst/
1753 $class->engine( $engine->new );
1756 =head2 $c->setup_home
1758 Sets up the home directory.
1763 my ( $class, $home ) = @_;
1765 if ( $ENV{CATALYST_HOME} ) {
1766 $home = $ENV{CATALYST_HOME};
1769 if ( $ENV{ uc($class) . '_HOME' } ) {
1770 $home = $ENV{ uc($class) . '_HOME' };
1774 $home = Catalyst::Utils::home($class);
1778 $class->config->{home} ||= $home;
1779 $class->config->{root} ||= dir($home)->subdir('root');
1783 =head2 $c->setup_log
1790 my ( $class, $debug ) = @_;
1792 unless ( $class->log ) {
1793 $class->log( Catalyst::Log->new );
1796 my $app_flag = Catalyst::Utils::class2env($class) . '_DEBUG';
1799 ( defined( $ENV{CATALYST_DEBUG} ) || defined( $ENV{$app_flag} ) )
1800 ? ( $ENV{CATALYST_DEBUG} || $ENV{$app_flag} )
1805 *{"$class\::debug"} = sub { 1 };
1806 $class->log->debug('Debug messages enabled');
1810 =head2 $c->setup_plugins
1817 my ( $class, $plugins ) = @_;
1820 for my $plugin ( reverse @$plugins ) {
1822 $plugin = "Catalyst::Plugin::$plugin";
1827 Catalyst::Exception->throw(
1828 message => qq/Couldn't load plugin "$plugin", "$@"/ );
1833 unshift @{"$class\::ISA"}, $plugin;
1842 =head2 $c->write( $data )
1844 Writes $data to the output stream. When using this method directly, you
1845 will need to manually set the C<Content-Length> header to the length of
1846 your output data, if known.
1853 # Finalize headers if someone manually writes output
1854 $c->finalize_headers;
1856 return $c->engine->write( $c, @_ );
1861 Returns the Catalyst version number. Mostly useful for "powered by"
1862 messages in template systems.
1866 sub version { return $Catalyst::VERSION }
1868 =head1 INTERNAL ACTIONS
1870 Catalyst uses internal actions like C<_DISPATCH>, C<_BEGIN>, C<_AUTO>,
1871 C<_ACTION>, and C<_END>. These are by default not shown in the private
1872 action table, but you can make them visible with a config parameter.
1874 MyApp->config->{show_internal_actions} = 1;
1876 =head1 CASE SENSITIVITY
1878 By default Catalyst is not case sensitive, so C<MyApp::C::FOO::Bar> is
1879 mapped to C</foo/bar>. You can activate case sensitivity with a config
1882 MyApp->config->{case_sensitive} = 1;
1884 This causes C<MyApp::C::Foo::Bar> to map to C</Foo/Bar>.
1886 =head1 ON-DEMAND PARSER
1888 The request body is usually parsed at the beginning of a request,
1889 but if you want to handle input yourself or speed things up a bit,
1890 you can enable on-demand parsing with a config parameter.
1892 MyApp->config->{parse_on_demand} = 1;
1894 =head1 PROXY SUPPORT
1896 Many production servers operate using the common double-server approach,
1897 with a lightweight frontend web server passing requests to a larger
1898 backend server. An application running on the backend server must deal
1899 with two problems: the remote user always appears to be C<127.0.0.1> and
1900 the server's hostname will appear to be C<localhost> regardless of the
1901 virtual host that the user connected through.
1903 Catalyst will automatically detect this situation when you are running
1904 the frontend and backend servers on the same machine. The following
1905 changes are made to the request.
1907 $c->req->address is set to the user's real IP address, as read from
1908 the HTTP X-Forwarded-For header.
1910 The host value for $c->req->base and $c->req->uri is set to the real
1911 host, as read from the HTTP X-Forwarded-Host header.
1913 Obviously, your web server must support these headers for this to work.
1915 In a more complex server farm environment where you may have your
1916 frontend proxy server(s) on different machines, you will need to set a
1917 configuration option to tell Catalyst to read the proxied data from the
1920 MyApp->config->{using_frontend_proxy} = 1;
1922 If you do not wish to use the proxy support at all, you may set:
1924 MyApp->config->{ignore_frontend_proxy} = 1;
1926 =head1 THREAD SAFETY
1928 Catalyst has been tested under Apache 2's threading mpm_worker, mpm_winnt,
1929 and the standalone forking HTTP server on Windows. We believe the Catalyst
1930 core to be thread-safe.
1932 If you plan to operate in a threaded environment, remember that all other
1933 modules you are using must also be thread-safe. Some modules, most notably
1934 L<DBD::SQLite>, are not thread-safe.
1940 Join #catalyst on irc.perl.org.
1944 http://lists.rawmode.org/mailman/listinfo/catalyst
1945 http://lists.rawmode.org/mailman/listinfo/catalyst-dev
1949 http://catalyst.perl.org
1953 http://dev.catalyst.perl.org
1957 =head2 L<Task::Catalyst> - All you need to start with Catalyst
1959 =head2 L<Catalyst::Manual> - The Catalyst Manual
1961 =head2 L<Catalyst::Component>, L<Catalyst::Base> - Base classes for components
1963 =head2 L<Catalyst::Engine> - Core engine
1965 =head2 L<Catalyst::Log> - Log class.
1967 =head2 L<Catalyst::Request> - Request object
1969 =head2 L<Catalyst::Response> - Response object
1971 =head2 L<Catalyst::Test> - The test suite.
2041 Sebastian Riedel, C<sri@oook.de>
2045 This library is free software, you can redistribute it and/or modify it under
2046 the same terms as Perl itself.