4 use base 'Catalyst::Base';
6 use UNIVERSAL::require;
7 use Catalyst::Exception;
10 use Catalyst::Request::Upload;
11 use Catalyst::Response;
14 use Text::SimpleTable;
16 use Time::HiRes qw/gettimeofday tv_interval/;
18 use Scalar::Util qw/weaken/;
21 __PACKAGE__->mk_accessors(
22 qw/counter depth request response state action namespace/
25 attributes->import( __PACKAGE__, \&namespace, 'lvalue' );
32 # For backwards compatibility
33 *finalize_output = \&finalize_body;
38 our $RECURSION = 1000;
39 our $DETACH = "catalyst_detach\n";
41 require Module::Pluggable::Fast;
43 # Helper script generation
44 our $CATALYST_SCRIPT_GEN = 10;
46 __PACKAGE__->mk_classdata($_)
47 for qw/components arguments dispatcher engine log/;
49 our $VERSION = '5.49_03';
52 my ( $class, @arguments ) = @_;
54 # We have to limit $class to Catalyst to avoid pushing Catalyst upon every
56 return unless $class eq 'Catalyst';
58 my $caller = caller(0);
60 unless ( $caller->isa('Catalyst') ) {
62 push @{"$caller\::ISA"}, $class;
65 $caller->arguments( [@arguments] );
71 Catalyst - The Elegant MVC Web Application Framework
75 # use the helper to start a new application
79 # add models, views, controllers
80 script/myapp_create.pl model Something
81 script/myapp_create.pl view Stuff
82 script/myapp_create.pl controller Yada
85 script/myapp_server.pl
87 # command line interface
88 script/myapp_test.pl /yada
93 use Catalyst qw/My::Module My::OtherModule/;
95 use Catalyst '-Debug';
97 use Catalyst qw/-Debug -Engine=CGI/;
99 sub default : Private { $_[1]->res->output('Hello') } );
101 sub index : Path('/index.html') {
102 my ( $self, $c ) = @_;
103 $c->res->output('Hello');
107 sub product : Regex('^product[_]*(\d*).html$') {
108 my ( $self, $c ) = @_;
109 $c->stash->{template} = 'product.tt';
110 $c->stash->{product} = $c->req->snippets->[0];
113 See also L<Catalyst::Manual::Intro>
117 The key concept of Catalyst is DRY (Don't Repeat Yourself).
119 See L<Catalyst::Manual> for more documentation.
121 Catalyst plugins can be loaded by naming them as arguments to the "use Catalyst" statement.
122 Omit the C<Catalyst::Plugin::> prefix from the plugin name,
123 so C<Catalyst::Plugin::My::Module> becomes C<My::Module>.
125 use Catalyst 'My::Module';
127 Special flags like -Debug and -Engine can also be specified as arguments when
130 use Catalyst qw/-Debug My::Module/;
132 The position of plugins and flags in the chain is important, because they are
133 loaded in exactly the order that they appear.
135 The following flags are supported:
141 enables debug output, i.e.:
143 use Catalyst '-Debug';
145 this is equivalent to:
152 Force Catalyst to use a specific dispatcher.
156 Force Catalyst to use a specific engine.
157 Omit the C<Catalyst::Engine::> prefix of the engine name, i.e.:
159 use Catalyst '-Engine=CGI';
163 Force Catalyst to use a specific home directory.
177 Accessor for the current action
179 =item $c->comp($name)
181 =item $c->component($name)
183 Get a component object by name.
185 $c->comp('MyApp::Model::MyModel')->do_stuff;
196 my $appclass = ref $c || $c;
199 $name, "${appclass}::${name}",
200 map { "${appclass}::${_}::${name}" } qw/M V C/
203 foreach my $try (@names) {
205 if ( exists $c->components->{$try} ) {
207 return $c->components->{$try};
211 foreach my $component ( keys %{ $c->components } ) {
213 return $c->components->{$component} if $component =~ /$name/i;
218 return sort keys %{ $c->components };
223 Returns a hashref containing your applications settings.
227 =item $c->controller($name)
229 Get a L<Catalyst::Controller> instance by name.
231 $c->controller('Foo')->do_stuff;
236 my ( $c, $name ) = @_;
237 my $controller = $c->comp("Controller::$name");
238 return $controller if $controller;
239 return $c->comp("C::$name");
244 Overload to enable debug messages.
250 =item $c->detach( $command [, \@arguments ] )
252 Like C<forward> but doesn't return.
256 sub detach { my $c = shift; $c->dispatcher->detach( $c, @_ ) }
260 Contains the dispatcher instance.
261 Stringifies to class.
263 =item $c->forward( $command [, \@arguments ] )
265 Forward processing to a private action or a method from a class.
266 If you define a class without method it will default to process().
267 also takes an optional arrayref containing arguments to be passed
268 to the new function. $c->req->args will be reset upon returning
272 $c->forward('index');
273 $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
274 $c->forward('MyApp::View::TT');
278 sub forward { my $c = shift; $c->dispatcher->forward( $c, @_ ) }
280 =item $c->model($name)
282 Get a L<Catalyst::Model> instance by name.
284 $c->model('Foo')->do_stuff;
289 my ( $c, $name ) = @_;
290 my $model = $c->comp("Model::$name");
291 return $model if $model;
292 return $c->comp("M::$name");
297 Accessor to the namespace of the current action
299 =item $c->path_to(@path)
301 Merges C<@path> with $c->config->{home} and returns a L<Path::Class> object.
305 $c->path_to( 'db', 'sqlite.db' );
310 my ( $c, @path ) = @_;
311 my $path = dir( $c->config->{home}, @path );
312 if ( -d $path ) { return $path }
313 else { return file( $c->config->{home}, @path ) }
325 my ( $class, @arguments ) = @_;
327 unless ( $class->isa('Catalyst') ) {
329 Catalyst::Exception->throw(
330 message => qq/'$class' does not inherit from Catalyst/ );
333 if ( $class->arguments ) {
334 @arguments = ( @arguments, @{ $class->arguments } );
340 foreach (@arguments) {
344 ( $flags->{log} ) ? 'debug,' . $flags->{log} : 'debug';
346 elsif (/^-(\w+)=?(.*)$/) {
347 $flags->{ lc $1 } = $2;
350 push @{ $flags->{plugins} }, $_;
354 $class->setup_log( delete $flags->{log} );
355 $class->setup_plugins( delete $flags->{plugins} );
356 $class->setup_dispatcher( delete $flags->{dispatcher} );
357 $class->setup_engine( delete $flags->{engine} );
358 $class->setup_home( delete $flags->{home} );
360 for my $flag ( sort keys %{$flags} ) {
362 if ( my $code = $class->can( 'setup_' . $flag ) ) {
363 &$code( $class, delete $flags->{$flag} );
366 $class->log->warn(qq/Unknown flag "$flag"/);
370 $class->log->warn( "You are running an old helper script! "
371 . "Please update your scripts by regenerating the "
372 . "application and copying over the new scripts." )
373 if ( $ENV{CATALYST_SCRIPT_GEN}
374 && ( $ENV{CATALYST_SCRIPT_GEN} < $Catalyst::CATALYST_SCRIPT_GEN ) );
376 if ( $class->debug ) {
382 @plugins = grep { /^Catalyst::Plugin/ } @{"$class\::ISA"};
386 my $t = Text::SimpleTable->new(76);
387 $t->row($_) for @plugins;
388 $class->log->debug( "Loaded plugins:\n" . $t->draw );
391 my $dispatcher = $class->dispatcher;
392 my $engine = $class->engine;
393 my $home = $class->config->{home};
395 $class->log->debug(qq/Loaded dispatcher "$dispatcher"/);
396 $class->log->debug(qq/Loaded engine "$engine"/);
400 ? $class->log->debug(qq/Found home "$home"/)
401 : $class->log->debug(qq/Home "$home" doesn't exist/)
402 : $class->log->debug(q/Couldn't find home/);
407 no warnings qw/redefine/;
408 local *setup = sub { };
412 # Initialize our data structure
413 $class->components( {} );
415 $class->setup_components;
417 if ( $class->debug ) {
418 my $t = Text::SimpleTable->new( [ 37, 'Class' ], [ 36, 'Type' ] );
419 for my $comp ( sort keys %{ $class->components } ) {
420 my $type = ref $class->components->{$comp} ? 'instance' : 'class';
421 $t->row( $comp, $type );
423 $class->log->debug( "Loaded components:\n" . $t->draw )
424 if ( keys %{ $class->components } );
427 # Add our self to components, since we are also a component
428 $class->components->{$class} = $class;
430 $class->setup_actions;
432 if ( $class->debug ) {
433 my $name = $class->config->{name} || 'Application';
434 $class->log->info("$name powered by Catalyst $Catalyst::VERSION");
436 $class->log->_flush() if $class->log->can('_flush');
439 =item $c->uri_for($path,[@args])
441 Merges path with $c->request->base for absolute uri's and with
442 $c->request->match for relative uri's, then returns a normalized
443 L<URI> object. If any args are passed, they are added at the end
449 my ( $c, $path, @args ) = @_;
450 my $base = $c->request->base->clone;
451 my $basepath = $base->path;
452 $basepath =~ s/\/$//;
454 my $match = $c->request->match;
456 # massage match, empty if absolute path
458 $match .= '/' if $match;
460 $match = '' if $path =~ /^\//;
463 # join args with '/', or a blank string
464 my $args = ( scalar @args ? '/' . join( '/', @args ) : '' );
465 return URI->new_abs( URI->new_abs( "$path$args", "$basepath$match" ),
471 =item $c->error($error, ...)
473 =item $c->error($arrayref)
475 Returns an arrayref containing error messages.
477 my @error = @{ $c->error };
481 $c->error('Something bad happened');
492 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
493 push @{ $c->{error} }, @$error;
495 elsif ( defined $_[0] ) { $c->{error} = undef }
496 return $c->{error} || [];
501 Contains the engine instance.
502 Stringifies to the class.
506 Contains the logging object. Unless it is already set Catalyst sets this up with a
507 C<Catalyst::Log> object. To use your own log class:
509 $c->log( MyLogger->new );
510 $c->log->info("now logging with my own logger!");
512 Your log class should implement the methods described in the C<Catalyst::Log>
515 =item $c->plugin( $name, $class, @args )
517 Instant plugins for Catalyst.
518 Classdata accessor/mutator will be created, class loaded and instantiated.
520 MyApp->plugin( 'prototype', 'HTML::Prototype' );
522 $c->prototype->define_javascript_functions;
527 my ( $class, $name, $plugin, @args ) = @_;
530 if ( my $error = $UNIVERSAL::require::ERROR ) {
531 Catalyst::Exception->throw(
532 message => qq/Couldn't load instant plugin "$plugin", "$error"/ );
535 eval { $plugin->import };
536 $class->mk_classdata($name);
538 eval { $obj = $plugin->new(@args) };
541 Catalyst::Exception->throw( message =>
542 qq/Couldn't instantiate instant plugin "$plugin", "$@"/ );
546 $class->log->debug(qq/Initialized instant plugin "$plugin" as "$name"/)
554 Returns a C<Catalyst::Request> object.
562 Returns a C<Catalyst::Response> object.
568 Contains the return value of the last executed action.
572 Returns a hashref containing all your data.
574 print $c->stash->{foo};
576 Keys may be set in the stash by assigning to the hash reference, or by passing
577 either a single hash reference or a list of key/value pairs as arguments.
581 $c->stash->{foo} ||= 'yada';
582 $c->stash( { moose => 'majestic', qux => 0 } );
583 $c->stash( bar => 1, gorch => 2 );
590 my $stash = @_ > 1 ? {@_} : $_[0];
591 while ( my ( $key, $val ) = each %$stash ) {
592 $c->{stash}->{$key} = $val;
598 =item $c->view($name)
600 Get a L<Catalyst::View> instance by name.
602 $c->view('Foo')->do_stuff;
607 my ( $c, $name ) = @_;
608 my $view = $c->comp("View::$name");
609 return $view if $view;
610 return $c->comp("V::$name");
613 =item $c->welcome_message
615 Returns the Catalyst welcome HTML page.
619 sub welcome_message {
621 my $name = $c->config->{name};
622 my $logo = $c->uri_for('/static/images/catalyst_logo.png');
623 my $prefix = Catalyst::Utils::appprefix( ref $c );
624 $c->response->content_type('text/html; charset=utf-8');
626 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
627 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
628 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
630 <meta http-equiv="Content-Language" content="en" />
631 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
632 <title>$name on Catalyst $VERSION</title>
633 <style type="text/css">
636 background-color: #eee;
645 background-color: #ccc;
646 border: 1px solid #aaa;
647 -moz-border-radius: 10px;
652 font-family: verdana, tahoma, sans-serif;
655 font-family: verdana, tahoma, sans-serif;
658 text-decoration: none;
660 border-bottom: 1px dotted #bbb;
662 :link:hover, :visited:hover {
675 background-color: #fff;
676 border: 1px solid #aaa;
677 -moz-border-radius: 10px;
703 <h1><span id="appname">$name</span> on <a href="http://catalyst.perl.org">Catalyst</a>
708 <img src="$logo" alt="Catalyst Logo" />
710 <p>Welcome to the wonderful world of Catalyst.
711 This <a href="http://en.wikipedia.org/wiki/MVC">MVC</a>
712 framework will make web development something you had
713 never expected it to be: Fun, rewarding and quick.</p>
714 <h2>What to do now?</h2>
715 <p>That really depends on what <b>you</b> want to do.
716 We do, however, provide you with a few starting points.</p>
717 <p>If you want to jump right into web development with Catalyst
718 you might want to check out the documentation.</p>
719 <pre><code>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst/lib/Catalyst/Manual/Intro.pod">Catalyst::Manual::Intro</a>
720 perldoc <a href="http://cpansearch.perl.org/dist/Catalyst/lib/Catalyst/Manual.pod">Catalyst::Manual</a></code></pre>
721 <h2>What to do next?</h2>
722 <p>Next it's time to write an actual application. Use the
723 helper scripts to generate <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AController%3A%3A&mode=all">controllers</a>,
724 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AModel%3A%3A&mode=all">models</a> and
725 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AView%3A%3A&mode=all">views</a>,
726 they can save you a lot of work.</p>
727 <pre><code>script/${prefix}_create.pl -help</code></pre>
728 <p>Also, be sure to check out the vast and growing
729 collection of <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3APlugin%3A%3A&mode=all">plugins for Catalyst on CPAN</a>,
730 you are likely to find what you need there.
734 <p>Catalyst has a very active community. Here are the main places to
735 get in touch with us.</p>
738 <a href="http://dev.catalyst.perl.org">Wiki</a>
741 <a href="http://lists.rawmode.org/mailman/listinfo/catalyst">Mailing-List</a>
744 <a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
747 <h2>In conclusion</h2>
748 <p>The Catalyst team hopes you will enjoy using Catalyst as much
749 as we enjoyed making it. Please contact us if you have ideas
750 for improvement or other feedback.</p>
760 =head1 INTERNAL METHODS
764 =item $c->benchmark($coderef)
766 Takes a coderef with arguments and returns elapsed time as float.
768 my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
769 $c->log->info( sprintf "Processing took %f seconds", $elapsed );
776 my $time = [gettimeofday];
777 my @return = &$code(@_);
778 my $elapsed = tv_interval $time;
779 return wantarray ? ( $elapsed, @return ) : $elapsed;
784 Contains the components.
788 Returns a hashref containing coderefs and execution counts.
789 (Needed for deep recursion detection)
793 Returns the actual forward depth.
797 Dispatch request to actions.
801 sub dispatch { my $c = shift; $c->dispatcher->dispatch( $c, @_ ) }
805 Returns a list of 2-element array references (name, structure) pairs that will
806 be dumped on the error page in debug mode.
812 [ Request => $c->req ], [ Response => $c->res ], [ Stash => $c->stash ],;
815 =item $c->execute($class, $coderef)
817 Execute a coderef in given class and catch exceptions.
818 Errors are available via $c->error.
823 my ( $c, $class, $code ) = @_;
824 $class = $c->components->{$class} || $class;
826 my $callsub = ( caller(1) )[3];
831 $action = "/$action" unless $action =~ /\-\>/;
832 $c->counter->{"$code"}++;
834 if ( $c->counter->{"$code"} > $RECURSION ) {
835 my $error = qq/Deep recursion detected in "$action"/;
836 $c->log->error($error);
842 $action = "-> $action" if $callsub =~ /forward$/;
848 my ( $elapsed, @state ) =
849 $c->benchmark( $code, $class, $c, @{ $c->req->args } );
850 unless ( ( $code->name =~ /^_.*/ )
851 && ( !$c->config->{show_internal_actions} ) )
853 push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
858 $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 );
863 if ( my $error = $@ ) {
865 if ( $error eq $DETACH ) { die $DETACH if $c->{depth} > 1 }
867 unless ( ref $error ) {
869 $error = qq/Caught exception "$error"/;
887 for my $error ( @{ $c->error } ) {
888 $c->log->error($error);
891 $c->finalize_uploads;
894 if ( $#{ $c->error } >= 0 ) {
898 $c->finalize_headers;
901 if ( $c->request->method eq 'HEAD' ) {
902 $c->response->body('');
907 return $c->response->status;
910 =item $c->finalize_body
916 sub finalize_body { my $c = shift; $c->engine->finalize_body( $c, @_ ) }
918 =item $c->finalize_cookies
924 sub finalize_cookies { my $c = shift; $c->engine->finalize_cookies( $c, @_ ) }
926 =item $c->finalize_error
932 sub finalize_error { my $c = shift; $c->engine->finalize_error( $c, @_ ) }
934 =item $c->finalize_headers
940 sub finalize_headers {
943 # Check if we already finalized headers
944 return if $c->response->{_finalized_headers};
947 if ( my $location = $c->response->redirect ) {
948 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
949 $c->response->header( Location => $location );
953 if ( $c->response->body && !$c->response->content_length ) {
954 $c->response->content_length( bytes::length( $c->response->body ) );
958 if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
959 $c->response->headers->remove_header("Content-Length");
960 $c->response->body('');
963 $c->finalize_cookies;
965 $c->engine->finalize_headers( $c, @_ );
968 $c->response->{_finalized_headers} = 1;
971 =item $c->finalize_output
973 An alias for finalize_body.
975 =item $c->finalize_read
977 Finalize the input after reading is complete.
981 sub finalize_read { my $c = shift; $c->engine->finalize_read( $c, @_ ) }
983 =item $c->finalize_uploads
985 Finalize uploads. Cleans up any temporary files.
989 sub finalize_uploads { my $c = shift; $c->engine->finalize_uploads( $c, @_ ) }
991 =item $c->get_action( $action, $namespace )
993 Get an action in a given namespace.
997 sub get_action { my $c = shift; $c->dispatcher->get_action(@_) }
999 =item $c->get_actions( $action, $namespace )
1001 Get all actions of a given name in a namespace and all base namespaces.
1005 sub get_actions { my $c = shift; $c->dispatcher->get_actions( $c, @_ ) }
1007 =item handle_request( $class, @arguments )
1009 Handles the request.
1013 sub handle_request {
1014 my ( $class, @arguments ) = @_;
1016 # Always expect worst case!
1022 my $c = $class->prepare(@arguments);
1023 $c->{stats} = \@stats;
1025 return $c->finalize;
1028 if ( $class->debug ) {
1030 ( $elapsed, $status ) = $class->benchmark($handler);
1031 $elapsed = sprintf '%f', $elapsed;
1032 my $av = sprintf '%.3f',
1033 ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
1034 my $t = Text::SimpleTable->new( [ 64, 'Action' ], [ 9, 'Time' ] );
1036 for my $stat (@stats) { $t->row( $stat->[0], $stat->[1] ) }
1038 "Request took ${elapsed}s ($av/s)\n" . $t->draw );
1040 else { $status = &$handler }
1044 if ( my $error = $@ ) {
1046 $class->log->error(qq/Caught exception in engine "$error"/);
1050 $class->log->_flush() if $class->log->can('_flush');
1054 =item $c->prepare(@arguments)
1056 Turns the engine-specific request( Apache, CGI ... )
1057 into a Catalyst context .
1062 my ( $class, @arguments ) = @_;
1067 request => Catalyst::Request->new(
1070 body_parameters => {},
1072 headers => HTTP::Headers->new,
1074 query_parameters => {},
1080 response => Catalyst::Response->new(
1084 headers => HTTP::Headers->new(),
1092 # For on-demand data
1093 $c->request->{_context} = $c;
1094 $c->response->{_context} = $c;
1095 weaken( $c->request->{_context} );
1096 weaken( $c->response->{_context} );
1099 my $secs = time - $START || 1;
1100 my $av = sprintf '%.3f', $COUNT / $secs;
1101 $c->log->debug('**********************************');
1102 $c->log->debug("* Request $COUNT ($av/s) [$$]");
1103 $c->log->debug('**********************************');
1104 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
1107 $c->prepare_request(@arguments);
1108 $c->prepare_connection;
1109 $c->prepare_query_parameters;
1110 $c->prepare_headers;
1111 $c->prepare_cookies;
1115 $c->prepare_body unless $c->config->{parse_on_demand};
1118 my $method = $c->req->method || '';
1119 my $path = $c->req->path || '';
1120 my $address = $c->req->address || '';
1122 $c->log->debug(qq/"$method" request for "$path" from $address/)
1128 =item $c->prepare_action
1134 sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
1136 =item $c->prepare_body
1138 Prepare message body.
1145 # Do we run for the first time?
1146 return if defined $c->request->{_body};
1148 # Initialize on-demand data
1149 $c->engine->prepare_body( $c, @_ );
1150 $c->prepare_parameters;
1151 $c->prepare_uploads;
1153 if ( $c->debug && keys %{ $c->req->body_parameters } ) {
1154 my $t = Text::SimpleTable->new( [ 37, 'Key' ], [ 36, 'Value' ] );
1155 for my $key ( sort keys %{ $c->req->body_parameters } ) {
1156 my $param = $c->req->body_parameters->{$key};
1157 my $value = defined($param) ? $param : '';
1159 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1161 $c->log->debug( "Body Parameters are:\n" . $t->draw );
1165 =item $c->prepare_body_chunk( $chunk )
1167 Prepare a chunk of data before sending it to HTTP::Body.
1171 sub prepare_body_chunk {
1173 $c->engine->prepare_body_chunk( $c, @_ );
1176 =item $c->prepare_body_parameters
1178 Prepare body parameters.
1182 sub prepare_body_parameters {
1184 $c->engine->prepare_body_parameters( $c, @_ );
1187 =item $c->prepare_connection
1193 sub prepare_connection {
1195 $c->engine->prepare_connection( $c, @_ );
1198 =item $c->prepare_cookies
1204 sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
1206 =item $c->prepare_headers
1212 sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
1214 =item $c->prepare_parameters
1220 sub prepare_parameters {
1222 $c->prepare_body_parameters;
1223 $c->engine->prepare_parameters( $c, @_ );
1226 =item $c->prepare_path
1228 Prepare path and base.
1232 sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
1234 =item $c->prepare_query_parameters
1236 Prepare query parameters.
1240 sub prepare_query_parameters {
1243 $c->engine->prepare_query_parameters( $c, @_ );
1245 if ( $c->debug && keys %{ $c->request->query_parameters } ) {
1246 my $t = Text::SimpleTable->new( [ 37, 'Key' ], [ 36, 'Value' ] );
1247 for my $key ( sort keys %{ $c->req->query_parameters } ) {
1248 my $param = $c->req->query_parameters->{$key};
1249 my $value = defined($param) ? $param : '';
1251 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1253 $c->log->debug( "Query Parameters are:\n" . $t->draw );
1257 =item $c->prepare_read
1259 Prepare the input for reading.
1263 sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
1265 =item $c->prepare_request
1267 Prepare the engine request.
1271 sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
1273 =item $c->prepare_uploads
1279 sub prepare_uploads {
1282 $c->engine->prepare_uploads( $c, @_ );
1284 if ( $c->debug && keys %{ $c->request->uploads } ) {
1285 my $t = Text::SimpleTable->new(
1291 for my $key ( sort keys %{ $c->request->uploads } ) {
1292 my $upload = $c->request->uploads->{$key};
1293 for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
1294 $t->row( $key, $u->filename, $u->type, $u->size );
1297 $c->log->debug( "File Uploads are:\n" . $t->draw );
1301 =item $c->prepare_write
1303 Prepare the output for writing.
1307 sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
1309 =item $c->read( [$maxlength] )
1311 Read a chunk of data from the request body. This method is designed to be
1312 used in a while loop, reading $maxlength bytes on every call. $maxlength
1313 defaults to the size of the request if not specified.
1315 You have to set MyApp->config->{parse_on_demand} to use this directly.
1319 sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
1327 sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
1329 =item $c->set_action( $action, $code, $namespace, $attrs )
1331 Set an action in a given namespace.
1335 sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
1337 =item $c->setup_actions($component)
1339 Setup actions for a component.
1343 sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
1345 =item $c->setup_components
1351 sub setup_components {
1354 my $callback = sub {
1355 my ( $component, $context ) = @_;
1357 unless ( $component->isa('Catalyst::Component') ) {
1361 my $suffix = Catalyst::Utils::class2classsuffix($class);
1362 my $config = $class->config->{$suffix} || {};
1366 eval { $instance = $component->new( $context, $config ); };
1368 if ( my $error = $@ ) {
1372 Catalyst::Exception->throw( message =>
1373 qq/Couldn't instantiate component "$component", "$error"/ );
1376 Catalyst::Exception->throw( message =>
1377 qq/Couldn't instantiate component "$component", "new() didn't return a object"/
1379 unless ref $instance;
1384 Module::Pluggable::Fast->import(
1385 name => '_catalyst_components',
1387 "$class\::Controller", "$class\::C",
1388 "$class\::Model", "$class\::M",
1389 "$class\::View", "$class\::V"
1391 callback => $callback
1395 if ( my $error = $@ ) {
1399 Catalyst::Exception->throw(
1400 message => qq/Couldn't load components "$error"/ );
1403 for my $component ( $class->_catalyst_components($class) ) {
1404 $class->components->{ ref $component || $component } = $component;
1408 =item $c->setup_dispatcher
1412 sub setup_dispatcher {
1413 my ( $class, $dispatcher ) = @_;
1416 $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
1419 if ( $ENV{CATALYST_DISPATCHER} ) {
1420 $dispatcher = 'Catalyst::Dispatcher::' . $ENV{CATALYST_DISPATCHER};
1423 if ( $ENV{ uc($class) . '_DISPATCHER' } ) {
1425 'Catalyst::Dispatcher::' . $ENV{ uc($class) . '_DISPATCHER' };
1428 unless ($dispatcher) {
1429 $dispatcher = 'Catalyst::Dispatcher';
1432 $dispatcher->require;
1435 Catalyst::Exception->throw(
1436 message => qq/Couldn't load dispatcher "$dispatcher", "$@"/ );
1439 # dispatcher instance
1440 $class->dispatcher( $dispatcher->new );
1443 =item $c->setup_engine
1448 my ( $class, $engine ) = @_;
1451 $engine = 'Catalyst::Engine::' . $engine;
1454 if ( $ENV{CATALYST_ENGINE} ) {
1455 $engine = 'Catalyst::Engine::' . $ENV{CATALYST_ENGINE};
1458 if ( $ENV{ uc($class) . '_ENGINE' } ) {
1459 $engine = 'Catalyst::Engine::' . $ENV{ uc($class) . '_ENGINE' };
1462 if ( !$engine && $ENV{MOD_PERL} ) {
1464 # create the apache method
1467 *{"$class\::apache"} = sub { shift->engine->apache };
1470 my ( $software, $version ) =
1471 $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
1474 $version =~ s/(\.[^.]+)\./$1/g;
1476 if ( $software eq 'mod_perl' ) {
1478 if ( $version >= 1.99922 ) {
1479 $engine = 'Catalyst::Engine::Apache2::MP20';
1482 elsif ( $version >= 1.9901 ) {
1483 $engine = 'Catalyst::Engine::Apache2::MP19';
1486 elsif ( $version >= 1.24 ) {
1487 $engine = 'Catalyst::Engine::Apache::MP13';
1491 Catalyst::Exception->throw( message =>
1492 qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
1495 # install the correct mod_perl handler
1496 if ( $version >= 1.9901 ) {
1497 *handler = sub : method {
1498 shift->handle_request(@_);
1502 *handler = sub ($$) { shift->handle_request(@_) };
1507 elsif ( $software eq 'Zeus-Perl' ) {
1508 $engine = 'Catalyst::Engine::Zeus';
1512 Catalyst::Exception->throw(
1513 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
1518 $engine = 'Catalyst::Engine::CGI';
1524 Catalyst::Exception->throw( message =>
1525 qq/Couldn't load engine "$engine" (maybe you forgot to install it?), "$@"/
1529 # check for old engines that are no longer compatible
1531 if ( $engine->isa('Catalyst::Engine::Apache')
1532 && !Catalyst::Engine::Apache->VERSION )
1537 elsif ( $engine->isa('Catalyst::Engine::Server::Base')
1538 && Catalyst::Engine::Server->VERSION le '0.02' )
1543 elsif ($engine->isa('Catalyst::Engine::HTTP::POE')
1544 && $engine->VERSION eq '0.01' )
1549 elsif ($engine->isa('Catalyst::Engine::Zeus')
1550 && $engine->VERSION eq '0.01' )
1556 Catalyst::Exception->throw( message =>
1557 qq/Engine "$engine" is not supported by this version of Catalyst/
1562 $class->engine( $engine->new );
1565 =item $c->setup_home
1570 my ( $class, $home ) = @_;
1572 if ( $ENV{CATALYST_HOME} ) {
1573 $home = $ENV{CATALYST_HOME};
1576 if ( $ENV{ uc($class) . '_HOME' } ) {
1577 $home = $ENV{ uc($class) . '_HOME' };
1581 $home = Catalyst::Utils::home($class);
1585 $class->config->{home} ||= $home;
1586 $class->config->{root} ||= dir($home)->subdir('root');
1595 my ( $class, $debug ) = @_;
1597 unless ( $class->log ) {
1598 $class->log( Catalyst::Log->new );
1601 my $app_flag = Catalyst::Utils::class2env($class) . '_DEBUG';
1604 ( defined( $ENV{CATALYST_DEBUG} ) || defined( $ENV{$app_flag} ) )
1605 ? ( $ENV{CATALYST_DEBUG} || $ENV{$app_flag} )
1610 *{"$class\::debug"} = sub { 1 };
1611 $class->log->debug('Debug messages enabled');
1615 =item $c->setup_plugins
1620 my ( $class, $plugins ) = @_;
1623 for my $plugin ( reverse @$plugins ) {
1625 $plugin = "Catalyst::Plugin::$plugin";
1630 Catalyst::Exception->throw(
1631 message => qq/Couldn't load plugin "$plugin", "$@"/ );
1636 unshift @{"$class\::ISA"}, $plugin;
1641 =item $c->write( $data )
1643 Writes $data to the output stream. When using this method directly, you will
1644 need to manually set the Content-Length header to the length of your output
1652 # Finalize headers if someone manually writes output
1653 $c->finalize_headers;
1655 return $c->engine->write( $c, @_ );
1660 Returns the Catalyst version number. mostly useful for powered by messages
1661 in template systems.
1665 sub version { return $Catalyst::VERSION }
1669 =head1 INTERNAL ACTIONS
1671 Catalyst uses internal actions like C<_DISPATCH>, C<_BEGIN>, C<_AUTO>
1672 C<_ACTION> and C<_END>, these are by default not shown in the private
1675 But you can deactivate this with a config parameter.
1677 MyApp->config->{show_internal_actions} = 1;
1679 =head1 CASE SENSITIVITY
1681 By default Catalyst is not case sensitive, so C<MyApp::C::FOO::Bar> becomes
1684 But you can activate case sensitivity with a config parameter.
1686 MyApp->config->{case_sensitive} = 1;
1688 So C<MyApp::C::Foo::Bar> becomes C</Foo/Bar>.
1690 =head1 ON-DEMAND PARSER
1692 The request body is usually parsed at the beginning of a request,
1693 but if you want to handle input yourself or speed things up a bit
1694 you can enable on-demand parsing with a config parameter.
1696 MyApp->config->{parse_on_demand} = 1;
1698 =head1 PROXY SUPPORT
1700 Many production servers operate using the common double-server approach, with
1701 a lightweight frontend web server passing requests to a larger backend
1702 server. An application running on the backend server must deal with two
1703 problems: the remote user always appears to be '127.0.0.1' and the server's
1704 hostname will appear to be 'localhost' regardless of the virtual host the
1705 user connected through.
1707 Catalyst will automatically detect this situation when you are running both
1708 the frontend and backend servers on the same machine. The following changes
1709 are made to the request.
1711 $c->req->address is set to the user's real IP address, as read from the
1712 HTTP_X_FORWARDED_FOR header.
1714 The host value for $c->req->base and $c->req->uri is set to the real host,
1715 as read from the HTTP_X_FORWARDED_HOST header.
1717 Obviously, your web server must support these 2 headers for this to work.
1719 In a more complex server farm environment where you may have your frontend
1720 proxy server(s) on different machines, you will need to set a configuration
1721 option to tell Catalyst to read the proxied data from the headers.
1723 MyApp->config->{using_frontend_proxy} = 1;
1725 If you do not wish to use the proxy support at all, you may set:
1727 MyApp->config->{ignore_frontend_proxy} = 1;
1729 =head1 THREAD SAFETY
1731 Catalyst has been tested under Apache 2's threading mpm_worker, mpm_winnt,
1732 and the standalone forking HTTP server on Windows. We believe the Catalyst
1733 core to be thread-safe.
1735 If you plan to operate in a threaded environment, remember that all other
1736 modules you are using must also be thread-safe. Some modules, most notably
1737 DBD::SQLite, are not thread-safe.
1743 Join #catalyst on irc.perl.org.
1747 http://lists.rawmode.org/mailman/listinfo/catalyst
1748 http://lists.rawmode.org/mailman/listinfo/catalyst-dev
1752 http://catalyst.perl.org
1758 =item L<Catalyst::Manual> - The Catalyst Manual
1760 =item L<Catalyst::Engine> - Core Engine
1762 =item L<Catalyst::Log> - The Log Class.
1764 =item L<Catalyst::Request> - The Request Object
1766 =item L<Catalyst::Response> - The Response Object
1768 =item L<Catalyst::Test> - The test suite.
1836 Sebastian Riedel, C<sri@oook.de>
1840 This library is free software, you can redistribute it and/or modify it under
1841 the same terms as Perl itself.