force pod coverage testing for authors
[catagits/Catalyst-Runtime.git] / lib / Catalyst.pm
CommitLineData
fc7ec1d9 1package Catalyst;
2
3use strict;
31375184 4use base 'Catalyst::Component';
fbcc39ad 5use bytes;
a2f2cde9 6use Catalyst::Exception;
fc7ec1d9 7use Catalyst::Log;
fbcc39ad 8use Catalyst::Request;
9use Catalyst::Request::Upload;
10use Catalyst::Response;
812a28c9 11use Catalyst::Utils;
31375184 12use Catalyst::Controller;
364d7324 13use Devel::InnerPackage ();
8f62c91a 14use File::stat;
c50f595c 15use Module::Pluggable::Object ();
5d9a6d47 16use NEXT;
c50f595c 17use Text::SimpleTable ();
18use Path::Class::Dir ();
19use Path::Class::File ();
fbcc39ad 20use Time::HiRes qw/gettimeofday tv_interval/;
c50f595c 21use URI ();
933ba403 22use URI::http;
23use URI::https;
6a4a7002 24use Scalar::Util qw/weaken blessed/;
5513038d 25use Tree::Simple qw/use_weak_refs/;
26use Tree::Simple::Visitor::FindByUID;
261c571e 27use attributes;
5789a3d8 28use utf8;
c45c5d37 29use Carp qw/croak carp/;
fc7ec1d9 30
f63c03e4 31BEGIN { require 5.008001; }
32
66e28e3f 33__PACKAGE__->mk_accessors(
7a7d7af5 34 qw/counter request response state action stack namespace stats/
66e28e3f 35);
10dd6896 36
684d10ed 37attributes->import( __PACKAGE__, \&namespace, 'lvalue' );
261c571e 38
8767c5a3 39sub depth { scalar @{ shift->stack || [] }; }
28591cd7 40
fbcc39ad 41# Laziness++
42*comp = \&component;
43*req = \&request;
44*res = \&response;
45
46# For backwards compatibility
47*finalize_output = \&finalize_body;
48
49# For statistics
50our $COUNT = 1;
51our $START = time;
52our $RECURSION = 1000;
53our $DETACH = "catalyst_detach\n";
54
fbcc39ad 55__PACKAGE__->mk_classdata($_)
3cec521a 56 for qw/components arguments dispatcher engine log dispatcher_class
dc5f035e 57 engine_class context_class request_class response_class stats_class
58 setup_finished/;
cb0354c6 59
3cec521a 60__PACKAGE__->dispatcher_class('Catalyst::Dispatcher');
61__PACKAGE__->engine_class('Catalyst::Engine::CGI');
62__PACKAGE__->request_class('Catalyst::Request');
63__PACKAGE__->response_class('Catalyst::Response');
dc5f035e 64__PACKAGE__->stats_class('Catalyst::Stats');
fbcc39ad 65
6415bb4d 66# Remember to update this in Catalyst::Runtime as well!
67
4d4d6635 68our $VERSION = '5.7011';
189e2a51 69
fbcc39ad 70sub import {
71 my ( $class, @arguments ) = @_;
72
73 # We have to limit $class to Catalyst to avoid pushing Catalyst upon every
74 # callers @ISA.
75 return unless $class eq 'Catalyst';
76
77 my $caller = caller(0);
78
79 unless ( $caller->isa('Catalyst') ) {
80 no strict 'refs';
31375184 81 push @{"$caller\::ISA"}, $class, 'Catalyst::Controller';
fbcc39ad 82 }
83
84 $caller->arguments( [@arguments] );
85 $caller->setup_home;
86}
fc7ec1d9 87
88=head1 NAME
89
90Catalyst - The Elegant MVC Web Application Framework
91
92=head1 SYNOPSIS
93
e7ad3b81 94See the L<Catalyst::Manual> distribution for comprehensive
95documentation and tutorials.
96
86418559 97 # Install Catalyst::Devel for helpers and other development tools
b4b01a8a 98 # use the helper to create a new application
91864987 99 catalyst.pl MyApp
fc7ec1d9 100
101 # add models, views, controllers
cc95842f 102 script/myapp_create.pl model MyDatabase DBIC::Schema create=dynamic dbi:SQLite:/path/to/db
103 script/myapp_create.pl view MyTemplate TT
0ef52a96 104 script/myapp_create.pl controller Search
fc7ec1d9 105
e7f1cf73 106 # built in testserver -- use -r to restart automatically on changes
cc95842f 107 # --help to see all available options
ae4e40a7 108 script/myapp_server.pl
fc7ec1d9 109
0ef52a96 110 # command line testing interface
ae4e40a7 111 script/myapp_test.pl /yada
fc7ec1d9 112
b4b01a8a 113 ### in lib/MyApp.pm
0ef52a96 114 use Catalyst qw/-Debug/; # include plugins here as well
115
85d9fce6 116 ### In lib/MyApp/Controller/Root.pm (autocreated)
0ef52a96 117 sub foo : Global { # called for /foo, /foo/1, /foo/1/2, etc.
ae1e6b59 118 my ( $self, $c, @args ) = @_; # args are qw/1 2/ for /foo/1/2
119 $c->stash->{template} = 'foo.tt'; # set the template
0ef52a96 120 # lookup something from db -- stash vars are passed to TT
ae1e6b59 121 $c->stash->{data} =
b4b01a8a 122 $c->model('Database::Foo')->search( { country => $args[0] } );
0ef52a96 123 if ( $c->req->params->{bar} ) { # access GET or POST parameters
124 $c->forward( 'bar' ); # process another action
125 # do something else after forward returns
126 }
127 }
128
ae1e6b59 129 # The foo.tt TT template can use the stash data from the database
0ef52a96 130 [% WHILE (item = data.next) %]
131 [% item.foo %]
132 [% END %]
133
134 # called for /bar/of/soap, /bar/of/soap/10, etc.
135 sub bar : Path('/bar/of/soap') { ... }
fc7ec1d9 136
ae1e6b59 137 # called for all actions, from the top-most controller downwards
0ef52a96 138 sub auto : Private {
139 my ( $self, $c ) = @_;
b4b01a8a 140 if ( !$c->user_exists ) { # Catalyst::Plugin::Authentication
0ef52a96 141 $c->res->redirect( '/login' ); # require login
142 return 0; # abort request and go immediately to end()
143 }
ae1e6b59 144 return 1; # success; carry on to next action
0ef52a96 145 }
146
ae1e6b59 147 # called after all actions are finished
0ef52a96 148 sub end : Private {
5a8ed4fe 149 my ( $self, $c ) = @_;
0ef52a96 150 if ( scalar @{ $c->error } ) { ... } # handle errors
151 return if $c->res->body; # already have a response
152 $c->forward( 'MyApp::View::TT' ); # render template
5a8ed4fe 153 }
154
0ef52a96 155 ### in MyApp/Controller/Foo.pm
156 # called for /foo/bar
157 sub bar : Local { ... }
158
5400c668 159 # called for /blargle
160 sub blargle : Global { ... }
161
162 # an index action matches /foo, but not /foo/1, etc.
163 sub index : Private { ... }
0ef52a96 164
165 ### in MyApp/Controller/Foo/Bar.pm
166 # called for /foo/bar/baz
167 sub baz : Local { ... }
168
b4b01a8a 169 # first Root auto is called, then Foo auto, then this
0ef52a96 170 sub auto : Private { ... }
171
172 # powerful regular expression paths are also possible
173 sub details : Regex('^product/(\w+)/details$') {
5a8ed4fe 174 my ( $self, $c ) = @_;
0ef52a96 175 # extract the (\w+) from the URI
2982e768 176 my $product = $c->req->captures->[0];
5a8ed4fe 177 }
fc7ec1d9 178
0ef52a96 179See L<Catalyst::Manual::Intro> for additional information.
3803e98f 180
fc7ec1d9 181=head1 DESCRIPTION
182
86418559 183Catalyst is a modern framework for making web applications without the
184pain usually associated with this process. This document is a reference
185to the main Catalyst application. If you are a new user, we suggest you
186start with L<Catalyst::Manual::Tutorial> or L<Catalyst::Manual::Intro>.
fc7ec1d9 187
188See L<Catalyst::Manual> for more documentation.
189
ae1e6b59 190Catalyst plugins can be loaded by naming them as arguments to the "use
191Catalyst" statement. Omit the C<Catalyst::Plugin::> prefix from the
192plugin name, i.e., C<Catalyst::Plugin::My::Module> becomes
193C<My::Module>.
fc7ec1d9 194
0ef52a96 195 use Catalyst qw/My::Module/;
fc7ec1d9 196
836e1134 197If your plugin starts with a name other than C<Catalyst::Plugin::>, you can
198fully qualify the name by using a unary plus:
199
200 use Catalyst qw/
201 My::Module
202 +Fully::Qualified::Plugin::Name
203 /;
204
ae1e6b59 205Special flags like C<-Debug> and C<-Engine> can also be specified as
206arguments when Catalyst is loaded:
fc7ec1d9 207
208 use Catalyst qw/-Debug My::Module/;
209
ae1e6b59 210The position of plugins and flags in the chain is important, because
86418559 211they are loaded in the order in which they appear.
fc7ec1d9 212
23f9d934 213The following flags are supported:
214
b5ecfcf0 215=head2 -Debug
23f9d934 216
f8ad6ea5 217Enables debug output. You can also force this setting from the system
86418559 218environment with CATALYST_DEBUG or <MYAPP>_DEBUG. The environment
219settings override the application, with <MYAPP>_DEBUG having the highest
220priority.
fc7ec1d9 221
b5ecfcf0 222=head2 -Engine
fc7ec1d9 223
ae1e6b59 224Forces Catalyst to use a specific engine. Omit the
225C<Catalyst::Engine::> prefix of the engine name, i.e.:
fc7ec1d9 226
0ef52a96 227 use Catalyst qw/-Engine=CGI/;
fc7ec1d9 228
b5ecfcf0 229=head2 -Home
fbcc39ad 230
ae1e6b59 231Forces Catalyst to use a specific home directory, e.g.:
232
86418559 233 use Catalyst qw[-Home=/usr/mst];
fbcc39ad 234
cc95842f 235This can also be done in the shell environment by setting either the
236C<CATALYST_HOME> environment variable or C<MYAPP_HOME>; where C<MYAPP>
237is replaced with the uppercased name of your application, any "::" in
238the name will be replaced with underscores, e.g. MyApp::Web should use
239MYAPP_WEB_HOME. If both variables are set, the MYAPP_HOME one will be used.
240
b5ecfcf0 241=head2 -Log
fbcc39ad 242
0ef52a96 243Specifies log level.
fbcc39ad 244
dc5f035e 245=head2 -Stats
246
247Enables statistics collection and reporting. You can also force this setting
248from the system environment with CATALYST_STATS or <MYAPP>_STATS. The
249environment settings override the application, with <MYAPP>_STATS having the
250highest priority.
251
252e.g.
253
254 use Catalyst qw/-Stats=1/
255
23f9d934 256=head1 METHODS
257
f7b672ef 258=head2 INFORMATION ABOUT THE CURRENT REQUEST
0ef52a96 259
b5ecfcf0 260=head2 $c->action
66e28e3f 261
ae1e6b59 262Returns a L<Catalyst::Action> object for the current action, which
263stringifies to the action name. See L<Catalyst::Action>.
0ef52a96 264
b5ecfcf0 265=head2 $c->namespace
0ef52a96 266
86418559 267Returns the namespace of the current action, i.e., the URI prefix
ae1e6b59 268corresponding to the controller of the current action. For example:
269
270 # in Controller::Foo::Bar
271 $c->namespace; # returns 'foo/bar';
0ef52a96 272
b5ecfcf0 273=head2 $c->request
0ef52a96 274
b5ecfcf0 275=head2 $c->req
0ef52a96 276
86418559 277Returns the current L<Catalyst::Request> object, giving access to
278information about the current client request (including parameters,
279cookies, HTTP headers, etc.). See L<Catalyst::Request>.
0ef52a96 280
b4b01a8a 281=head2 REQUEST FLOW HANDLING
0ef52a96 282
b5ecfcf0 283=head2 $c->forward( $action [, \@arguments ] )
0ef52a96 284
b5ecfcf0 285=head2 $c->forward( $class, $method, [, \@arguments ] )
0ef52a96 286
86418559 287Forwards processing to another action, by its private name. If you give a
b4b01a8a 288class name but no method, C<process()> is called. You may also optionally
289pass arguments in an arrayref. The action will receive the arguments in
cc95842f 290C<@_> and C<< $c->req->args >>. Upon returning from the function,
291C<< $c->req->args >> will be restored to the previous values.
0ef52a96 292
3b984c64 293Any data C<return>ed from the action forwarded to, will be returned by the
d759db1e 294call to forward.
3b984c64 295
296 my $foodata = $c->forward('/foo');
0ef52a96 297 $c->forward('index');
e112461a 298 $c->forward(qw/MyApp::Model::DBIC::Foo do_stuff/);
0ef52a96 299 $c->forward('MyApp::View::TT');
300
86418559 301Note that forward implies an C<<eval { }>> around the call (actually
302C<execute> does), thus de-fatalizing all 'dies' within the called
303action. If you want C<die> to propagate you need to do something like:
f3e6a8c0 304
305 $c->forward('foo');
306 die $c->error if $c->error;
307
86418559 308Or make sure to always return true values from your actions and write
309your code like this:
f3e6a8c0 310
311 $c->forward('foo') || return;
312
0ef52a96 313=cut
314
315sub forward { my $c = shift; $c->dispatcher->forward( $c, @_ ) }
316
b5ecfcf0 317=head2 $c->detach( $action [, \@arguments ] )
0ef52a96 318
b5ecfcf0 319=head2 $c->detach( $class, $method, [, \@arguments ] )
0ef52a96 320
264bac8c 321=head2 $c->detach()
322
b4b01a8a 323The same as C<forward>, but doesn't return to the previous action when
324processing is finished.
0ef52a96 325
264bac8c 326When called with no arguments it escapes the processing chain entirely.
327
0ef52a96 328=cut
329
330sub detach { my $c = shift; $c->dispatcher->detach( $c, @_ ) }
331
b4b01a8a 332=head2 $c->response
333
334=head2 $c->res
335
cc95842f 336Returns the current L<Catalyst::Response> object, see there for details.
b4b01a8a 337
338=head2 $c->stash
339
340Returns a hashref to the stash, which may be used to store data and pass
341it between components during a request. You can also set hash keys by
342passing arguments. The stash is automatically sent to the view. The
343stash is cleared at the end of a request; it cannot be used for
86418559 344persistent storage (for this you must use a session; see
345L<Catalyst::Plugin::Session> for a complete system integrated with
346Catalyst).
b4b01a8a 347
348 $c->stash->{foo} = $bar;
349 $c->stash( { moose => 'majestic', qux => 0 } );
350 $c->stash( bar => 1, gorch => 2 ); # equivalent to passing a hashref
351
352 # stash is automatically passed to the view for use in a template
cc95842f 353 $c->forward( 'MyApp::View::TT' );
b4b01a8a 354
355=cut
356
357sub stash {
358 my $c = shift;
359 if (@_) {
360 my $stash = @_ > 1 ? {@_} : $_[0];
85d9fce6 361 croak('stash takes a hash or hashref') unless ref $stash;
c82ed742 362 foreach my $key ( keys %$stash ) {
363 $c->{stash}->{$key} = $stash->{$key};
b4b01a8a 364 }
365 }
366 return $c->{stash};
367}
368
b5ecfcf0 369=head2 $c->error
0ef52a96 370
b5ecfcf0 371=head2 $c->error($error, ...)
0ef52a96 372
b5ecfcf0 373=head2 $c->error($arrayref)
0ef52a96 374
83a8fcac 375Returns an arrayref containing error messages. If Catalyst encounters an
376error while processing a request, it stores the error in $c->error. This
e7ad3b81 377method should only be used to store fatal error messages.
0ef52a96 378
379 my @error = @{ $c->error };
380
381Add a new error.
382
383 $c->error('Something bad happened');
384
0ef52a96 385=cut
386
387sub error {
388 my $c = shift;
389 if ( $_[0] ) {
390 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
9ce44430 391 croak @$error unless ref $c;
0ef52a96 392 push @{ $c->{error} }, @$error;
393 }
394 elsif ( defined $_[0] ) { $c->{error} = undef }
395 return $c->{error} || [];
396}
397
b4b01a8a 398
399=head2 $c->state
400
401Contains the return value of the last executed action.
402
ca81eb67 403=head2 $c->clear_errors
404
405Clear errors. You probably don't want to clear the errors unless you are
406implementing a custom error screen.
407
408This is equivalent to running
409
410 $c->error(0);
411
412=cut
413
414sub clear_errors {
415 my $c = shift;
416 $c->error(0);
417}
418
0ef52a96 419
0756fe3b 420# search via regex
421sub _comp_search {
197bd788 422 my ( $c, @names ) = @_;
0756fe3b 423
424 foreach my $name (@names) {
425 foreach my $component ( keys %{ $c->components } ) {
197bd788 426 return $c->components->{$component} if $component =~ /$name/i;
0756fe3b 427 }
428 }
429
430 return undef;
431}
432
433# try explicit component names
434sub _comp_explicit {
197bd788 435 my ( $c, @names ) = @_;
0756fe3b 436
437 foreach my $try (@names) {
197bd788 438 return $c->components->{$try} if ( exists $c->components->{$try} );
0756fe3b 439 }
440
441 return undef;
442}
443
444# like component, but try just these prefixes before regex searching,
445# and do not try to return "sort keys %{ $c->components }"
446sub _comp_prefixes {
197bd788 447 my ( $c, $name, @prefixes ) = @_;
0756fe3b 448
449 my $appclass = ref $c || $c;
450
451 my @names = map { "${appclass}::${_}::${name}" } @prefixes;
452
453 my $comp = $c->_comp_explicit(@names);
454 return $comp if defined($comp);
455 $comp = $c->_comp_search($name);
456 return $comp;
457}
458
3b88a455 459# Find possible names for a prefix
460
461sub _comp_names {
462 my ( $c, @prefixes ) = @_;
463
464 my $appclass = ref $c || $c;
465
466 my @pre = map { "${appclass}::${_}::" } @prefixes;
467
468 my @names;
469
470 COMPONENT: foreach my $comp ($c->component) {
471 foreach my $p (@pre) {
472 if ($comp =~ s/^$p//) {
473 push(@names, $comp);
474 next COMPONENT;
475 }
476 }
477 }
478
479 return @names;
480}
481
649fd1fa 482# Return a component if only one matches.
483sub _comp_singular {
197bd788 484 my ( $c, @prefixes ) = @_;
649fd1fa 485
486 my $appclass = ref $c || $c;
487
197bd788 488 my ( $comp, $rest ) =
489 map { $c->_comp_search("^${appclass}::${_}::") } @prefixes;
649fd1fa 490 return $comp unless $rest;
491}
492
197bd788 493# Filter a component before returning by calling ACCEPT_CONTEXT if available
494sub _filter_component {
495 my ( $c, $comp, @args ) = @_;
496 if ( eval { $comp->can('ACCEPT_CONTEXT'); } ) {
497 return $comp->ACCEPT_CONTEXT( $c, @args );
498 }
499 else { return $comp }
500}
501
f7b672ef 502=head2 COMPONENT ACCESSORS
0ef52a96 503
b5ecfcf0 504=head2 $c->controller($name)
af3ff00e 505
0ef52a96 506Gets a L<Catalyst::Controller> instance by name.
af3ff00e 507
508 $c->controller('Foo')->do_stuff;
509
86418559 510If the name is omitted, will return the controller for the dispatched
511action.
649fd1fa 512
af3ff00e 513=cut
514
515sub controller {
197bd788 516 my ( $c, $name, @args ) = @_;
517 return $c->_filter_component( $c->_comp_prefixes( $name, qw/Controller C/ ),
518 @args )
519 if ($name);
520 return $c->component( $c->action->class );
af3ff00e 521}
522
b5ecfcf0 523=head2 $c->model($name)
fc7ec1d9 524
0ef52a96 525Gets a L<Catalyst::Model> instance by name.
526
527 $c->model('Foo')->do_stuff;
fc7ec1d9 528
72f87c4b 529Any extra arguments are directly passed to ACCEPT_CONTEXT.
530
a3b71f0f 531If the name is omitted, it will look for
532 - a model object in $c->stash{current_model_instance}, then
533 - a model name in $c->stash->{current_model}, then
534 - a config setting 'default_model', or
535 - check if there is only one model, and return it if that's the case.
649fd1fa 536
fc7ec1d9 537=cut
538
0ef52a96 539sub model {
197bd788 540 my ( $c, $name, @args ) = @_;
541 return $c->_filter_component( $c->_comp_prefixes( $name, qw/Model M/ ),
542 @args )
543 if $name;
a3b71f0f 544 if (ref $c) {
545 return $c->stash->{current_model_instance}
546 if $c->stash->{current_model_instance};
547 return $c->model( $c->stash->{current_model} )
548 if $c->stash->{current_model};
a3b71f0f 549 }
72f87c4b 550 return $c->model( $c->config->{default_model} )
551 if $c->config->{default_model};
552 return $c->_filter_component( $c->_comp_singular(qw/Model M/) );
649fd1fa 553
0ef52a96 554}
fc7ec1d9 555
b4b01a8a 556=head2 $c->controllers
3b88a455 557
b4b01a8a 558Returns the available names which can be passed to $c->controller
3b88a455 559
560=cut
561
b4b01a8a 562sub controllers {
3b88a455 563 my ( $c ) = @_;
b4b01a8a 564 return $c->_comp_names(qw/Controller C/);
3b88a455 565}
566
b4b01a8a 567
b5ecfcf0 568=head2 $c->view($name)
0ef52a96 569
570Gets a L<Catalyst::View> instance by name.
fc7ec1d9 571
0ef52a96 572 $c->view('Foo')->do_stuff;
fc7ec1d9 573
72f87c4b 574Any extra arguments are directly passed to ACCEPT_CONTEXT.
575
a3b71f0f 576If the name is omitted, it will look for
577 - a view object in $c->stash{current_view_instance}, then
578 - a view name in $c->stash->{current_view}, then
579 - a config setting 'default_view', or
580 - check if there is only one view, and return it if that's the case.
649fd1fa 581
fc7ec1d9 582=cut
583
0ef52a96 584sub view {
197bd788 585 my ( $c, $name, @args ) = @_;
586 return $c->_filter_component( $c->_comp_prefixes( $name, qw/View V/ ),
587 @args )
588 if $name;
a3b71f0f 589 if (ref $c) {
590 return $c->stash->{current_view_instance}
591 if $c->stash->{current_view_instance};
592 return $c->view( $c->stash->{current_view} )
593 if $c->stash->{current_view};
a3b71f0f 594 }
72f87c4b 595 return $c->view( $c->config->{default_view} )
596 if $c->config->{default_view};
197bd788 597 return $c->_filter_component( $c->_comp_singular(qw/View V/) );
0ef52a96 598}
fbcc39ad 599
b4b01a8a 600=head2 $c->models
601
602Returns the available names which can be passed to $c->model
603
604=cut
605
606sub models {
607 my ( $c ) = @_;
608 return $c->_comp_names(qw/Model M/);
609}
610
611
3b88a455 612=head2 $c->views
613
614Returns the available names which can be passed to $c->view
615
616=cut
617
618sub views {
619 my ( $c ) = @_;
620 return $c->_comp_names(qw/View V/);
621}
622
b4b01a8a 623=head2 $c->comp($name)
624
625=head2 $c->component($name)
626
cc95842f 627Gets a component object by name. This method is not recommended,
b4b01a8a 628unless you want to get a specific component by full
cc95842f 629class. C<< $c->controller >>, C<< $c->model >>, and C<< $c->view >>
b4b01a8a 630should be used instead.
631
632=cut
633
634sub component {
635 my $c = shift;
636
637 if (@_) {
638
639 my $name = shift;
640
641 my $appclass = ref $c || $c;
642
643 my @names = (
644 $name, "${appclass}::${name}",
645 map { "${appclass}::${_}::${name}" }
646 qw/Model M Controller C View V/
647 );
648
649 my $comp = $c->_comp_explicit(@names);
650 return $c->_filter_component( $comp, @_ ) if defined($comp);
651
652 $comp = $c->_comp_search($name);
653 return $c->_filter_component( $comp, @_ ) if defined($comp);
654 }
655
656 return sort keys %{ $c->components };
657}
658
659
660
661=head2 CLASS DATA AND HELPER CLASSES
fbcc39ad 662
b5ecfcf0 663=head2 $c->config
fbcc39ad 664
0ef52a96 665Returns or takes a hashref containing the application's configuration.
666
61b1d329 667 __PACKAGE__->config( { db => 'dsn:SQLite:foo.db' } );
81557adf 668
cc95842f 669You can also use a C<YAML>, C<XML> or C<Config::General> config file
670like myapp.yml in your applications home directory. See
671L<Catalyst::Plugin::ConfigLoader>.
a6ad13b6 672
673 ---
674 db: dsn:SQLite:foo.db
675
b4b01a8a 676
3643e890 677=cut
678
679sub config {
680 my $c = shift;
681
682 $c->log->warn("Setting config after setup has been run is not a good idea.")
683 if ( @_ and $c->setup_finished );
684
685 $c->NEXT::config(@_);
686}
687
b5ecfcf0 688=head2 $c->log
0ef52a96 689
86418559 690Returns the logging object instance. Unless it is already set, Catalyst
691sets this up with a L<Catalyst::Log> object. To use your own log class,
692set the logger with the C<< __PACKAGE__->log >> method prior to calling
9e7673af 693C<< __PACKAGE__->setup >>.
694
695 __PACKAGE__->log( MyLogger->new );
696 __PACKAGE__->setup;
697
698And later:
0ef52a96 699
ae1e6b59 700 $c->log->info( 'Now logging with my own logger!' );
0ef52a96 701
86418559 702Your log class should implement the methods described in
703L<Catalyst::Log>.
af3ff00e 704
b4b01a8a 705
706=head2 $c->debug
707
708Overload to enable debug messages (same as -Debug option).
709
e80e8542 710Note that this is a static method, not an accessor and should be overloaded
711by declaring "sub debug { 1 }" in your MyApp.pm, not by calling $c->debug(1).
712
af3ff00e 713=cut
714
b4b01a8a 715sub debug { 0 }
716
717=head2 $c->dispatcher
718
719Returns the dispatcher instance. Stringifies to class name. See
720L<Catalyst::Dispatcher>.
721
722=head2 $c->engine
723
724Returns the engine instance. Stringifies to the class name. See
725L<Catalyst::Engine>.
726
727
f7b672ef 728=head2 UTILITY METHODS
66e28e3f 729
b5ecfcf0 730=head2 $c->path_to(@path)
01033d73 731
cc95842f 732Merges C<@path> with C<< $c->config->{home} >> and returns a
733L<Path::Class::Dir> object.
01033d73 734
735For example:
736
737 $c->path_to( 'db', 'sqlite.db' );
738
739=cut
740
741sub path_to {
742 my ( $c, @path ) = @_;
a738ab68 743 my $path = Path::Class::Dir->new( $c->config->{home}, @path );
01033d73 744 if ( -d $path ) { return $path }
a738ab68 745 else { return Path::Class::File->new( $c->config->{home}, @path ) }
01033d73 746}
747
b5ecfcf0 748=head2 $c->plugin( $name, $class, @args )
0ef52a96 749
ae1e6b59 750Helper method for plugins. It creates a classdata accessor/mutator and
751loads and instantiates the given class.
0ef52a96 752
753 MyApp->plugin( 'prototype', 'HTML::Prototype' );
754
755 $c->prototype->define_javascript_functions;
756
757=cut
758
759sub plugin {
760 my ( $class, $name, $plugin, @args ) = @_;
97b58e17 761 $class->_register_plugin( $plugin, 1 );
0ef52a96 762
763 eval { $plugin->import };
764 $class->mk_classdata($name);
765 my $obj;
766 eval { $obj = $plugin->new(@args) };
767
768 if ($@) {
769 Catalyst::Exception->throw( message =>
770 qq/Couldn't instantiate instant plugin "$plugin", "$@"/ );
771 }
772
773 $class->$name($obj);
774 $class->log->debug(qq/Initialized instant plugin "$plugin" as "$name"/)
775 if $class->debug;
776}
777
b5ecfcf0 778=head2 MyApp->setup
fbcc39ad 779
e7f1cf73 780Initializes the dispatcher and engine, loads any plugins, and loads the
ae1e6b59 781model, view, and controller components. You may also specify an array
782of plugins to load here, if you choose to not load them in the C<use
783Catalyst> line.
fbcc39ad 784
0ef52a96 785 MyApp->setup;
786 MyApp->setup( qw/-Debug/ );
fbcc39ad 787
788=cut
789
790sub setup {
0319a12c 791 my ( $class, @arguments ) = @_;
599b5295 792
5168a5fc 793 $class->log->warn("Running setup twice is not a good idea.")
794 if ( $class->setup_finished );
795
fbcc39ad 796 unless ( $class->isa('Catalyst') ) {
953b0e15 797
fbcc39ad 798 Catalyst::Exception->throw(
799 message => qq/'$class' does not inherit from Catalyst/ );
1c99e125 800 }
0319a12c 801
fbcc39ad 802 if ( $class->arguments ) {
803 @arguments = ( @arguments, @{ $class->arguments } );
804 }
805
806 # Process options
807 my $flags = {};
808
809 foreach (@arguments) {
810
811 if (/^-Debug$/) {
812 $flags->{log} =
813 ( $flags->{log} ) ? 'debug,' . $flags->{log} : 'debug';
814 }
815 elsif (/^-(\w+)=?(.*)$/) {
816 $flags->{ lc $1 } = $2;
817 }
818 else {
819 push @{ $flags->{plugins} }, $_;
820 }
821 }
822
99f187d6 823 $class->setup_home( delete $flags->{home} );
824
fbcc39ad 825 $class->setup_log( delete $flags->{log} );
826 $class->setup_plugins( delete $flags->{plugins} );
827 $class->setup_dispatcher( delete $flags->{dispatcher} );
828 $class->setup_engine( delete $flags->{engine} );
dc5f035e 829 $class->setup_stats( delete $flags->{stats} );
fbcc39ad 830
831 for my $flag ( sort keys %{$flags} ) {
832
833 if ( my $code = $class->can( 'setup_' . $flag ) ) {
834 &$code( $class, delete $flags->{$flag} );
835 }
836 else {
837 $class->log->warn(qq/Unknown flag "$flag"/);
838 }
839 }
840
0eb4af72 841 eval { require Catalyst::Devel; };
842 if( !$@ && $ENV{CATALYST_SCRIPT_GEN} && ( $ENV{CATALYST_SCRIPT_GEN} < $Catalyst::Devel::CATALYST_SCRIPT_GEN ) ) {
843 $class->log->warn(<<"EOF");
4ff0d824 844You are running an old script!
845
34a83d89 846 Please update by running (this will overwrite existing files):
847 catalyst.pl -force -scripts $class
848
849 or (this will not overwrite existing files):
850 catalyst.pl -scripts $class
1cf0345b 851
4ff0d824 852EOF
0eb4af72 853 }
854
fbcc39ad 855 if ( $class->debug ) {
6601f2ad 856 my @plugins = map { "$_ " . ( $_->VERSION || '' ) } $class->registered_plugins;
fbcc39ad 857
858 if (@plugins) {
34d28dfd 859 my $t = Text::SimpleTable->new(74);
8c113188 860 $t->row($_) for @plugins;
1cf0345b 861 $class->log->debug( "Loaded plugins:\n" . $t->draw . "\n" );
fbcc39ad 862 }
863
864 my $dispatcher = $class->dispatcher;
865 my $engine = $class->engine;
866 my $home = $class->config->{home};
867
868 $class->log->debug(qq/Loaded dispatcher "$dispatcher"/);
869 $class->log->debug(qq/Loaded engine "$engine"/);
870
871 $home
872 ? ( -d $home )
873 ? $class->log->debug(qq/Found home "$home"/)
874 : $class->log->debug(qq/Home "$home" doesn't exist/)
875 : $class->log->debug(q/Couldn't find home/);
876 }
877
878 # Call plugins setup
879 {
880 no warnings qw/redefine/;
881 local *setup = sub { };
882 $class->setup;
883 }
884
885 # Initialize our data structure
886 $class->components( {} );
887
888 $class->setup_components;
889
890 if ( $class->debug ) {
34d28dfd 891 my $t = Text::SimpleTable->new( [ 63, 'Class' ], [ 8, 'Type' ] );
684d10ed 892 for my $comp ( sort keys %{ $class->components } ) {
893 my $type = ref $class->components->{$comp} ? 'instance' : 'class';
894 $t->row( $comp, $type );
895 }
1cf0345b 896 $class->log->debug( "Loaded components:\n" . $t->draw . "\n" )
8c113188 897 if ( keys %{ $class->components } );
fbcc39ad 898 }
899
900 # Add our self to components, since we are also a component
901 $class->components->{$class} = $class;
902
903 $class->setup_actions;
904
905 if ( $class->debug ) {
906 my $name = $class->config->{name} || 'Application';
907 $class->log->info("$name powered by Catalyst $Catalyst::VERSION");
908 }
909 $class->log->_flush() if $class->log->can('_flush');
3643e890 910
911 $class->setup_finished(1);
fbcc39ad 912}
913
73664287 914=head2 $c->uri_for( $path, @args?, \%query_values? )
fbcc39ad 915
c50f595c 916Merges path with C<< $c->request->base >> for absolute URIs and with
917C<< $c->namespace >> for relative URIs, then returns a normalized L<URI>
86418559 918object. If any args are passed, they are added at the end of the path.
919If the last argument to C<uri_for> is a hash reference, it is assumed to
920contain GET parameter key/value pairs, which will be appended to the URI
921in standard fashion.
fbcc39ad 922
86418559 923Instead of C<$path>, you can also optionally pass a C<$action> object
924which will be resolved to a path using
147869cd 925C<< $c->dispatcher->uri_for_action >>; if the first element of
86418559 926C<@args> is an arrayref it is treated as a list of captures to be passed
927to C<uri_for_action>.
ea0e58d9 928
fbcc39ad 929=cut
930
931sub uri_for {
00e6a2b7 932 my ( $c, $path, @args ) = @_;
00e6a2b7 933
ea0e58d9 934 if ( Scalar::Util::blessed($path) ) { # action object
935 my $captures = ( scalar @args && ref $args[0] eq 'ARRAY'
936 ? shift(@args)
937 : [] );
938 $path = $c->dispatcher->uri_for_action($path, $captures);
939 return undef unless defined($path);
81e75875 940 $path = '/' if $path eq '';
ea0e58d9 941 }
942
51674a63 943 undef($path) if (defined $path && $path eq '');
00e6a2b7 944
97b58e17 945 my $params =
946 ( scalar @args && ref $args[$#args] eq 'HASH' ? pop @args : {} );
8327e2e2 947
cbb93105 948 carp "uri_for called with undef argument" if grep { ! defined $_ } @args;
51674a63 949 s/([^$URI::uric])/$URI::Escape::escapes{$1}/go for @args;
950
951 unshift(@args, $path);
952
953 unless (defined $path && $path =~ s!^/!!) { # in-place strip
954 my $namespace = $c->namespace;
955 if (defined $path) { # cheesy hack to handle path '../foo'
956 $namespace =~ s{(?:^|/)[^/]+$}{} while $args[0] =~ s{^\.\./}{};
6601f2ad 957 }
51674a63 958 unshift(@args, $namespace || '');
959 }
5789a3d8 960
189e2a51 961 # join args with '/', or a blank string
51674a63 962 my $args = join('/', grep { defined($_) } @args);
963 $args =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
964 $args =~ s!^/!!;
965 my $base = $c->req->base;
966 my $class = ref($base);
967 $base =~ s{(?<!/)$}{/};
968
969 my $query = '';
970
971 if (my @keys = keys %$params) {
972 # somewhat lifted from URI::_query's query_form
973 $query = '?'.join('&', map {
974 s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/go;
975 s/ /+/g;
976 my $key = $_;
977 my $val = $params->{$_};
978 $val = '' unless defined $val;
979 (map {
980 $_ = "$_";
981 utf8::encode( $_ );
982 # using the URI::Escape pattern here so utf8 chars survive
983 s/([^A-Za-z0-9\-_.!~*'() ])/$URI::Escape::escapes{$1}/go;
984 s/ /+/g;
985 "${key}=$_"; } ( ref $val eq 'ARRAY' ? @$val : $val ));
986 } @keys);
987 }
988
989 my $res = bless(\"${base}${args}${query}", $class);
d3e7a648 990 $res;
fbcc39ad 991}
992
b5ecfcf0 993=head2 $c->welcome_message
ab2374d3 994
995Returns the Catalyst welcome HTML page.
996
997=cut
998
999sub welcome_message {
bf1f2c60 1000 my $c = shift;
1001 my $name = $c->config->{name};
1002 my $logo = $c->uri_for('/static/images/catalyst_logo.png');
1003 my $prefix = Catalyst::Utils::appprefix( ref $c );
80cdbbff 1004 $c->response->content_type('text/html; charset=utf-8');
ab2374d3 1005 return <<"EOF";
80cdbbff 1006<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1007 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1008<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
ab2374d3 1009 <head>
85d9fce6 1010 <meta http-equiv="Content-Language" content="en" />
1011 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
ab2374d3 1012 <title>$name on Catalyst $VERSION</title>
1013 <style type="text/css">
1014 body {
ab2374d3 1015 color: #000;
1016 background-color: #eee;
1017 }
1018 div#content {
1019 width: 640px;
80cdbbff 1020 margin-left: auto;
1021 margin-right: auto;
ab2374d3 1022 margin-top: 10px;
1023 margin-bottom: 10px;
1024 text-align: left;
1025 background-color: #ccc;
1026 border: 1px solid #aaa;
ab2374d3 1027 }
d84c4dab 1028 p, h1, h2 {
ab2374d3 1029 margin-left: 20px;
1030 margin-right: 20px;
16215972 1031 font-family: verdana, tahoma, sans-serif;
ab2374d3 1032 }
d84c4dab 1033 a {
1034 font-family: verdana, tahoma, sans-serif;
1035 }
d114e033 1036 :link, :visited {
1037 text-decoration: none;
1038 color: #b00;
1039 border-bottom: 1px dotted #bbb;
1040 }
1041 :link:hover, :visited:hover {
d114e033 1042 color: #555;
1043 }
ab2374d3 1044 div#topbar {
1045 margin: 0px;
1046 }
3e82a295 1047 pre {
3e82a295 1048 margin: 10px;
1049 padding: 8px;
1050 }
ab2374d3 1051 div#answers {
1052 padding: 8px;
1053 margin: 10px;
d114e033 1054 background-color: #fff;
ab2374d3 1055 border: 1px solid #aaa;
ab2374d3 1056 }
1057 h1 {
33108eaf 1058 font-size: 0.9em;
1059 font-weight: normal;
ab2374d3 1060 text-align: center;
1061 }
1062 h2 {
1063 font-size: 1.0em;
1064 }
1065 p {
1066 font-size: 0.9em;
1067 }
ae7c5252 1068 p img {
1069 float: right;
1070 margin-left: 10px;
1071 }
9619f23c 1072 span#appname {
1073 font-weight: bold;
33108eaf 1074 font-size: 1.6em;
ab2374d3 1075 }
1076 </style>
1077 </head>
1078 <body>
1079 <div id="content">
1080 <div id="topbar">
9619f23c 1081 <h1><span id="appname">$name</span> on <a href="http://catalyst.perl.org">Catalyst</a>
d84c4dab 1082 $VERSION</h1>
ab2374d3 1083 </div>
1084 <div id="answers">
ae7c5252 1085 <p>
80cdbbff 1086 <img src="$logo" alt="Catalyst Logo" />
ae7c5252 1087 </p>
596aaffe 1088 <p>Welcome to the world of Catalyst.
f92fd545 1089 This <a href="http://en.wikipedia.org/wiki/MVC">MVC</a>
1090 framework will make web development something you had
60dd6e1d 1091 never expected it to be: Fun, rewarding, and quick.</p>
ab2374d3 1092 <h2>What to do now?</h2>
4b8cb778 1093 <p>That really depends on what <b>you</b> want to do.
ab2374d3 1094 We do, however, provide you with a few starting points.</p>
1095 <p>If you want to jump right into web development with Catalyst
596aaffe 1096 you might want want to start with a tutorial.</p>
b607f8a0 1097<pre>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Tutorial.pod">Catalyst::Manual::Tutorial</a></code>
596aaffe 1098</pre>
1099<p>Afterwards you can go on to check out a more complete look at our features.</p>
1100<pre>
b607f8a0 1101<code>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Intro.pod">Catalyst::Manual::Intro</a>
1102<!-- Something else should go here, but the Catalyst::Manual link seems unhelpful -->
1103</code></pre>
ab2374d3 1104 <h2>What to do next?</h2>
f5681c92 1105 <p>Next it's time to write an actual application. Use the
80cdbbff 1106 helper scripts to generate <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AController%3A%3A&amp;mode=all">controllers</a>,
60dd6e1d 1107 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AModel%3A%3A&amp;mode=all">models</a>, and
1108 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AView%3A%3A&amp;mode=all">views</a>;
bf1f2c60 1109 they can save you a lot of work.</p>
1110 <pre><code>script/${prefix}_create.pl -help</code></pre>
1111 <p>Also, be sure to check out the vast and growing
60dd6e1d 1112 collection of <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3APlugin%3A%3A&amp;mode=all">plugins for Catalyst on CPAN</a>;
bf1f2c60 1113 you are likely to find what you need there.
f5681c92 1114 </p>
1115
82245cc4 1116 <h2>Need help?</h2>
f5681c92 1117 <p>Catalyst has a very active community. Here are the main places to
1118 get in touch with us.</p>
16215972 1119 <ul>
1120 <li>
2b9a7d76 1121 <a href="http://dev.catalyst.perl.org">Wiki</a>
16215972 1122 </li>
1123 <li>
1124 <a href="http://lists.rawmode.org/mailman/listinfo/catalyst">Mailing-List</a>
1125 </li>
1126 <li>
4eaf7c88 1127 <a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
16215972 1128 </li>
1129 </ul>
ab2374d3 1130 <h2>In conclusion</h2>
4e7aa2ea 1131 <p>The Catalyst team hopes you will enjoy using Catalyst as much
f5681c92 1132 as we enjoyed making it. Please contact us if you have ideas
1133 for improvement or other feedback.</p>
ab2374d3 1134 </div>
1135 </div>
1136 </body>
1137</html>
1138EOF
1139}
1140
fbcc39ad 1141=head1 INTERNAL METHODS
1142
ae1e6b59 1143These methods are not meant to be used by end users.
1144
b5ecfcf0 1145=head2 $c->components
fbcc39ad 1146
e7f1cf73 1147Returns a hash of components.
fbcc39ad 1148
b5ecfcf0 1149=head2 $c->context_class
1f9cb7c1 1150
e7f1cf73 1151Returns or sets the context class.
1f9cb7c1 1152
b5ecfcf0 1153=head2 $c->counter
fbcc39ad 1154
ae1e6b59 1155Returns a hashref containing coderefs and execution counts (needed for
1156deep recursion detection).
fbcc39ad 1157
b5ecfcf0 1158=head2 $c->depth
fbcc39ad 1159
e7f1cf73 1160Returns the number of actions on the current internal execution stack.
fbcc39ad 1161
b5ecfcf0 1162=head2 $c->dispatch
fbcc39ad 1163
e7f1cf73 1164Dispatches a request to actions.
fbcc39ad 1165
1166=cut
1167
1168sub dispatch { my $c = shift; $c->dispatcher->dispatch( $c, @_ ) }
1169
b5ecfcf0 1170=head2 $c->dispatcher_class
1f9cb7c1 1171
e7f1cf73 1172Returns or sets the dispatcher class.
1f9cb7c1 1173
b5ecfcf0 1174=head2 $c->dump_these
7f92deef 1175
ae1e6b59 1176Returns a list of 2-element array references (name, structure) pairs
1177that will be dumped on the error page in debug mode.
7f92deef 1178
1179=cut
1180
1181sub dump_these {
1182 my $c = shift;
052a2d89 1183 [ Request => $c->req ],
1184 [ Response => $c->res ],
1185 [ Stash => $c->stash ],
1186 [ Config => $c->config ];
7f92deef 1187}
1188
b5ecfcf0 1189=head2 $c->engine_class
1f9cb7c1 1190
e7f1cf73 1191Returns or sets the engine class.
1f9cb7c1 1192
b5ecfcf0 1193=head2 $c->execute( $class, $coderef )
fbcc39ad 1194
0ef52a96 1195Execute a coderef in given class and catch exceptions. Errors are available
1196via $c->error.
fbcc39ad 1197
1198=cut
1199
1200sub execute {
1201 my ( $c, $class, $code ) = @_;
858828dd 1202 $class = $c->component($class) || $class;
fbcc39ad 1203 $c->state(0);
a0eca838 1204
197bd788 1205 if ( $c->depth >= $RECURSION ) {
1627551a 1206 my $action = "$code";
91d08727 1207 $action = "/$action" unless $action =~ /->/;
1627551a 1208 my $error = qq/Deep recursion detected calling "$action"/;
1209 $c->log->error($error);
1210 $c->error($error);
1211 $c->state(0);
1212 return $c->state;
1213 }
1214
dc5f035e 1215 my $stats_info = $c->_stats_start_execute( $code ) if $c->use_stats;
22247e54 1216
8767c5a3 1217 push( @{ $c->stack }, $code );
7a7d7af5 1218
245ae014 1219 eval { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) };
22247e54 1220
dc5f035e 1221 $c->_stats_finish_execute( $stats_info ) if $c->use_stats and $stats_info;
7a7d7af5 1222
a6724a82 1223 my $last = pop( @{ $c->stack } );
fbcc39ad 1224
1225 if ( my $error = $@ ) {
88879e92 1226 if ( !ref($error) and $error eq $DETACH ) { die $DETACH if $c->depth > 1 }
fbcc39ad 1227 else {
1228 unless ( ref $error ) {
91d08727 1229 no warnings 'uninitialized';
fbcc39ad 1230 chomp $error;
f59def82 1231 my $class = $last->class;
1232 my $name = $last->name;
1233 $error = qq/Caught exception in $class->$name "$error"/;
fbcc39ad 1234 }
fbcc39ad 1235 $c->error($error);
1236 $c->state(0);
1237 }
1238 }
1239 return $c->state;
1240}
1241
7a7d7af5 1242sub _stats_start_execute {
1243 my ( $c, $code ) = @_;
1244
a6724a82 1245 return if ( ( $code->name =~ /^_.*/ )
1246 && ( !$c->config->{show_internal_actions} ) );
7a7d7af5 1247
7a7d7af5 1248 $c->counter->{"$code"}++;
1249
a6724a82 1250 my $action = "$code";
1251 $action = "/$action" unless $action =~ /->/;
1252
7a7d7af5 1253 # determine if the call was the result of a forward
1254 # this is done by walking up the call stack and looking for a calling
1255 # sub of Catalyst::forward before the eval
1256 my $callsub = q{};
1257 for my $index ( 2 .. 11 ) {
1258 last
1259 if ( ( caller($index) )[0] eq 'Catalyst'
1260 && ( caller($index) )[3] eq '(eval)' );
1261
1262 if ( ( caller($index) )[3] =~ /forward$/ ) {
1263 $callsub = ( caller($index) )[3];
1264 $action = "-> $action";
1265 last;
1266 }
1267 }
1268
74efc144 1269 my $uid = "$code" . $c->counter->{"$code"};
1270
a6724a82 1271 # is this a root-level call or a forwarded call?
1272 if ( $callsub =~ /forward$/ ) {
1273
1274 # forward, locate the caller
1275 if ( my $parent = $c->stack->[-1] ) {
b01f0c69 1276 $c->stats->profile(begin => $action,
74efc144 1277 parent => "$parent" . $c->counter->{"$parent"},
1278 uid => $uid);
7a7d7af5 1279 }
1280 else {
1281
a6724a82 1282 # forward with no caller may come from a plugin
74efc144 1283 $c->stats->profile(begin => $action,
1284 uid => $uid);
7a7d7af5 1285 }
1286 }
a6724a82 1287 else {
b01f0c69 1288
a6724a82 1289 # root-level call
74efc144 1290 $c->stats->profile(begin => $action,
1291 uid => $uid);
a6724a82 1292 }
dc5f035e 1293 return $action;
7a7d7af5 1294
7a7d7af5 1295}
1296
1297sub _stats_finish_execute {
1298 my ( $c, $info ) = @_;
dc5f035e 1299 $c->stats->profile(end => $info);
7a7d7af5 1300}
1301
3d0d6d21 1302=head2 $c->_localize_fields( sub { }, \%keys );
1303
1304=cut
1305
1306sub _localize_fields {
1307 my ( $c, $localized, $code ) = ( @_ );
1308
1309 my $request = delete $localized->{request} || {};
1310 my $response = delete $localized->{response} || {};
1311
1312 local @{ $c }{ keys %$localized } = values %$localized;
1313 local @{ $c->request }{ keys %$request } = values %$request;
1314 local @{ $c->response }{ keys %$response } = values %$response;
1315
1316 $code->();
1317}
1318
b5ecfcf0 1319=head2 $c->finalize
fbcc39ad 1320
e7f1cf73 1321Finalizes the request.
fbcc39ad 1322
1323=cut
1324
1325sub finalize {
1326 my $c = shift;
1327
369c09bc 1328 for my $error ( @{ $c->error } ) {
1329 $c->log->error($error);
1330 }
1331
5050d7a7 1332 # Allow engine to handle finalize flow (for POE)
1333 if ( $c->engine->can('finalize') ) {
34d28dfd 1334 $c->engine->finalize($c);
fbcc39ad 1335 }
5050d7a7 1336 else {
fbcc39ad 1337
5050d7a7 1338 $c->finalize_uploads;
fbcc39ad 1339
5050d7a7 1340 # Error
1341 if ( $#{ $c->error } >= 0 ) {
1342 $c->finalize_error;
1343 }
1344
1345 $c->finalize_headers;
fbcc39ad 1346
5050d7a7 1347 # HEAD request
1348 if ( $c->request->method eq 'HEAD' ) {
1349 $c->response->body('');
1350 }
1351
1352 $c->finalize_body;
1353 }
908e3d9e 1354
596677b6 1355 if ($c->use_stats) {
1356 my $elapsed = sprintf '%f', $c->stats->elapsed;
12bf12c0 1357 my $av = $elapsed == 0 ? '??' : sprintf '%.3f', 1 / $elapsed;
908e3d9e 1358 $c->log->info(
dc5f035e 1359 "Request took ${elapsed}s ($av/s)\n" . $c->stats->report . "\n" );
908e3d9e 1360 }
fbcc39ad 1361
1362 return $c->response->status;
1363}
1364
b5ecfcf0 1365=head2 $c->finalize_body
fbcc39ad 1366
e7f1cf73 1367Finalizes body.
fbcc39ad 1368
1369=cut
1370
1371sub finalize_body { my $c = shift; $c->engine->finalize_body( $c, @_ ) }
1372
b5ecfcf0 1373=head2 $c->finalize_cookies
fbcc39ad 1374
e7f1cf73 1375Finalizes cookies.
fbcc39ad 1376
1377=cut
1378
147821ea 1379sub finalize_cookies { my $c = shift; $c->engine->finalize_cookies( $c, @_ ) }
fbcc39ad 1380
b5ecfcf0 1381=head2 $c->finalize_error
fbcc39ad 1382
e7f1cf73 1383Finalizes error.
fbcc39ad 1384
1385=cut
1386
1387sub finalize_error { my $c = shift; $c->engine->finalize_error( $c, @_ ) }
1388
b5ecfcf0 1389=head2 $c->finalize_headers
fbcc39ad 1390
e7f1cf73 1391Finalizes headers.
fbcc39ad 1392
1393=cut
1394
1395sub finalize_headers {
1396 my $c = shift;
1397
1398 # Check if we already finalized headers
1399 return if $c->response->{_finalized_headers};
1400
1401 # Handle redirects
1402 if ( my $location = $c->response->redirect ) {
1403 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
1404 $c->response->header( Location => $location );
39655cdc 1405
1406 if ( !$c->response->body ) {
1407 # Add a default body if none is already present
1408 $c->response->body(
e422816e 1409 qq{<html><body><p>This item has moved <a href="$location">here</a>.</p></body></html>}
39655cdc 1410 );
1411 }
fbcc39ad 1412 }
1413
1414 # Content-Length
1415 if ( $c->response->body && !$c->response->content_length ) {
775878ac 1416
8f62c91a 1417 # get the length from a filehandle
197bd788 1418 if ( blessed( $c->response->body ) && $c->response->body->can('read') )
1419 {
3b6a1db1 1420 my $stat = stat $c->response->body;
1421 if ( $stat && $stat->size > 0 ) {
8f62c91a 1422 $c->response->content_length( $stat->size );
1423 }
1424 else {
775878ac 1425 $c->log->warn('Serving filehandle without a content-length');
8f62c91a 1426 }
1427 }
1428 else {
775878ac 1429 $c->response->content_length( bytes::length( $c->response->body ) );
8f62c91a 1430 }
fbcc39ad 1431 }
1432
1433 # Errors
1434 if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
1435 $c->response->headers->remove_header("Content-Length");
1436 $c->response->body('');
1437 }
1438
1439 $c->finalize_cookies;
1440
1441 $c->engine->finalize_headers( $c, @_ );
1442
1443 # Done
1444 $c->response->{_finalized_headers} = 1;
1445}
1446
b5ecfcf0 1447=head2 $c->finalize_output
fbcc39ad 1448
1449An alias for finalize_body.
1450
b5ecfcf0 1451=head2 $c->finalize_read
fbcc39ad 1452
e7f1cf73 1453Finalizes the input after reading is complete.
fbcc39ad 1454
1455=cut
1456
1457sub finalize_read { my $c = shift; $c->engine->finalize_read( $c, @_ ) }
1458
b5ecfcf0 1459=head2 $c->finalize_uploads
fbcc39ad 1460
ae1e6b59 1461Finalizes uploads. Cleans up any temporary files.
fbcc39ad 1462
1463=cut
1464
1465sub finalize_uploads { my $c = shift; $c->engine->finalize_uploads( $c, @_ ) }
1466
b5ecfcf0 1467=head2 $c->get_action( $action, $namespace )
fbcc39ad 1468
e7f1cf73 1469Gets an action in a given namespace.
fbcc39ad 1470
1471=cut
1472
684d10ed 1473sub get_action { my $c = shift; $c->dispatcher->get_action(@_) }
fbcc39ad 1474
b5ecfcf0 1475=head2 $c->get_actions( $action, $namespace )
a9dc674c 1476
ae1e6b59 1477Gets all actions of a given name in a namespace and all parent
1478namespaces.
a9dc674c 1479
1480=cut
1481
1482sub get_actions { my $c = shift; $c->dispatcher->get_actions( $c, @_ ) }
1483
f7b672ef 1484=head2 $c->handle_request( $class, @arguments )
fbcc39ad 1485
e7f1cf73 1486Called to handle each HTTP request.
fbcc39ad 1487
1488=cut
1489
1490sub handle_request {
1491 my ( $class, @arguments ) = @_;
1492
1493 # Always expect worst case!
1494 my $status = -1;
1495 eval {
dea1884f 1496 if ($class->debug) {
908e3d9e 1497 my $secs = time - $START || 1;
1498 my $av = sprintf '%.3f', $COUNT / $secs;
1499 my $time = localtime time;
1500 $class->log->info("*** Request $COUNT ($av/s) [$$] [$time] ***");
dea1884f 1501 }
908e3d9e 1502
1503 my $c = $class->prepare(@arguments);
1504 $c->dispatch;
1505 $status = $c->finalize;
fbcc39ad 1506 };
1507
1508 if ( my $error = $@ ) {
1509 chomp $error;
1510 $class->log->error(qq/Caught exception in engine "$error"/);
1511 }
1512
1513 $COUNT++;
1514 $class->log->_flush() if $class->log->can('_flush');
1515 return $status;
1516}
1517
b5ecfcf0 1518=head2 $c->prepare( @arguments )
fbcc39ad 1519
ae1e6b59 1520Creates a Catalyst context from an engine-specific request (Apache, CGI,
1521etc.).
fbcc39ad 1522
1523=cut
1524
1525sub prepare {
1526 my ( $class, @arguments ) = @_;
1527
3cec521a 1528 $class->context_class( ref $class || $class ) unless $class->context_class;
1529 my $c = $class->context_class->new(
1530 {
1531 counter => {},
28591cd7 1532 stack => [],
3cec521a 1533 request => $class->request_class->new(
1534 {
1535 arguments => [],
1536 body_parameters => {},
1537 cookies => {},
1538 headers => HTTP::Headers->new,
1539 parameters => {},
1540 query_parameters => {},
1541 secure => 0,
2982e768 1542 captures => [],
3cec521a 1543 uploads => {}
1544 }
1545 ),
1546 response => $class->response_class->new(
1547 {
1548 body => '',
1549 cookies => {},
1550 headers => HTTP::Headers->new(),
1551 status => 200
1552 }
1553 ),
1554 stash => {},
1555 state => 0
1556 }
1557 );
fbcc39ad 1558
dc5f035e 1559 $c->stats($class->stats_class->new)->enable($c->use_stats);
908e3d9e 1560 if ( $c->debug ) {
908e3d9e 1561 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
1562 }
1563
fbcc39ad 1564 # For on-demand data
1565 $c->request->{_context} = $c;
1566 $c->response->{_context} = $c;
1567 weaken( $c->request->{_context} );
1568 weaken( $c->response->{_context} );
1569
5050d7a7 1570 # Allow engine to direct the prepare flow (for POE)
1571 if ( $c->engine->can('prepare') ) {
1572 $c->engine->prepare( $c, @arguments );
1573 }
1574 else {
1575 $c->prepare_request(@arguments);
1576 $c->prepare_connection;
1577 $c->prepare_query_parameters;
1578 $c->prepare_headers;
1579 $c->prepare_cookies;
1580 $c->prepare_path;
1581
878b821c 1582 # Prepare the body for reading, either by prepare_body
1583 # or the user, if they are using $c->read
1584 $c->prepare_read;
1585
1586 # Parse the body unless the user wants it on-demand
1587 unless ( $c->config->{parse_on_demand} ) {
1588 $c->prepare_body;
1589 }
5050d7a7 1590 }
fbcc39ad 1591
fbcc39ad 1592 my $method = $c->req->method || '';
34d28dfd 1593 my $path = $c->req->path || '/';
fbcc39ad 1594 my $address = $c->req->address || '';
1595
e3a13771 1596 $c->log->debug(qq/"$method" request for "$path" from "$address"/)
fbcc39ad 1597 if $c->debug;
1598
e3a13771 1599 $c->prepare_action;
1600
fbcc39ad 1601 return $c;
1602}
1603
b5ecfcf0 1604=head2 $c->prepare_action
fbcc39ad 1605
b4b01a8a 1606Prepares action. See L<Catalyst::Dispatcher>.
fbcc39ad 1607
1608=cut
1609
1610sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
1611
b5ecfcf0 1612=head2 $c->prepare_body
fbcc39ad 1613
e7f1cf73 1614Prepares message body.
fbcc39ad 1615
1616=cut
1617
1618sub prepare_body {
1619 my $c = shift;
1620
1621 # Do we run for the first time?
1622 return if defined $c->request->{_body};
1623
1624 # Initialize on-demand data
1625 $c->engine->prepare_body( $c, @_ );
1626 $c->prepare_parameters;
1627 $c->prepare_uploads;
1628
1629 if ( $c->debug && keys %{ $c->req->body_parameters } ) {
34d28dfd 1630 my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ 36, 'Value' ] );
fbcc39ad 1631 for my $key ( sort keys %{ $c->req->body_parameters } ) {
1632 my $param = $c->req->body_parameters->{$key};
1633 my $value = defined($param) ? $param : '';
8c113188 1634 $t->row( $key,
fbcc39ad 1635 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1636 }
1637 $c->log->debug( "Body Parameters are:\n" . $t->draw );
1638 }
1639}
1640
b5ecfcf0 1641=head2 $c->prepare_body_chunk( $chunk )
4bd82c41 1642
e7f1cf73 1643Prepares a chunk of data before sending it to L<HTTP::Body>.
4bd82c41 1644
b4b01a8a 1645See L<Catalyst::Engine>.
1646
4bd82c41 1647=cut
1648
4f5ebacd 1649sub prepare_body_chunk {
1650 my $c = shift;
4bd82c41 1651 $c->engine->prepare_body_chunk( $c, @_ );
1652}
1653
b5ecfcf0 1654=head2 $c->prepare_body_parameters
fbcc39ad 1655
e7f1cf73 1656Prepares body parameters.
fbcc39ad 1657
1658=cut
1659
1660sub prepare_body_parameters {
1661 my $c = shift;
1662 $c->engine->prepare_body_parameters( $c, @_ );
1663}
1664
b5ecfcf0 1665=head2 $c->prepare_connection
fbcc39ad 1666
e7f1cf73 1667Prepares connection.
fbcc39ad 1668
1669=cut
1670
1671sub prepare_connection {
1672 my $c = shift;
1673 $c->engine->prepare_connection( $c, @_ );
1674}
1675
b5ecfcf0 1676=head2 $c->prepare_cookies
fbcc39ad 1677
e7f1cf73 1678Prepares cookies.
fbcc39ad 1679
1680=cut
1681
1682sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
1683
b5ecfcf0 1684=head2 $c->prepare_headers
fbcc39ad 1685
e7f1cf73 1686Prepares headers.
fbcc39ad 1687
1688=cut
1689
1690sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
1691
b5ecfcf0 1692=head2 $c->prepare_parameters
fbcc39ad 1693
e7f1cf73 1694Prepares parameters.
fbcc39ad 1695
1696=cut
1697
1698sub prepare_parameters {
1699 my $c = shift;
1700 $c->prepare_body_parameters;
1701 $c->engine->prepare_parameters( $c, @_ );
1702}
1703
b5ecfcf0 1704=head2 $c->prepare_path
fbcc39ad 1705
e7f1cf73 1706Prepares path and base.
fbcc39ad 1707
1708=cut
1709
1710sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
1711
b5ecfcf0 1712=head2 $c->prepare_query_parameters
fbcc39ad 1713
e7f1cf73 1714Prepares query parameters.
fbcc39ad 1715
1716=cut
1717
1718sub prepare_query_parameters {
1719 my $c = shift;
1720
1721 $c->engine->prepare_query_parameters( $c, @_ );
1722
1723 if ( $c->debug && keys %{ $c->request->query_parameters } ) {
34d28dfd 1724 my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ 36, 'Value' ] );
fbcc39ad 1725 for my $key ( sort keys %{ $c->req->query_parameters } ) {
1726 my $param = $c->req->query_parameters->{$key};
1727 my $value = defined($param) ? $param : '';
8c113188 1728 $t->row( $key,
fbcc39ad 1729 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1730 }
1731 $c->log->debug( "Query Parameters are:\n" . $t->draw );
1732 }
1733}
1734
b5ecfcf0 1735=head2 $c->prepare_read
fbcc39ad 1736
e7f1cf73 1737Prepares the input for reading.
fbcc39ad 1738
1739=cut
1740
1741sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
1742
b5ecfcf0 1743=head2 $c->prepare_request
fbcc39ad 1744
e7f1cf73 1745Prepares the engine request.
fbcc39ad 1746
1747=cut
1748
1749sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
1750
b5ecfcf0 1751=head2 $c->prepare_uploads
fbcc39ad 1752
e7f1cf73 1753Prepares uploads.
fbcc39ad 1754
1755=cut
1756
1757sub prepare_uploads {
1758 my $c = shift;
1759
1760 $c->engine->prepare_uploads( $c, @_ );
1761
1762 if ( $c->debug && keys %{ $c->request->uploads } ) {
8c113188 1763 my $t = Text::SimpleTable->new(
34d28dfd 1764 [ 12, 'Parameter' ],
1765 [ 26, 'Filename' ],
8c113188 1766 [ 18, 'Type' ],
1767 [ 9, 'Size' ]
1768 );
fbcc39ad 1769 for my $key ( sort keys %{ $c->request->uploads } ) {
1770 my $upload = $c->request->uploads->{$key};
1771 for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
8c113188 1772 $t->row( $key, $u->filename, $u->type, $u->size );
fbcc39ad 1773 }
1774 }
1775 $c->log->debug( "File Uploads are:\n" . $t->draw );
1776 }
1777}
1778
b5ecfcf0 1779=head2 $c->prepare_write
fbcc39ad 1780
e7f1cf73 1781Prepares the output for writing.
fbcc39ad 1782
1783=cut
1784
1785sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
1786
b5ecfcf0 1787=head2 $c->request_class
1f9cb7c1 1788
e7f1cf73 1789Returns or sets the request class.
1f9cb7c1 1790
b5ecfcf0 1791=head2 $c->response_class
1f9cb7c1 1792
e7f1cf73 1793Returns or sets the response class.
1f9cb7c1 1794
b5ecfcf0 1795=head2 $c->read( [$maxlength] )
fbcc39ad 1796
ae1e6b59 1797Reads a chunk of data from the request body. This method is designed to
1798be used in a while loop, reading C<$maxlength> bytes on every call.
1799C<$maxlength> defaults to the size of the request if not specified.
fbcc39ad 1800
cc95842f 1801You have to set C<< MyApp->config->{parse_on_demand} >> to use this
ae1e6b59 1802directly.
fbcc39ad 1803
878b821c 1804Warning: If you use read(), Catalyst will not process the body,
1805so you will not be able to access POST parameters or file uploads via
1806$c->request. You must handle all body parsing yourself.
1807
fbcc39ad 1808=cut
1809
1810sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
1811
b5ecfcf0 1812=head2 $c->run
fbcc39ad 1813
1814Starts the engine.
1815
1816=cut
1817
1818sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
1819
b5ecfcf0 1820=head2 $c->set_action( $action, $code, $namespace, $attrs )
fbcc39ad 1821
e7f1cf73 1822Sets an action in a given namespace.
fbcc39ad 1823
1824=cut
1825
1826sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
1827
b5ecfcf0 1828=head2 $c->setup_actions($component)
fbcc39ad 1829
e7f1cf73 1830Sets up actions for a component.
fbcc39ad 1831
1832=cut
1833
1834sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
1835
b5ecfcf0 1836=head2 $c->setup_components
fbcc39ad 1837
86418559 1838Sets up components. Specify a C<setup_components> config option to pass
1839additional options directly to L<Module::Pluggable>. To add additional
1840search paths, specify a key named C<search_extra> as an array
1841reference. Items in the array beginning with C<::> will have the
18de900e 1842application class name prepended to them.
fbcc39ad 1843
1844=cut
1845
1846sub setup_components {
1847 my $class = shift;
1848
18de900e 1849 my @paths = qw( ::Controller ::C ::Model ::M ::View ::V );
1850 my $config = $class->config->{ setup_components };
1851 my $extra = delete $config->{ search_extra } || [];
1852
1853 push @paths, @$extra;
1854
364d7324 1855 my $locator = Module::Pluggable::Object->new(
18de900e 1856 search_path => [ map { s/^(?=::)/$class/; $_; } @paths ],
1857 %$config
364d7324 1858 );
b94b200c 1859
1860 my @comps = sort { length $a <=> length $b } $locator->plugins;
1861 my %comps = map { $_ => 1 } @comps;
364d7324 1862
b94b200c 1863 for my $component ( @comps ) {
dd91afb5 1864
1865 # We pass ignore_loaded here so that overlay files for (e.g.)
1866 # Model::DBI::Schema sub-classes are loaded - if it's in @comps
1867 # we know M::P::O found a file on disk so this is safe
1868
d06051f7 1869 Catalyst::Utils::ensure_class_loaded( $component, { ignore_loaded => 1 } );
364d7324 1870
1871 my $module = $class->setup_component( $component );
1872 my %modules = (
1873 $component => $module,
1874 map {
1875 $_ => $class->setup_component( $_ )
b94b200c 1876 } grep {
1877 not exists $comps{$_}
364d7324 1878 } Devel::InnerPackage::list_packages( $component )
1879 );
1880
1881 for my $key ( keys %modules ) {
1882 $class->components->{ $key } = $modules{ $key };
fbcc39ad 1883 }
364d7324 1884 }
1885}
fbcc39ad 1886
364d7324 1887=head2 $c->setup_component
fbcc39ad 1888
364d7324 1889=cut
fbcc39ad 1890
364d7324 1891sub setup_component {
1892 my( $class, $component ) = @_;
fbcc39ad 1893
364d7324 1894 unless ( $component->can( 'COMPONENT' ) ) {
1895 return $component;
1896 }
fbcc39ad 1897
364d7324 1898 my $suffix = Catalyst::Utils::class2classsuffix( $component );
1899 my $config = $class->config->{ $suffix } || {};
fbcc39ad 1900
364d7324 1901 my $instance = eval { $component->COMPONENT( $class, $config ); };
fbcc39ad 1902
1903 if ( my $error = $@ ) {
fbcc39ad 1904 chomp $error;
fbcc39ad 1905 Catalyst::Exception->throw(
364d7324 1906 message => qq/Couldn't instantiate component "$component", "$error"/
1907 );
fbcc39ad 1908 }
1909
364d7324 1910 Catalyst::Exception->throw(
1911 message =>
1912 qq/Couldn't instantiate component "$component", "COMPONENT() didn't return an object-like value"/
1913 ) unless eval { $instance->can( 'can' ) };
1914
1915 return $instance;
fbcc39ad 1916}
1917
b5ecfcf0 1918=head2 $c->setup_dispatcher
fbcc39ad 1919
ae1e6b59 1920Sets up dispatcher.
1921
fbcc39ad 1922=cut
1923
1924sub setup_dispatcher {
1925 my ( $class, $dispatcher ) = @_;
1926
1927 if ($dispatcher) {
1928 $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
1929 }
1930
cb69249e 1931 if ( my $env = Catalyst::Utils::env_value( $class, 'DISPATCHER' ) ) {
1932 $dispatcher = 'Catalyst::Dispatcher::' . $env;
fbcc39ad 1933 }
1934
1935 unless ($dispatcher) {
cb0354c6 1936 $dispatcher = $class->dispatcher_class;
fbcc39ad 1937 }
1938
1e514a51 1939 unless (Class::Inspector->loaded($dispatcher)) {
1940 require Class::Inspector->filename($dispatcher);
fbcc39ad 1941 }
1942
1943 # dispatcher instance
1944 $class->dispatcher( $dispatcher->new );
1945}
1946
b5ecfcf0 1947=head2 $c->setup_engine
fbcc39ad 1948
ae1e6b59 1949Sets up engine.
1950
fbcc39ad 1951=cut
1952
1953sub setup_engine {
1954 my ( $class, $engine ) = @_;
1955
1956 if ($engine) {
1957 $engine = 'Catalyst::Engine::' . $engine;
1958 }
1959
cb69249e 1960 if ( my $env = Catalyst::Utils::env_value( $class, 'ENGINE' ) ) {
1961 $engine = 'Catalyst::Engine::' . $env;
fbcc39ad 1962 }
1963
9b0a3e0f 1964 if ( $ENV{MOD_PERL} ) {
fbcc39ad 1965
1966 # create the apache method
1967 {
1968 no strict 'refs';
1969 *{"$class\::apache"} = sub { shift->engine->apache };
1970 }
1971
1972 my ( $software, $version ) =
1973 $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
1974
1975 $version =~ s/_//g;
1976 $version =~ s/(\.[^.]+)\./$1/g;
1977
1978 if ( $software eq 'mod_perl' ) {
1979
9b0a3e0f 1980 if ( !$engine ) {
22247e54 1981
9b0a3e0f 1982 if ( $version >= 1.99922 ) {
1983 $engine = 'Catalyst::Engine::Apache2::MP20';
1984 }
22247e54 1985
9b0a3e0f 1986 elsif ( $version >= 1.9901 ) {
1987 $engine = 'Catalyst::Engine::Apache2::MP19';
1988 }
22247e54 1989
9b0a3e0f 1990 elsif ( $version >= 1.24 ) {
1991 $engine = 'Catalyst::Engine::Apache::MP13';
1992 }
22247e54 1993
9b0a3e0f 1994 else {
1995 Catalyst::Exception->throw( message =>
1996 qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
1997 }
fbcc39ad 1998
fbcc39ad 1999 }
2000
2001 # install the correct mod_perl handler
2002 if ( $version >= 1.9901 ) {
2003 *handler = sub : method {
2004 shift->handle_request(@_);
2005 };
2006 }
2007 else {
2008 *handler = sub ($$) { shift->handle_request(@_) };
2009 }
2010
2011 }
2012
2013 elsif ( $software eq 'Zeus-Perl' ) {
2014 $engine = 'Catalyst::Engine::Zeus';
2015 }
2016
2017 else {
2018 Catalyst::Exception->throw(
2019 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
2020 }
2021 }
2022
2023 unless ($engine) {
cb0354c6 2024 $engine = $class->engine_class;
fbcc39ad 2025 }
2026
1e514a51 2027 unless (Class::Inspector->loaded($engine)) {
2028 require Class::Inspector->filename($engine);
fbcc39ad 2029 }
0e7f5826 2030
d54484bf 2031 # check for old engines that are no longer compatible
2032 my $old_engine;
0e7f5826 2033 if ( $engine->isa('Catalyst::Engine::Apache')
2034 && !Catalyst::Engine::Apache->VERSION )
d54484bf 2035 {
2036 $old_engine = 1;
2037 }
0e7f5826 2038
d54484bf 2039 elsif ( $engine->isa('Catalyst::Engine::Server::Base')
0e7f5826 2040 && Catalyst::Engine::Server->VERSION le '0.02' )
d54484bf 2041 {
2042 $old_engine = 1;
2043 }
0e7f5826 2044
2045 elsif ($engine->isa('Catalyst::Engine::HTTP::POE')
2046 && $engine->VERSION eq '0.01' )
d54484bf 2047 {
2048 $old_engine = 1;
2049 }
0e7f5826 2050
2051 elsif ($engine->isa('Catalyst::Engine::Zeus')
2052 && $engine->VERSION eq '0.01' )
d54484bf 2053 {
2054 $old_engine = 1;
2055 }
fbcc39ad 2056
d54484bf 2057 if ($old_engine) {
2058 Catalyst::Exception->throw( message =>
0e7f5826 2059 qq/Engine "$engine" is not supported by this version of Catalyst/
d54484bf 2060 );
2061 }
0e7f5826 2062
fbcc39ad 2063 # engine instance
2064 $class->engine( $engine->new );
2065}
2066
b5ecfcf0 2067=head2 $c->setup_home
fbcc39ad 2068
ae1e6b59 2069Sets up the home directory.
2070
fbcc39ad 2071=cut
2072
2073sub setup_home {
2074 my ( $class, $home ) = @_;
2075
cb69249e 2076 if ( my $env = Catalyst::Utils::env_value( $class, 'HOME' ) ) {
2077 $home = $env;
fbcc39ad 2078 }
2079
2080 unless ($home) {
2081 $home = Catalyst::Utils::home($class);
2082 }
2083
2084 if ($home) {
2085 $class->config->{home} ||= $home;
a738ab68 2086 $class->config->{root} ||= Path::Class::Dir->new($home)->subdir('root');
fbcc39ad 2087 }
2088}
2089
b5ecfcf0 2090=head2 $c->setup_log
fbcc39ad 2091
ae1e6b59 2092Sets up log.
2093
fbcc39ad 2094=cut
2095
2096sub setup_log {
2097 my ( $class, $debug ) = @_;
2098
2099 unless ( $class->log ) {
2100 $class->log( Catalyst::Log->new );
2101 }
af3ff00e 2102
cb69249e 2103 my $env_debug = Catalyst::Utils::env_value( $class, 'DEBUG' );
2104 if ( defined($env_debug) ? $env_debug : $debug ) {
fbcc39ad 2105 no strict 'refs';
2106 *{"$class\::debug"} = sub { 1 };
2107 $class->log->debug('Debug messages enabled');
2108 }
2109}
2110
b5ecfcf0 2111=head2 $c->setup_plugins
fbcc39ad 2112
ae1e6b59 2113Sets up plugins.
2114
fbcc39ad 2115=cut
2116
dc5f035e 2117=head2 $c->setup_stats
2118
2119Sets up timing statistics class.
2120
2121=cut
2122
2123sub setup_stats {
2124 my ( $class, $stats ) = @_;
2125
2126 Catalyst::Utils::ensure_class_loaded($class->stats_class);
2127
2128 my $env = Catalyst::Utils::env_value( $class, 'STATS' );
2129 if ( defined($env) ? $env : ($stats || $class->debug ) ) {
b01f0c69 2130 no strict 'refs';
2131 *{"$class\::use_stats"} = sub { 1 };
2132 $class->log->debug('Statistics enabled');
dc5f035e 2133 }
2134}
2135
2136
836e1134 2137=head2 $c->registered_plugins
2138
2139Returns a sorted list of the plugins which have either been stated in the
2140import list or which have been added via C<< MyApp->plugin(@args); >>.
2141
2142If passed a given plugin name, it will report a boolean value indicating
2143whether or not that plugin is loaded. A fully qualified name is required if
2144the plugin name does not begin with C<Catalyst::Plugin::>.
2145
2146 if ($c->registered_plugins('Some::Plugin')) {
2147 ...
2148 }
2149
2150=cut
fbcc39ad 2151
836e1134 2152{
97b58e17 2153
2154 sub registered_plugins {
836e1134 2155 my $proto = shift;
197bd788 2156 return sort keys %{ $proto->_plugins } unless @_;
836e1134 2157 my $plugin = shift;
d0d4d785 2158 return 1 if exists $proto->_plugins->{$plugin};
2159 return exists $proto->_plugins->{"Catalyst::Plugin::$plugin"};
836e1134 2160 }
fbcc39ad 2161
836e1134 2162 sub _register_plugin {
2163 my ( $proto, $plugin, $instant ) = @_;
2164 my $class = ref $proto || $proto;
fbcc39ad 2165
dd91afb5 2166 # no ignore_loaded here, the plugin may already have been
2167 # defined in memory and we don't want to error on "no file" if so
2168
2169 Catalyst::Utils::ensure_class_loaded( $plugin );
fbcc39ad 2170
197bd788 2171 $proto->_plugins->{$plugin} = 1;
836e1134 2172 unless ($instant) {
fbcc39ad 2173 no strict 'refs';
2174 unshift @{"$class\::ISA"}, $plugin;
2175 }
836e1134 2176 return $class;
2177 }
2178
2179 sub setup_plugins {
2180 my ( $class, $plugins ) = @_;
2181
d0d4d785 2182 $class->_plugins( {} ) unless $class->_plugins;
836e1134 2183 $plugins ||= [];
2184 for my $plugin ( reverse @$plugins ) {
2185
2186 unless ( $plugin =~ s/\A\+// ) {
2187 $plugin = "Catalyst::Plugin::$plugin";
2188 }
2189
2190 $class->_register_plugin($plugin);
2191 }
fbcc39ad 2192 }
2193}
2194
b5ecfcf0 2195=head2 $c->stack
8767c5a3 2196
86418559 2197Returns an arrayref of the internal execution stack (actions that are
2198currently executing).
8767c5a3 2199
dc5f035e 2200=head2 $c->stats_class
2201
2202Returns or sets the stats (timing statistics) class.
2203
2204=head2 $c->use_stats
2205
2206Returns 1 when stats collection is enabled. Stats collection is enabled
2207when the -Stats options is set, debug is on or when the <MYAPP>_STATS
2208environment variable is set.
2209
2210Note that this is a static method, not an accessor and should be overloaded
2211by declaring "sub use_stats { 1 }" in your MyApp.pm, not by calling $c->use_stats(1).
2212
2213=cut
2214
2215sub use_stats { 0 }
2216
2217
b5ecfcf0 2218=head2 $c->write( $data )
fbcc39ad 2219
ae1e6b59 2220Writes $data to the output stream. When using this method directly, you
2221will need to manually set the C<Content-Length> header to the length of
2222your output data, if known.
fbcc39ad 2223
2224=cut
2225
4f5ebacd 2226sub write {
2227 my $c = shift;
2228
2229 # Finalize headers if someone manually writes output
2230 $c->finalize_headers;
2231
2232 return $c->engine->write( $c, @_ );
2233}
fbcc39ad 2234
b5ecfcf0 2235=head2 version
bf88a181 2236
ae1e6b59 2237Returns the Catalyst version number. Mostly useful for "powered by"
2238messages in template systems.
bf88a181 2239
2240=cut
2241
2242sub version { return $Catalyst::VERSION }
2243
b0bb11ec 2244=head1 INTERNAL ACTIONS
2245
ae1e6b59 2246Catalyst uses internal actions like C<_DISPATCH>, C<_BEGIN>, C<_AUTO>,
2247C<_ACTION>, and C<_END>. These are by default not shown in the private
3e705254 2248action table, but you can make them visible with a config parameter.
b0bb11ec 2249
2250 MyApp->config->{show_internal_actions} = 1;
2251
d2ee9760 2252=head1 CASE SENSITIVITY
2253
3e705254 2254By default Catalyst is not case sensitive, so C<MyApp::C::FOO::Bar> is
ae1e6b59 2255mapped to C</foo/bar>. You can activate case sensitivity with a config
3e705254 2256parameter.
d2ee9760 2257
2258 MyApp->config->{case_sensitive} = 1;
2259
3e705254 2260This causes C<MyApp::C::Foo::Bar> to map to C</Foo/Bar>.
fbcc39ad 2261
2262=head1 ON-DEMAND PARSER
2263
2264The request body is usually parsed at the beginning of a request,
878b821c 2265but if you want to handle input yourself, you can enable on-demand
2266parsing with a config parameter.
fbcc39ad 2267
2268 MyApp->config->{parse_on_demand} = 1;
2269
2270=head1 PROXY SUPPORT
2271
ae1e6b59 2272Many production servers operate using the common double-server approach,
2273with a lightweight frontend web server passing requests to a larger
2274backend server. An application running on the backend server must deal
2275with two problems: the remote user always appears to be C<127.0.0.1> and
2276the server's hostname will appear to be C<localhost> regardless of the
2277virtual host that the user connected through.
fbcc39ad 2278
ae1e6b59 2279Catalyst will automatically detect this situation when you are running
2280the frontend and backend servers on the same machine. The following
2281changes are made to the request.
fbcc39ad 2282
ae1e6b59 2283 $c->req->address is set to the user's real IP address, as read from
2284 the HTTP X-Forwarded-For header.
fbcc39ad 2285
ae1e6b59 2286 The host value for $c->req->base and $c->req->uri is set to the real
2287 host, as read from the HTTP X-Forwarded-Host header.
fbcc39ad 2288
3e705254 2289Obviously, your web server must support these headers for this to work.
fbcc39ad 2290
ae1e6b59 2291In a more complex server farm environment where you may have your
2292frontend proxy server(s) on different machines, you will need to set a
2293configuration option to tell Catalyst to read the proxied data from the
2294headers.
fbcc39ad 2295
2296 MyApp->config->{using_frontend_proxy} = 1;
2297
2298If you do not wish to use the proxy support at all, you may set:
d1a31ac6 2299
fbcc39ad 2300 MyApp->config->{ignore_frontend_proxy} = 1;
2301
2302=head1 THREAD SAFETY
2303
86418559 2304Catalyst has been tested under Apache 2's threading C<mpm_worker>,
2305C<mpm_winnt>, and the standalone forking HTTP server on Windows. We
2306believe the Catalyst core to be thread-safe.
fbcc39ad 2307
2308If you plan to operate in a threaded environment, remember that all other
3e705254 2309modules you are using must also be thread-safe. Some modules, most notably
2310L<DBD::SQLite>, are not thread-safe.
d1a31ac6 2311
3cb1db8c 2312=head1 SUPPORT
2313
2314IRC:
2315
4eaf7c88 2316 Join #catalyst on irc.perl.org.
3cb1db8c 2317
3e705254 2318Mailing Lists:
3cb1db8c 2319
2320 http://lists.rawmode.org/mailman/listinfo/catalyst
2321 http://lists.rawmode.org/mailman/listinfo/catalyst-dev
1985c30b 2322
432d507d 2323Web:
2324
2325 http://catalyst.perl.org
2326
0ef52a96 2327Wiki:
2328
2329 http://dev.catalyst.perl.org
2330
fc7ec1d9 2331=head1 SEE ALSO
2332
829a28ca 2333=head2 L<Task::Catalyst> - All you need to start with Catalyst
2334
b5ecfcf0 2335=head2 L<Catalyst::Manual> - The Catalyst Manual
e7f1cf73 2336
b5ecfcf0 2337=head2 L<Catalyst::Component>, L<Catalyst::Base> - Base classes for components
61b1e958 2338
b5ecfcf0 2339=head2 L<Catalyst::Engine> - Core engine
61b1e958 2340
b5ecfcf0 2341=head2 L<Catalyst::Log> - Log class.
61b1e958 2342
b5ecfcf0 2343=head2 L<Catalyst::Request> - Request object
61b1e958 2344
b5ecfcf0 2345=head2 L<Catalyst::Response> - Response object
61b1e958 2346
b5ecfcf0 2347=head2 L<Catalyst::Test> - The test suite.
fc7ec1d9 2348
15f0b5b7 2349=head1 CREDITS
fc7ec1d9 2350
15f0b5b7 2351Andy Grundman
2352
fbcc39ad 2353Andy Wardley
2354
33108eaf 2355Andreas Marienborg
2356
f4a57de4 2357Andrew Bramble
2358
15f0b5b7 2359Andrew Ford
2360
2361Andrew Ruthven
2362
fbcc39ad 2363Arthur Bergman
2364
15f0b5b7 2365Autrijus Tang
2366
0cf56dbc 2367Brian Cassidy
2368
6aaa1c60 2369Carl Franks
2370
15f0b5b7 2371Christian Hansen
2372
2373Christopher Hicks
2374
2375Dan Sully
2376
2377Danijel Milicevic
2378
0ef52a96 2379David Kamholz
2380
15f0b5b7 2381David Naughton
2382
61bef238 2383Drew Taylor
2384
15f0b5b7 2385Gary Ashton Jones
2386
2387Geoff Richards
2388
2389Jesse Sheidlower
2390
fbcc39ad 2391Jesse Vincent
2392
15f0b5b7 2393Jody Belka
2394
2395Johan Lindstrom
2396
2397Juan Camacho
2398
2399Leon Brocard
2400
2401Marcus Ramberg
2402
2403Matt S Trout
2404
71c3bcc3 2405Robert Sedlacek
2406
a727119f 2407Sam Vilain
2408
1cf1c56a 2409Sascha Kiefer
2410
9c71d51d 2411Sebastian Willert
2412
15f0b5b7 2413Tatsuhiko Miyagawa
fc7ec1d9 2414
51f0308d 2415Ulf Edvinsson
2416
bdcb95ef 2417Yuval Kogman
2418
51f0308d 2419=head1 AUTHOR
2420
2421Sebastian Riedel, C<sri@oook.de>
2422
fc7ec1d9 2423=head1 LICENSE
2424
9ce5ab63 2425This library is free software, you can redistribute it and/or modify it under
41ca9ba7 2426the same terms as Perl itself.
fc7ec1d9 2427
2428=cut
2429
24301;