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