The nginx bullshit can just die
[catagits/Catalyst-Runtime.git] / lib / Catalyst.pm
CommitLineData
fc7ec1d9 1package Catalyst;
2
a7caa492 3use Moose;
c98492ae 4use Moose::Meta::Class ();
60eabdaf 5extends 'Catalyst::Component';
2f5cb070 6use Moose::Util qw/find_meta/;
acca8cd5 7use B::Hooks::EndOfScope ();
a2f2cde9 8use Catalyst::Exception;
154ef0c8 9use Catalyst::Exception::Detach;
10use Catalyst::Exception::Go;
fc7ec1d9 11use Catalyst::Log;
fbcc39ad 12use Catalyst::Request;
13use Catalyst::Request::Upload;
14use Catalyst::Response;
812a28c9 15use Catalyst::Utils;
31375184 16use Catalyst::Controller;
62b6b631 17use Data::OptList;
364d7324 18use Devel::InnerPackage ();
c50f595c 19use Module::Pluggable::Object ();
c50f595c 20use Text::SimpleTable ();
21use Path::Class::Dir ();
22use Path::Class::File ();
c50f595c 23use URI ();
933ba403 24use URI::http;
25use URI::https;
5513038d 26use Tree::Simple qw/use_weak_refs/;
27use Tree::Simple::Visitor::FindByUID;
269408a4 28use Class::C3::Adopt::NEXT;
196f06d1 29use List::MoreUtils qw/uniq/;
261c571e 30use attributes;
532f0516 31use String::RewritePrefix;
b1ededd4 32use Catalyst::EngineLoader;
5789a3d8 33use utf8;
108201b5 34use Carp qw/croak carp shortmess/;
3640641e 35use Try::Tiny;
ad79be34 36use Plack::Middleware::Conditional;
37use Plack::Middleware::ReverseProxy;
fb99321f 38use Plack::Middleware::IIS6ScriptNameFix;
d3670826 39use Plack::Middleware::LighttpdScriptNameFix;
fc7ec1d9 40
2407a0ae 41BEGIN { require 5.008004; }
f63c03e4 42
8a440eba 43has stack => (is => 'ro', default => sub { [] });
6680c772 44has stash => (is => 'rw', default => sub { {} });
45has state => (is => 'rw', default => 0);
b6d4ee6e 46has stats => (is => 'rw');
47has action => (is => 'rw');
6680c772 48has counter => (is => 'rw', default => sub { {} });
49has request => (is => 'rw', default => sub { $_[0]->request_class->new({}) }, required => 1, lazy => 1);
50has response => (is => 'rw', default => sub { $_[0]->response_class->new({}) }, required => 1, lazy => 1);
e63bdf38 51has namespace => (is => 'rw');
52
8767c5a3 53sub depth { scalar @{ shift->stack || [] }; }
0fc2d522 54sub comp { shift->component(@_) }
6680c772 55
56sub req {
6680c772 57 my $self = shift; return $self->request(@_);
58}
59sub res {
6680c772 60 my $self = shift; return $self->response(@_);
61}
fbcc39ad 62
63# For backwards compatibility
0fc2d522 64sub finalize_output { shift->finalize_body(@_) };
fbcc39ad 65
66# For statistics
67our $COUNT = 1;
68our $START = time;
69our $RECURSION = 1000;
154ef0c8 70our $DETACH = Catalyst::Exception::Detach->new;
71our $GO = Catalyst::Exception::Go->new;
fbcc39ad 72
b6d4ee6e 73#I imagine that very few of these really need to be class variables. if any.
74#maybe we should just make them attributes with a default?
fbcc39ad 75__PACKAGE__->mk_classdata($_)
3cec521a 76 for qw/components arguments dispatcher engine log dispatcher_class
1e5dad00 77 engine_loader context_class request_class response_class stats_class
2e1f92a3 78 setup_finished _psgi_app loading_psgi_file/;
cb0354c6 79
3cec521a 80__PACKAGE__->dispatcher_class('Catalyst::Dispatcher');
3cec521a 81__PACKAGE__->request_class('Catalyst::Request');
82__PACKAGE__->response_class('Catalyst::Response');
dc5f035e 83__PACKAGE__->stats_class('Catalyst::Stats');
fbcc39ad 84
6415bb4d 85# Remember to update this in Catalyst::Runtime as well!
86
cfb5d52a 87our $VERSION = '5.89003';
189e2a51 88
fbcc39ad 89sub import {
90 my ( $class, @arguments ) = @_;
91
92 # We have to limit $class to Catalyst to avoid pushing Catalyst upon every
93 # callers @ISA.
94 return unless $class eq 'Catalyst';
95
84ff88cf 96 my $caller = caller();
97 return if $caller eq 'main';
269408a4 98
84ff88cf 99 my $meta = Moose::Meta::Class->initialize($caller);
fbcc39ad 100 unless ( $caller->isa('Catalyst') ) {
84ff88cf 101 my @superclasses = ($meta->superclasses, $class, 'Catalyst::Controller');
102 $meta->superclasses(@superclasses);
103 }
1cad29ab 104 # Avoid possible C3 issues if 'Moose::Object' is already on RHS of MyApp
105 $meta->superclasses(grep { $_ ne 'Moose::Object' } $meta->superclasses);
106
84ff88cf 107 unless( $meta->has_method('meta') ){
9c74923d 108 if ($Moose::VERSION >= 1.15) {
109 $meta->_add_meta_method('meta');
110 }
111 else {
112 $meta->add_method(meta => sub { Moose::Meta::Class->initialize("${caller}") } );
113 }
fbcc39ad 114 }
115
116 $caller->arguments( [@arguments] );
117 $caller->setup_home;
118}
fc7ec1d9 119
e6bfaa20 120sub _application { $_[0] }
121
fc7ec1d9 122=head1 NAME
123
124Catalyst - The Elegant MVC Web Application Framework
125
126=head1 SYNOPSIS
127
e7ad3b81 128See the L<Catalyst::Manual> distribution for comprehensive
129documentation and tutorials.
130
86418559 131 # Install Catalyst::Devel for helpers and other development tools
b4b01a8a 132 # use the helper to create a new application
91864987 133 catalyst.pl MyApp
fc7ec1d9 134
135 # add models, views, controllers
2f381252 136 script/myapp_create.pl model MyDatabase DBIC::Schema create=static dbi:SQLite:/path/to/db
cc95842f 137 script/myapp_create.pl view MyTemplate TT
0ef52a96 138 script/myapp_create.pl controller Search
fc7ec1d9 139
e7f1cf73 140 # built in testserver -- use -r to restart automatically on changes
cc95842f 141 # --help to see all available options
ae4e40a7 142 script/myapp_server.pl
fc7ec1d9 143
0ef52a96 144 # command line testing interface
ae4e40a7 145 script/myapp_test.pl /yada
fc7ec1d9 146
b4b01a8a 147 ### in lib/MyApp.pm
0ef52a96 148 use Catalyst qw/-Debug/; # include plugins here as well
62a6df80 149
85d9fce6 150 ### In lib/MyApp/Controller/Root.pm (autocreated)
0ef52a96 151 sub foo : Global { # called for /foo, /foo/1, /foo/1/2, etc.
ae1e6b59 152 my ( $self, $c, @args ) = @_; # args are qw/1 2/ for /foo/1/2
153 $c->stash->{template} = 'foo.tt'; # set the template
0ef52a96 154 # lookup something from db -- stash vars are passed to TT
62a6df80 155 $c->stash->{data} =
b4b01a8a 156 $c->model('Database::Foo')->search( { country => $args[0] } );
0ef52a96 157 if ( $c->req->params->{bar} ) { # access GET or POST parameters
158 $c->forward( 'bar' ); # process another action
62a6df80 159 # do something else after forward returns
0ef52a96 160 }
161 }
62a6df80 162
ae1e6b59 163 # The foo.tt TT template can use the stash data from the database
0ef52a96 164 [% WHILE (item = data.next) %]
165 [% item.foo %]
166 [% END %]
62a6df80 167
0ef52a96 168 # called for /bar/of/soap, /bar/of/soap/10, etc.
169 sub bar : Path('/bar/of/soap') { ... }
fc7ec1d9 170
ae1e6b59 171 # called for all actions, from the top-most controller downwards
62a6df80 172 sub auto : Private {
0ef52a96 173 my ( $self, $c ) = @_;
b4b01a8a 174 if ( !$c->user_exists ) { # Catalyst::Plugin::Authentication
0ef52a96 175 $c->res->redirect( '/login' ); # require login
176 return 0; # abort request and go immediately to end()
177 }
ae1e6b59 178 return 1; # success; carry on to next action
0ef52a96 179 }
62a6df80 180
ae1e6b59 181 # called after all actions are finished
62a6df80 182 sub end : Private {
5a8ed4fe 183 my ( $self, $c ) = @_;
0ef52a96 184 if ( scalar @{ $c->error } ) { ... } # handle errors
185 return if $c->res->body; # already have a response
186 $c->forward( 'MyApp::View::TT' ); # render template
5a8ed4fe 187 }
188
0ef52a96 189 ### in MyApp/Controller/Foo.pm
190 # called for /foo/bar
191 sub bar : Local { ... }
62a6df80 192
5400c668 193 # called for /blargle
194 sub blargle : Global { ... }
62a6df80 195
5400c668 196 # an index action matches /foo, but not /foo/1, etc.
197 sub index : Private { ... }
62a6df80 198
0ef52a96 199 ### in MyApp/Controller/Foo/Bar.pm
200 # called for /foo/bar/baz
201 sub baz : Local { ... }
62a6df80 202
b4b01a8a 203 # first Root auto is called, then Foo auto, then this
0ef52a96 204 sub auto : Private { ... }
62a6df80 205
0ef52a96 206 # powerful regular expression paths are also possible
207 sub details : Regex('^product/(\w+)/details$') {
5a8ed4fe 208 my ( $self, $c ) = @_;
0ef52a96 209 # extract the (\w+) from the URI
2982e768 210 my $product = $c->req->captures->[0];
5a8ed4fe 211 }
fc7ec1d9 212
0ef52a96 213See L<Catalyst::Manual::Intro> for additional information.
3803e98f 214
fc7ec1d9 215=head1 DESCRIPTION
216
86418559 217Catalyst is a modern framework for making web applications without the
218pain usually associated with this process. This document is a reference
219to the main Catalyst application. If you are a new user, we suggest you
220start with L<Catalyst::Manual::Tutorial> or L<Catalyst::Manual::Intro>.
fc7ec1d9 221
222See L<Catalyst::Manual> for more documentation.
223
ae1e6b59 224Catalyst plugins can be loaded by naming them as arguments to the "use
225Catalyst" statement. Omit the C<Catalyst::Plugin::> prefix from the
226plugin name, i.e., C<Catalyst::Plugin::My::Module> becomes
227C<My::Module>.
fc7ec1d9 228
0ef52a96 229 use Catalyst qw/My::Module/;
fc7ec1d9 230
836e1134 231If your plugin starts with a name other than C<Catalyst::Plugin::>, you can
232fully qualify the name by using a unary plus:
233
234 use Catalyst qw/
235 My::Module
236 +Fully::Qualified::Plugin::Name
237 /;
238
ae1e6b59 239Special flags like C<-Debug> and C<-Engine> can also be specified as
240arguments when Catalyst is loaded:
fc7ec1d9 241
242 use Catalyst qw/-Debug My::Module/;
243
ae1e6b59 244The position of plugins and flags in the chain is important, because
86418559 245they are loaded in the order in which they appear.
fc7ec1d9 246
23f9d934 247The following flags are supported:
248
b5ecfcf0 249=head2 -Debug
23f9d934 250
f8ad6ea5 251Enables debug output. You can also force this setting from the system
86418559 252environment with CATALYST_DEBUG or <MYAPP>_DEBUG. The environment
253settings override the application, with <MYAPP>_DEBUG having the highest
254priority.
fc7ec1d9 255
c8083f4e 256This sets the log level to 'debug' and enables full debug output on the
257error screen. If you only want the latter, see L<< $c->debug >>.
258
b5ecfcf0 259=head2 -Engine
fc7ec1d9 260
ae1e6b59 261Forces Catalyst to use a specific engine. Omit the
262C<Catalyst::Engine::> prefix of the engine name, i.e.:
fc7ec1d9 263
0ef52a96 264 use Catalyst qw/-Engine=CGI/;
fc7ec1d9 265
b5ecfcf0 266=head2 -Home
fbcc39ad 267
ae1e6b59 268Forces Catalyst to use a specific home directory, e.g.:
269
86418559 270 use Catalyst qw[-Home=/usr/mst];
fbcc39ad 271
cc95842f 272This can also be done in the shell environment by setting either the
273C<CATALYST_HOME> environment variable or C<MYAPP_HOME>; where C<MYAPP>
274is replaced with the uppercased name of your application, any "::" in
275the name will be replaced with underscores, e.g. MyApp::Web should use
276MYAPP_WEB_HOME. If both variables are set, the MYAPP_HOME one will be used.
277
d7a82605 278If none of these are set, Catalyst will attempt to automatically detect the
279home directory. If you are working in a development envirnoment, Catalyst
280will try and find the directory containing either Makefile.PL, Build.PL or
281dist.ini. If the application has been installed into the system (i.e.
282you have done C<make install>), then Catalyst will use the path to your
283application module, without the .pm extension (ie, /foo/MyApp if your
284application was installed at /foo/MyApp.pm)
285
b5ecfcf0 286=head2 -Log
fbcc39ad 287
0fa676a7 288 use Catalyst '-Log=warn,fatal,error';
62a6df80 289
0fa676a7 290Specifies a comma-delimited list of log levels.
fbcc39ad 291
dc5f035e 292=head2 -Stats
293
01c5eab0 294Enables statistics collection and reporting.
dc5f035e 295
01c5eab0 296 use Catalyst qw/-Stats=1/;
dc5f035e 297
01c5eab0 298You can also force this setting from the system environment with CATALYST_STATS
299or <MYAPP>_STATS. The environment settings override the application, with
300<MYAPP>_STATS having the highest priority.
dc5f035e 301
01c5eab0 302Stats are also enabled if L<< debugging |/"-Debug" >> is enabled.
dc5f035e 303
23f9d934 304=head1 METHODS
305
f7b672ef 306=head2 INFORMATION ABOUT THE CURRENT REQUEST
0ef52a96 307
b5ecfcf0 308=head2 $c->action
66e28e3f 309
ae1e6b59 310Returns a L<Catalyst::Action> object for the current action, which
311stringifies to the action name. See L<Catalyst::Action>.
0ef52a96 312
b5ecfcf0 313=head2 $c->namespace
0ef52a96 314
86418559 315Returns the namespace of the current action, i.e., the URI prefix
ae1e6b59 316corresponding to the controller of the current action. For example:
317
318 # in Controller::Foo::Bar
319 $c->namespace; # returns 'foo/bar';
0ef52a96 320
b5ecfcf0 321=head2 $c->request
0ef52a96 322
b5ecfcf0 323=head2 $c->req
0ef52a96 324
86418559 325Returns the current L<Catalyst::Request> object, giving access to
326information about the current client request (including parameters,
327cookies, HTTP headers, etc.). See L<Catalyst::Request>.
0ef52a96 328
b4b01a8a 329=head2 REQUEST FLOW HANDLING
0ef52a96 330
b5ecfcf0 331=head2 $c->forward( $action [, \@arguments ] )
0ef52a96 332
b5ecfcf0 333=head2 $c->forward( $class, $method, [, \@arguments ] )
0ef52a96 334
86418559 335Forwards processing to another action, by its private name. If you give a
b4b01a8a 336class name but no method, C<process()> is called. You may also optionally
337pass arguments in an arrayref. The action will receive the arguments in
cc95842f 338C<@_> and C<< $c->req->args >>. Upon returning from the function,
339C<< $c->req->args >> will be restored to the previous values.
0ef52a96 340
3b984c64 341Any data C<return>ed from the action forwarded to, will be returned by the
d759db1e 342call to forward.
3b984c64 343
344 my $foodata = $c->forward('/foo');
0ef52a96 345 $c->forward('index');
1d3a0700 346 $c->forward(qw/Model::DBIC::Foo do_stuff/);
347 $c->forward('View::TT');
0ef52a96 348
18a9655c 349Note that L<< forward|/"$c->forward( $action [, \@arguments ] )" >> implies
350an C<< eval { } >> around the call (actually
351L<< execute|/"$c->execute( $class, $coderef )" >> does), thus de-fatalizing
352all 'dies' within the called action. If you want C<die> to propagate you
353need to do something like:
f3e6a8c0 354
355 $c->forward('foo');
7d6820cc 356 die join "\n", @{ $c->error } if @{ $c->error };
f3e6a8c0 357
86418559 358Or make sure to always return true values from your actions and write
359your code like this:
f3e6a8c0 360
361 $c->forward('foo') || return;
1d3a0700 362
2e60292e 363Another note is that C<< $c->forward >> always returns a scalar because it
364actually returns $c->state which operates in a scalar context.
365Thus, something like:
366
367 return @array;
1d3a0700 368
369in an action that is forwarded to is going to return a scalar,
2e60292e 370i.e. how many items are in that array, which is probably not what you want.
1d3a0700 371If you need to return an array then return a reference to it,
2e60292e 372or stash it like so:
373
374 $c->stash->{array} = \@array;
375
376and access it from the stash.
f3e6a8c0 377
9c74923d 378Keep in mind that the C<end> method used is that of the caller action. So a C<$c-E<gt>detach> inside a forwarded action would run the C<end> method from the original action requested.
379
0ef52a96 380=cut
381
6680c772 382sub forward { my $c = shift; no warnings 'recursion'; $c->dispatcher->forward( $c, @_ ) }
0ef52a96 383
b5ecfcf0 384=head2 $c->detach( $action [, \@arguments ] )
0ef52a96 385
b5ecfcf0 386=head2 $c->detach( $class, $method, [, \@arguments ] )
0ef52a96 387
264bac8c 388=head2 $c->detach()
389
18a9655c 390The same as L<< forward|/"$c->forward( $action [, \@arguments ] )" >>, but
391doesn't return to the previous action when processing is finished.
0ef52a96 392
264bac8c 393When called with no arguments it escapes the processing chain entirely.
394
0ef52a96 395=cut
396
397sub detach { my $c = shift; $c->dispatcher->detach( $c, @_ ) }
398
5d91ffe2 399=head2 $c->visit( $action [, \@captures, \@arguments ] )
ae0e35ee 400
5d91ffe2 401=head2 $c->visit( $class, $method, [, \@captures, \@arguments ] )
ae0e35ee 402
18a9655c 403Almost the same as L<< forward|/"$c->forward( $action [, \@arguments ] )" >>,
404but does a full dispatch, instead of just calling the new C<$action> /
405C<< $class->$method >>. This means that C<begin>, C<auto> and the method
406you go to are called, just like a new request.
ae0e35ee 407
4b48773e 408In addition both C<< $c->action >> and C<< $c->namespace >> are localized.
18a9655c 409This means, for example, that C<< $c->action >> methods such as
410L<name|Catalyst::Action/name>, L<class|Catalyst::Action/class> and
411L<reverse|Catalyst::Action/reverse> return information for the visited action
412when they are invoked within the visited action. This is different from the
413behavior of L<< forward|/"$c->forward( $action [, \@arguments ] )" >>, which
414continues to use the $c->action object from the caller action even when
4b48773e 415invoked from the callee.
416
18a9655c 417C<< $c->stash >> is kept unchanged.
ae0e35ee 418
18a9655c 419In effect, L<< visit|/"$c->visit( $action [, \@captures, \@arguments ] )" >>
420allows you to "wrap" another action, just as it would have been called by
421dispatching from a URL, while the analogous
422L<< go|/"$c->go( $action [, \@captures, \@arguments ] )" >> allows you to
423transfer control to another action as if it had been reached directly from a URL.
ae0e35ee 424
425=cut
426
427sub visit { my $c = shift; $c->dispatcher->visit( $c, @_ ) }
428
5d91ffe2 429=head2 $c->go( $action [, \@captures, \@arguments ] )
2f381252 430
5d91ffe2 431=head2 $c->go( $class, $method, [, \@captures, \@arguments ] )
2f381252 432
1d3a0700 433The relationship between C<go> and
12c48597 434L<< visit|/"$c->visit( $action [, \@captures, \@arguments ] )" >> is the same as
1d3a0700 435the relationship between
12c48597 436L<< forward|/"$c->forward( $class, $method, [, \@arguments ] )" >> and
437L<< detach|/"$c->detach( $action [, \@arguments ] )" >>. Like C<< $c->visit >>,
438C<< $c->go >> will perform a full dispatch on the specified action or method,
439with localized C<< $c->action >> and C<< $c->namespace >>. Like C<detach>,
440C<go> escapes the processing of the current request chain on completion, and
441does not return to its caller.
2f381252 442
9c74923d 443@arguments are arguments to the final destination of $action. @captures are
444arguments to the intermediate steps, if any, on the way to the final sub of
445$action.
446
2f381252 447=cut
448
449sub go { my $c = shift; $c->dispatcher->go( $c, @_ ) }
450
b4b01a8a 451=head2 $c->response
452
453=head2 $c->res
454
cc95842f 455Returns the current L<Catalyst::Response> object, see there for details.
b4b01a8a 456
457=head2 $c->stash
458
459Returns a hashref to the stash, which may be used to store data and pass
460it between components during a request. You can also set hash keys by
461passing arguments. The stash is automatically sent to the view. The
462stash is cleared at the end of a request; it cannot be used for
86418559 463persistent storage (for this you must use a session; see
464L<Catalyst::Plugin::Session> for a complete system integrated with
465Catalyst).
b4b01a8a 466
467 $c->stash->{foo} = $bar;
468 $c->stash( { moose => 'majestic', qux => 0 } );
469 $c->stash( bar => 1, gorch => 2 ); # equivalent to passing a hashref
62a6df80 470
b4b01a8a 471 # stash is automatically passed to the view for use in a template
cc95842f 472 $c->forward( 'MyApp::View::TT' );
b4b01a8a 473
474=cut
475
4090e3bb 476around stash => sub {
477 my $orig = shift;
b4b01a8a 478 my $c = shift;
4090e3bb 479 my $stash = $orig->($c);
b4b01a8a 480 if (@_) {
4090e3bb 481 my $new_stash = @_ > 1 ? {@_} : $_[0];
482 croak('stash takes a hash or hashref') unless ref $new_stash;
483 foreach my $key ( keys %$new_stash ) {
484 $stash->{$key} = $new_stash->{$key};
b4b01a8a 485 }
486 }
0fc2d522 487
4090e3bb 488 return $stash;
489};
0fc2d522 490
b4b01a8a 491
b5ecfcf0 492=head2 $c->error
0ef52a96 493
b5ecfcf0 494=head2 $c->error($error, ...)
0ef52a96 495
b5ecfcf0 496=head2 $c->error($arrayref)
0ef52a96 497
83a8fcac 498Returns an arrayref containing error messages. If Catalyst encounters an
499error while processing a request, it stores the error in $c->error. This
e7ad3b81 500method should only be used to store fatal error messages.
0ef52a96 501
502 my @error = @{ $c->error };
503
504Add a new error.
505
506 $c->error('Something bad happened');
507
0ef52a96 508=cut
509
510sub error {
511 my $c = shift;
512 if ( $_[0] ) {
513 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
9ce44430 514 croak @$error unless ref $c;
0ef52a96 515 push @{ $c->{error} }, @$error;
516 }
517 elsif ( defined $_[0] ) { $c->{error} = undef }
518 return $c->{error} || [];
519}
520
b4b01a8a 521
522=head2 $c->state
523
1d3a0700 524Contains the return value of the last executed action.
2e60292e 525Note that << $c->state >> operates in a scalar context which means that all
526values it returns are scalar.
b4b01a8a 527
ca81eb67 528=head2 $c->clear_errors
529
530Clear errors. You probably don't want to clear the errors unless you are
531implementing a custom error screen.
532
533This is equivalent to running
534
535 $c->error(0);
536
537=cut
538
539sub clear_errors {
540 my $c = shift;
541 $c->error(0);
542}
543
2f381252 544sub _comp_search_prefixes {
c23b894b 545 my $c = shift;
546 return map $c->components->{ $_ }, $c->_comp_names_search_prefixes(@_);
547}
548
549# search components given a name and some prefixes
550sub _comp_names_search_prefixes {
2f381252 551 my ( $c, $name, @prefixes ) = @_;
552 my $appclass = ref $c || $c;
553 my $filter = "^${appclass}::(" . join( '|', @prefixes ) . ')::';
cce626ed 554 $filter = qr/$filter/; # Compile regex now rather than once per loop
0ef52a96 555
2f381252 556 # map the original component name to the sub part that we will search against
557 my %eligible = map { my $n = $_; $n =~ s{^$appclass\::[^:]+::}{}; $_ => $n; }
558 grep { /$filter/ } keys %{ $c->components };
0756fe3b 559
2f381252 560 # undef for a name will return all
561 return keys %eligible if !defined $name;
0756fe3b 562
2f381252 563 my $query = ref $name ? $name : qr/^$name$/i;
564 my @result = grep { $eligible{$_} =~ m{$query} } keys %eligible;
0756fe3b 565
c23b894b 566 return @result if @result;
0756fe3b 567
2f381252 568 # if we were given a regexp to search against, we're done.
569 return if ref $name;
0756fe3b 570
ab86b480 571 # skip regexp fallback if configured
572 return
573 if $appclass->config->{disable_component_resolution_regex_fallback};
574
2f381252 575 # regexp fallback
576 $query = qr/$name/i;
c23b894b 577 @result = grep { $eligible{ $_ } =~ m{$query} } keys %eligible;
0756fe3b 578
2f381252 579 # no results? try against full names
580 if( !@result ) {
c23b894b 581 @result = grep { m{$query} } keys %eligible;
2f381252 582 }
0756fe3b 583
2f381252 584 # don't warn if we didn't find any results, it just might not exist
585 if( @result ) {
cce626ed 586 # Disgusting hack to work out correct method name
587 my $warn_for = lc $prefixes[0];
e260802a 588 my $msg = "Used regexp fallback for \$c->${warn_for}('${name}'), which found '" .
108201b5 589 (join '", "', @result) . "'. Relying on regexp fallback behavior for " .
590 "component resolution is unreliable and unsafe.";
591 my $short = $result[0];
ab86b480 592 # remove the component namespace prefix
593 $short =~ s/.*?(Model|Controller|View):://;
108201b5 594 my $shortmess = Carp::shortmess('');
595 if ($shortmess =~ m#Catalyst/Plugin#) {
596 $msg .= " You probably need to set '$short' instead of '${name}' in this " .
597 "plugin's config";
598 } elsif ($shortmess =~ m#Catalyst/lib/(View|Controller)#) {
599 $msg .= " You probably need to set '$short' instead of '${name}' in this " .
600 "component's config";
601 } else {
ab86b480 602 $msg .= " You probably meant \$c->${warn_for}('$short') instead of \$c->${warn_for}('${name}'), " .
108201b5 603 "but if you really wanted to search, pass in a regexp as the argument " .
cce626ed 604 "like so: \$c->${warn_for}(qr/${name}/)";
108201b5 605 }
606 $c->log->warn( "${msg}$shortmess" );
2f381252 607 }
0756fe3b 608
2f381252 609 return @result;
0756fe3b 610}
611
62a6df80 612# Find possible names for a prefix
3b88a455 613sub _comp_names {
614 my ( $c, @prefixes ) = @_;
3b88a455 615 my $appclass = ref $c || $c;
616
2f381252 617 my $filter = "^${appclass}::(" . join( '|', @prefixes ) . ')::';
3b88a455 618
c23b894b 619 my @names = map { s{$filter}{}; $_; }
620 $c->_comp_names_search_prefixes( undef, @prefixes );
621
3b88a455 622 return @names;
623}
624
197bd788 625# Filter a component before returning by calling ACCEPT_CONTEXT if available
626sub _filter_component {
627 my ( $c, $comp, @args ) = @_;
2f381252 628
8abaac85 629 if ( eval { $comp->can('ACCEPT_CONTEXT'); } ) {
197bd788 630 return $comp->ACCEPT_CONTEXT( $c, @args );
631 }
62a6df80 632
2f381252 633 return $comp;
197bd788 634}
635
f7b672ef 636=head2 COMPONENT ACCESSORS
0ef52a96 637
b5ecfcf0 638=head2 $c->controller($name)
af3ff00e 639
0ef52a96 640Gets a L<Catalyst::Controller> instance by name.
af3ff00e 641
642 $c->controller('Foo')->do_stuff;
643
86418559 644If the name is omitted, will return the controller for the dispatched
645action.
649fd1fa 646
2f381252 647If you want to search for controllers, pass in a regexp as the argument.
648
649 # find all controllers that start with Foo
650 my @foo_controllers = $c->controller(qr{^Foo});
651
652
af3ff00e 653=cut
654
655sub controller {
197bd788 656 my ( $c, $name, @args ) = @_;
2f381252 657
13311c16 658 my $appclass = ref($c) || $c;
2f381252 659 if( $name ) {
13311c16 660 unless ( ref($name) ) { # Direct component hash lookup to avoid costly regexps
661 my $comps = $c->components;
662 my $check = $appclass."::Controller::".$name;
663 return $c->_filter_component( $comps->{$check}, @args ) if exists $comps->{$check};
664 }
2f381252 665 my @result = $c->_comp_search_prefixes( $name, qw/Controller C/ );
666 return map { $c->_filter_component( $_, @args ) } @result if ref $name;
667 return $c->_filter_component( $result[ 0 ], @args );
668 }
669
197bd788 670 return $c->component( $c->action->class );
af3ff00e 671}
672
b5ecfcf0 673=head2 $c->model($name)
fc7ec1d9 674
0ef52a96 675Gets a L<Catalyst::Model> instance by name.
676
677 $c->model('Foo')->do_stuff;
fc7ec1d9 678
72f87c4b 679Any extra arguments are directly passed to ACCEPT_CONTEXT.
680
62a6df80 681If the name is omitted, it will look for
2f381252 682 - a model object in $c->stash->{current_model_instance}, then
a3b71f0f 683 - a model name in $c->stash->{current_model}, then
684 - a config setting 'default_model', or
685 - check if there is only one model, and return it if that's the case.
649fd1fa 686
2f381252 687If you want to search for models, pass in a regexp as the argument.
688
689 # find all models that start with Foo
690 my @foo_models = $c->model(qr{^Foo});
691
fc7ec1d9 692=cut
693
0ef52a96 694sub model {
197bd788 695 my ( $c, $name, @args ) = @_;
df960201 696 my $appclass = ref($c) || $c;
2f381252 697 if( $name ) {
13311c16 698 unless ( ref($name) ) { # Direct component hash lookup to avoid costly regexps
699 my $comps = $c->components;
700 my $check = $appclass."::Model::".$name;
701 return $c->_filter_component( $comps->{$check}, @args ) if exists $comps->{$check};
702 }
2f381252 703 my @result = $c->_comp_search_prefixes( $name, qw/Model M/ );
704 return map { $c->_filter_component( $_, @args ) } @result if ref $name;
705 return $c->_filter_component( $result[ 0 ], @args );
706 }
707
a3b71f0f 708 if (ref $c) {
62a6df80 709 return $c->stash->{current_model_instance}
a3b71f0f 710 if $c->stash->{current_model_instance};
711 return $c->model( $c->stash->{current_model} )
712 if $c->stash->{current_model};
a3b71f0f 713 }
df960201 714 return $c->model( $appclass->config->{default_model} )
715 if $appclass->config->{default_model};
3b88a455 716
2f381252 717 my( $comp, $rest ) = $c->_comp_search_prefixes( undef, qw/Model M/);
3b88a455 718
2f381252 719 if( $rest ) {
108201b5 720 $c->log->warn( Carp::shortmess('Calling $c->model() will return a random model unless you specify one of:') );
4600a5a1 721 $c->log->warn( '* $c->config(default_model => "the name of the default model to use")' );
2f381252 722 $c->log->warn( '* $c->stash->{current_model} # the name of the model to use for this request' );
723 $c->log->warn( '* $c->stash->{current_model_instance} # the instance of the model to use for this request' );
11c270bd 724 $c->log->warn( 'NB: in version 5.81, the "random" behavior will not work at all.' );
2f381252 725 }
3b88a455 726
2f381252 727 return $c->_filter_component( $comp );
3b88a455 728}
729
b4b01a8a 730
b5ecfcf0 731=head2 $c->view($name)
0ef52a96 732
733Gets a L<Catalyst::View> instance by name.
fc7ec1d9 734
0ef52a96 735 $c->view('Foo')->do_stuff;
fc7ec1d9 736
72f87c4b 737Any extra arguments are directly passed to ACCEPT_CONTEXT.
738
62a6df80 739If the name is omitted, it will look for
2f381252 740 - a view object in $c->stash->{current_view_instance}, then
a3b71f0f 741 - a view name in $c->stash->{current_view}, then
742 - a config setting 'default_view', or
743 - check if there is only one view, and return it if that's the case.
649fd1fa 744
2f381252 745If you want to search for views, pass in a regexp as the argument.
746
747 # find all views that start with Foo
748 my @foo_views = $c->view(qr{^Foo});
749
fc7ec1d9 750=cut
751
0ef52a96 752sub view {
197bd788 753 my ( $c, $name, @args ) = @_;
2f381252 754
df960201 755 my $appclass = ref($c) || $c;
2f381252 756 if( $name ) {
13311c16 757 unless ( ref($name) ) { # Direct component hash lookup to avoid costly regexps
758 my $comps = $c->components;
759 my $check = $appclass."::View::".$name;
9c74923d 760 if( exists $comps->{$check} ) {
761 return $c->_filter_component( $comps->{$check}, @args );
762 }
763 else {
764 $c->log->warn( "Attempted to use view '$check', but does not exist" );
765 }
13311c16 766 }
2f381252 767 my @result = $c->_comp_search_prefixes( $name, qw/View V/ );
768 return map { $c->_filter_component( $_, @args ) } @result if ref $name;
769 return $c->_filter_component( $result[ 0 ], @args );
770 }
771
a3b71f0f 772 if (ref $c) {
62a6df80 773 return $c->stash->{current_view_instance}
a3b71f0f 774 if $c->stash->{current_view_instance};
775 return $c->view( $c->stash->{current_view} )
776 if $c->stash->{current_view};
a3b71f0f 777 }
df960201 778 return $c->view( $appclass->config->{default_view} )
779 if $appclass->config->{default_view};
2f381252 780
781 my( $comp, $rest ) = $c->_comp_search_prefixes( undef, qw/View V/);
782
783 if( $rest ) {
784 $c->log->warn( 'Calling $c->view() will return a random view unless you specify one of:' );
4600a5a1 785 $c->log->warn( '* $c->config(default_view => "the name of the default view to use")' );
2f381252 786 $c->log->warn( '* $c->stash->{current_view} # the name of the view to use for this request' );
787 $c->log->warn( '* $c->stash->{current_view_instance} # the instance of the view to use for this request' );
11c270bd 788 $c->log->warn( 'NB: in version 5.81, the "random" behavior will not work at all.' );
2f381252 789 }
790
791 return $c->_filter_component( $comp );
792}
793
794=head2 $c->controllers
795
796Returns the available names which can be passed to $c->controller
797
798=cut
799
800sub controllers {
801 my ( $c ) = @_;
802 return $c->_comp_names(qw/Controller C/);
0ef52a96 803}
fbcc39ad 804
b4b01a8a 805=head2 $c->models
806
807Returns the available names which can be passed to $c->model
808
809=cut
810
811sub models {
812 my ( $c ) = @_;
813 return $c->_comp_names(qw/Model M/);
814}
815
816
3b88a455 817=head2 $c->views
818
819Returns the available names which can be passed to $c->view
820
821=cut
822
823sub views {
824 my ( $c ) = @_;
825 return $c->_comp_names(qw/View V/);
826}
827
b4b01a8a 828=head2 $c->comp($name)
829
830=head2 $c->component($name)
831
cc95842f 832Gets a component object by name. This method is not recommended,
b4b01a8a 833unless you want to get a specific component by full
cc95842f 834class. C<< $c->controller >>, C<< $c->model >>, and C<< $c->view >>
b4b01a8a 835should be used instead.
836
2f381252 837If C<$name> is a regexp, a list of components matched against the full
838component name will be returned.
839
ab86b480 840If Catalyst can't find a component by name, it will fallback to regex
841matching by default. To disable this behaviour set
842disable_component_resolution_regex_fallback to a true value.
1d3a0700 843
220f4575 844 __PACKAGE__->config( disable_component_resolution_regex_fallback => 1 );
ab86b480 845
b4b01a8a 846=cut
847
848sub component {
2f381252 849 my ( $c, $name, @args ) = @_;
b4b01a8a 850
2f381252 851 if( $name ) {
852 my $comps = $c->components;
b4b01a8a 853
2f381252 854 if( !ref $name ) {
855 # is it the exact name?
856 return $c->_filter_component( $comps->{ $name }, @args )
857 if exists $comps->{ $name };
b4b01a8a 858
2f381252 859 # perhaps we just omitted "MyApp"?
860 my $composed = ( ref $c || $c ) . "::${name}";
861 return $c->_filter_component( $comps->{ $composed }, @args )
862 if exists $comps->{ $composed };
b4b01a8a 863
2f381252 864 # search all of the models, views and controllers
865 my( $comp ) = $c->_comp_search_prefixes( $name, qw/Model M Controller C View V/ );
866 return $c->_filter_component( $comp, @args ) if $comp;
867 }
868
f899107d 869 return
870 if $c->config->{disable_component_resolution_regex_fallback};
871
2f381252 872 # This is here so $c->comp( '::M::' ) works
873 my $query = ref $name ? $name : qr{$name}i;
b4b01a8a 874
2f381252 875 my @result = grep { m{$query} } keys %{ $c->components };
876 return map { $c->_filter_component( $_, @args ) } @result if ref $name;
b4b01a8a 877
2f381252 878 if( $result[ 0 ] ) {
108201b5 879 $c->log->warn( Carp::shortmess(qq(Found results for "${name}" using regexp fallback)) );
2f381252 880 $c->log->warn( 'Relying on the regexp fallback behavior for component resolution' );
881 $c->log->warn( 'is unreliable and unsafe. You have been warned' );
882 return $c->_filter_component( $result[ 0 ], @args );
883 }
884
885 # I would expect to return an empty list here, but that breaks back-compat
b4b01a8a 886 }
887
2f381252 888 # fallback
b4b01a8a 889 return sort keys %{ $c->components };
890}
891
b4b01a8a 892=head2 CLASS DATA AND HELPER CLASSES
fbcc39ad 893
b5ecfcf0 894=head2 $c->config
fbcc39ad 895
0ef52a96 896Returns or takes a hashref containing the application's configuration.
897
61b1d329 898 __PACKAGE__->config( { db => 'dsn:SQLite:foo.db' } );
81557adf 899
18a9655c 900You can also use a C<YAML>, C<XML> or L<Config::General> config file
901like C<myapp.conf> in your applications home directory. See
cc95842f 902L<Catalyst::Plugin::ConfigLoader>.
a6ad13b6 903
6df30f7e 904=head3 Cascading configuration
a6ad13b6 905
b3542016 906The config method is present on all Catalyst components, and configuration
907will be merged when an application is started. Configuration loaded with
908L<Catalyst::Plugin::ConfigLoader> takes precedence over other configuration,
62a6df80 909followed by configuration in your top level C<MyApp> class. These two
a51d14ff 910configurations are merged, and then configuration data whose hash key matches a
b3542016 911component name is merged with configuration for that component.
912
913The configuration for a component is then passed to the C<new> method when a
914component is constructed.
915
916For example:
917
918 MyApp->config({ 'Model::Foo' => { bar => 'baz', overrides => 'me' } });
790ff9aa 919 MyApp::Model::Foo->config({ quux => 'frob', overrides => 'this' });
62a6df80 920
921will mean that C<MyApp::Model::Foo> receives the following data when
b3542016 922constructed:
923
924 MyApp::Model::Foo->new({
925 bar => 'baz',
926 quux => 'frob',
927 overrides => 'me',
928 });
b4b01a8a 929
f8a54681 930It's common practice to use a Moose attribute
931on the receiving component to access the config value.
932
933 package MyApp::Model::Foo;
934
935 use Moose;
936
937 # this attr will receive 'baz' at construction time
9c74923d 938 has 'bar' => (
f8a54681 939 is => 'rw',
940 isa => 'Str',
941 );
942
943You can then get the value 'baz' by calling $c->model('Foo')->bar
9c74923d 944(or $self->bar inside code in the model).
945
946B<NOTE:> you MUST NOT call C<< $self->config >> or C<< __PACKAGE__->config >>
947as a way of reading config within your code, as this B<will not> give you the
948correctly merged config back. You B<MUST> take the config values supplied to
949the constructor and use those instead.
f8a54681 950
3643e890 951=cut
952
4090e3bb 953around config => sub {
954 my $orig = shift;
3643e890 955 my $c = shift;
956
fcf89172 957 croak('Setting config after setup has been run is not allowed.')
958 if ( @_ and $c->setup_finished );
3643e890 959
4090e3bb 960 $c->$orig(@_);
961};
3643e890 962
b5ecfcf0 963=head2 $c->log
0ef52a96 964
86418559 965Returns the logging object instance. Unless it is already set, Catalyst
966sets this up with a L<Catalyst::Log> object. To use your own log class,
967set the logger with the C<< __PACKAGE__->log >> method prior to calling
9e7673af 968C<< __PACKAGE__->setup >>.
969
970 __PACKAGE__->log( MyLogger->new );
971 __PACKAGE__->setup;
972
973And later:
0ef52a96 974
ae1e6b59 975 $c->log->info( 'Now logging with my own logger!' );
0ef52a96 976
86418559 977Your log class should implement the methods described in
978L<Catalyst::Log>.
af3ff00e 979
b4b01a8a 980
981=head2 $c->debug
982
c74d3f0c 983Returns 1 if debug mode is enabled, 0 otherwise.
b4b01a8a 984
7e5c67f2 985You can enable debug mode in several ways:
986
987=over
988
62a6df80 989=item By calling myapp_server.pl with the -d flag
990
7e5c67f2 991=item With the environment variables MYAPP_DEBUG, or CATALYST_DEBUG
992
993=item The -Debug option in your MyApp.pm
994
8eae92ad 995=item By declaring C<sub debug { 1 }> in your MyApp.pm.
7e5c67f2 996
997=back
c74d3f0c 998
c8083f4e 999The first three also set the log level to 'debug'.
1000
8eae92ad 1001Calling C<< $c->debug(1) >> has no effect.
e80e8542 1002
af3ff00e 1003=cut
1004
b4b01a8a 1005sub debug { 0 }
1006
1007=head2 $c->dispatcher
1008
2887a7f1 1009Returns the dispatcher instance. See L<Catalyst::Dispatcher>.
b4b01a8a 1010
1011=head2 $c->engine
1012
2887a7f1 1013Returns the engine instance. See L<Catalyst::Engine>.
b4b01a8a 1014
1015
f7b672ef 1016=head2 UTILITY METHODS
66e28e3f 1017
b5ecfcf0 1018=head2 $c->path_to(@path)
01033d73 1019
cc95842f 1020Merges C<@path> with C<< $c->config->{home} >> and returns a
4e392da6 1021L<Path::Class::Dir> object. Note you can usually use this object as
1022a filename, but sometimes you will have to explicitly stringify it
18a9655c 1023yourself by calling the C<< ->stringify >> method.
01033d73 1024
1025For example:
1026
1027 $c->path_to( 'db', 'sqlite.db' );
1028
1029=cut
1030
1031sub path_to {
1032 my ( $c, @path ) = @_;
a738ab68 1033 my $path = Path::Class::Dir->new( $c->config->{home}, @path );
01033d73 1034 if ( -d $path ) { return $path }
a738ab68 1035 else { return Path::Class::File->new( $c->config->{home}, @path ) }
01033d73 1036}
1037
b5ecfcf0 1038=head2 $c->plugin( $name, $class, @args )
0ef52a96 1039
10011c19 1040Helper method for plugins. It creates a class data accessor/mutator and
ae1e6b59 1041loads and instantiates the given class.
0ef52a96 1042
1043 MyApp->plugin( 'prototype', 'HTML::Prototype' );
1044
1045 $c->prototype->define_javascript_functions;
4e68badc 1046
6b2a933b 1047B<Note:> This method of adding plugins is deprecated. The ability
4e68badc 1048to add plugins like this B<will be removed> in a Catalyst 5.81.
6b2a933b 1049Please do not use this functionality in new code.
0ef52a96 1050
1051=cut
1052
1053sub plugin {
1054 my ( $class, $name, $plugin, @args ) = @_;
6b2a933b 1055
4e68badc 1056 # See block comment in t/unit_core_plugin.t
b3542016 1057 $class->log->warn(qq/Adding plugin using the ->plugin method is deprecated, and will be removed in Catalyst 5.81/);
4e68badc 1058
97b58e17 1059 $class->_register_plugin( $plugin, 1 );
0ef52a96 1060
1061 eval { $plugin->import };
1062 $class->mk_classdata($name);
1063 my $obj;
1064 eval { $obj = $plugin->new(@args) };
1065
1066 if ($@) {
1067 Catalyst::Exception->throw( message =>
1068 qq/Couldn't instantiate instant plugin "$plugin", "$@"/ );
1069 }
1070
1071 $class->$name($obj);
1072 $class->log->debug(qq/Initialized instant plugin "$plugin" as "$name"/)
1073 if $class->debug;
1074}
1075
b5ecfcf0 1076=head2 MyApp->setup
fbcc39ad 1077
e7f1cf73 1078Initializes the dispatcher and engine, loads any plugins, and loads the
ae1e6b59 1079model, view, and controller components. You may also specify an array
1080of plugins to load here, if you choose to not load them in the C<use
1081Catalyst> line.
fbcc39ad 1082
0ef52a96 1083 MyApp->setup;
1084 MyApp->setup( qw/-Debug/ );
fbcc39ad 1085
1086=cut
1087
1088sub setup {
0319a12c 1089 my ( $class, @arguments ) = @_;
c2f3cc1b 1090 croak('Running setup more than once')
1091 if ( $class->setup_finished );
5168a5fc 1092
fbcc39ad 1093 unless ( $class->isa('Catalyst') ) {
953b0e15 1094
fbcc39ad 1095 Catalyst::Exception->throw(
1096 message => qq/'$class' does not inherit from Catalyst/ );
1c99e125 1097 }
0319a12c 1098
fbcc39ad 1099 if ( $class->arguments ) {
1100 @arguments = ( @arguments, @{ $class->arguments } );
1101 }
1102
1103 # Process options
1104 my $flags = {};
1105
1106 foreach (@arguments) {
1107
1108 if (/^-Debug$/) {
1109 $flags->{log} =
1110 ( $flags->{log} ) ? 'debug,' . $flags->{log} : 'debug';
1111 }
1112 elsif (/^-(\w+)=?(.*)$/) {
1113 $flags->{ lc $1 } = $2;
1114 }
1115 else {
1116 push @{ $flags->{plugins} }, $_;
1117 }
1118 }
1119
99f187d6 1120 $class->setup_home( delete $flags->{home} );
1121
fbcc39ad 1122 $class->setup_log( delete $flags->{log} );
1123 $class->setup_plugins( delete $flags->{plugins} );
1124 $class->setup_dispatcher( delete $flags->{dispatcher} );
acbecf08 1125 if (my $engine = delete $flags->{engine}) {
0aafa77a 1126 $class->log->warn("Specifying the engine in ->setup is no longer supported, see Catalyst::Upgrading");
acbecf08 1127 }
1128 $class->setup_engine();
dc5f035e 1129 $class->setup_stats( delete $flags->{stats} );
fbcc39ad 1130
1131 for my $flag ( sort keys %{$flags} ) {
1132
1133 if ( my $code = $class->can( 'setup_' . $flag ) ) {
1134 &$code( $class, delete $flags->{$flag} );
1135 }
1136 else {
1137 $class->log->warn(qq/Unknown flag "$flag"/);
1138 }
1139 }
1140
0eb4af72 1141 eval { require Catalyst::Devel; };
1142 if( !$@ && $ENV{CATALYST_SCRIPT_GEN} && ( $ENV{CATALYST_SCRIPT_GEN} < $Catalyst::Devel::CATALYST_SCRIPT_GEN ) ) {
1143 $class->log->warn(<<"EOF");
4ff0d824 1144You are running an old script!
1145
34a83d89 1146 Please update by running (this will overwrite existing files):
1147 catalyst.pl -force -scripts $class
1148
1149 or (this will not overwrite existing files):
1150 catalyst.pl -scripts $class
1cf0345b 1151
4ff0d824 1152EOF
0eb4af72 1153 }
62a6df80 1154
fbcc39ad 1155 if ( $class->debug ) {
6601f2ad 1156 my @plugins = map { "$_ " . ( $_->VERSION || '' ) } $class->registered_plugins;
fbcc39ad 1157
1158 if (@plugins) {
39fc2ce1 1159 my $column_width = Catalyst::Utils::term_width() - 6;
1160 my $t = Text::SimpleTable->new($column_width);
8c113188 1161 $t->row($_) for @plugins;
1cf0345b 1162 $class->log->debug( "Loaded plugins:\n" . $t->draw . "\n" );
fbcc39ad 1163 }
1164
1165 my $dispatcher = $class->dispatcher;
1166 my $engine = $class->engine;
1167 my $home = $class->config->{home};
1168
01ce7075 1169 $class->log->debug(sprintf(q/Loaded dispatcher "%s"/, blessed($dispatcher)));
1170 $class->log->debug(sprintf(q/Loaded engine "%s"/, blessed($engine)));
fbcc39ad 1171
1172 $home
1173 ? ( -d $home )
1174 ? $class->log->debug(qq/Found home "$home"/)
1175 : $class->log->debug(qq/Home "$home" doesn't exist/)
1176 : $class->log->debug(q/Couldn't find home/);
1177 }
1178
54f4bfef 1179 # Call plugins setup, this is stupid and evil.
16b7c476 1180 # Also screws C3 badly on 5.10, hack to avoid.
fbcc39ad 1181 {
1182 no warnings qw/redefine/;
1183 local *setup = sub { };
16b7c476 1184 $class->setup unless $Catalyst::__AM_RESTARTING;
fbcc39ad 1185 }
1186
1187 # Initialize our data structure
1188 $class->components( {} );
1189
1190 $class->setup_components;
1191
1192 if ( $class->debug ) {
39fc2ce1 1193 my $column_width = Catalyst::Utils::term_width() - 8 - 9;
1194 my $t = Text::SimpleTable->new( [ $column_width, 'Class' ], [ 8, 'Type' ] );
684d10ed 1195 for my $comp ( sort keys %{ $class->components } ) {
1196 my $type = ref $class->components->{$comp} ? 'instance' : 'class';
1197 $t->row( $comp, $type );
1198 }
1cf0345b 1199 $class->log->debug( "Loaded components:\n" . $t->draw . "\n" )
8c113188 1200 if ( keys %{ $class->components } );
fbcc39ad 1201 }
1202
1203 # Add our self to components, since we are also a component
96d8d513 1204 if( $class->isa('Catalyst::Controller') ){
1205 $class->components->{$class} = $class;
1206 }
fbcc39ad 1207
1208 $class->setup_actions;
1209
1210 if ( $class->debug ) {
1211 my $name = $class->config->{name} || 'Application';
1212 $class->log->info("$name powered by Catalyst $Catalyst::VERSION");
1213 }
3643e890 1214
62a6df80 1215 # Make sure that the application class becomes immutable at this point,
acca8cd5 1216 B::Hooks::EndOfScope::on_scope_end {
df861f8e 1217 return if $@;
e106a59f 1218 my $meta = Class::MOP::get_metaclass_by_name($class);
4ffa3785 1219 if (
1220 $meta->is_immutable
1221 && ! { $meta->immutable_options }->{replace_constructor}
1222 && (
1223 $class->isa('Class::Accessor::Fast')
1224 || $class->isa('Class::Accessor')
1225 )
1226 ) {
81ef9afd 1227 warn "You made your application class ($class) immutable, "
4ffa3785 1228 . "but did not inline the\nconstructor. "
1229 . "This will break catalyst, as your app \@ISA "
1230 . "Class::Accessor(::Fast)?\nPlease pass "
1231 . "(replace_constructor => 1)\nwhen making your class immutable.\n";
6e5505d4 1232 }
83b8cda1 1233 $meta->make_immutable(
1234 replace_constructor => 1,
83b8cda1 1235 ) unless $meta->is_immutable;
acca8cd5 1236 };
3d041c32 1237
647a3de1 1238 if ($class->config->{case_sensitive}) {
1239 $class->log->warn($class . "->config->{case_sensitive} is set.");
1240 $class->log->warn("This setting is deprecated and planned to be removed in Catalyst 5.81.");
1241 }
1242
a5d07d29 1243 $class->setup_finalize;
647a3de1 1244 # Should be the last thing we do so that user things hooking
1245 # setup_finalize can log..
1246 $class->log->_flush() if $class->log->can('_flush');
64ceb36b 1247 return 1; # Explicit return true as people have __PACKAGE__->setup as the last thing in their class. HATE.
a5d07d29 1248}
1249
23c63a17 1250=head2 $app->setup_finalize
1251
128a7cee 1252A hook to attach modifiers to. This method does not do anything except set the
1253C<setup_finished> accessor.
23c63a17 1254
ae7da8f5 1255Applying method modifiers to the C<setup> method doesn't work, because of quirky things done for plugin setup.
23c63a17 1256
128a7cee 1257Example:
23c63a17 1258
128a7cee 1259 after setup_finalize => sub {
1260 my $app = shift;
23c63a17 1261
128a7cee 1262 ## do stuff here..
1263 };
23c63a17 1264
1265=cut
1266
a5d07d29 1267sub setup_finalize {
1268 my ($class) = @_;
3643e890 1269 $class->setup_finished(1);
fbcc39ad 1270}
1271
d71da6fe 1272=head2 $c->uri_for( $path?, @args?, \%query_values? )
fbcc39ad 1273
ee8963de 1274=head2 $c->uri_for( $action, \@captures?, @args?, \%query_values? )
9df7c5d9 1275
ee8963de 1276Constructs an absolute L<URI> object based on the application root, the
1277provided path, and the additional arguments and query parameters provided.
186d5270 1278When used as a string, provides a textual URI. If you need more flexibility
92981fc3 1279than this (i.e. the option to provide relative URIs etc.) see
186d5270 1280L<Catalyst::Plugin::SmartURI>.
ee8963de 1281
d71da6fe 1282If no arguments are provided, the URI for the current action is returned.
1283To return the current action and also provide @args, use
1d3a0700 1284C<< $c->uri_for( $c->action, @args ) >>.
d71da6fe 1285
ee8963de 1286If the first argument is a string, it is taken as a public URI path relative
1287to C<< $c->namespace >> (if it doesn't begin with a forward slash) or
e7e4c469 1288relative to the application root (if it does). It is then merged with
ee8963de 1289C<< $c->request->base >>; any C<@args> are appended as additional path
1290components; and any C<%query_values> are appended as C<?foo=bar> parameters.
1291
1292If the first argument is a L<Catalyst::Action> it represents an action which
1293will have its path resolved using C<< $c->dispatcher->uri_for_action >>. The
1294optional C<\@captures> argument (an arrayref) allows passing the captured
1295variables that are needed to fill in the paths of Chained and Regex actions;
1296once the path is resolved, C<uri_for> continues as though a path was
1297provided, appending any arguments or parameters and creating an absolute
1298URI.
1299
e7e4c469 1300The captures for the current request can be found in
ee8963de 1301C<< $c->request->captures >>, and actions can be resolved using
1302C<< Catalyst::Controller->action_for($name) >>. If you have a private action
1303path, use C<< $c->uri_for_action >> instead.
1304
1305 # Equivalent to $c->req->uri
e7e4c469 1306 $c->uri_for($c->action, $c->req->captures,
ee8963de 1307 @{ $c->req->args }, $c->req->params);
62a6df80 1308
9df7c5d9 1309 # For the Foo action in the Bar controller
ee8963de 1310 $c->uri_for($c->controller('Bar')->action_for('Foo'));
9df7c5d9 1311
ee8963de 1312 # Path to a static resource
1313 $c->uri_for('/static/images/logo.png');
d5e3d528 1314
4cf1dd00 1315=cut
1316
fbcc39ad 1317sub uri_for {
00e6a2b7 1318 my ( $c, $path, @args ) = @_;
00e6a2b7 1319
7069eab5 1320 if (blessed($path) && $path->isa('Catalyst::Controller')) {
1321 $path = $path->path_prefix;
1322 $path =~ s{/+\z}{};
1323 $path .= '/';
1324 }
1325
2689f8a4 1326 undef($path) if (defined $path && $path eq '');
1327
1328 my $params =
1329 ( scalar @args && ref $args[$#args] eq 'HASH' ? pop @args : {} );
1330
1331 carp "uri_for called with undef argument" if grep { ! defined $_ } @args;
a4f2cdc8 1332 foreach my $arg (@args) {
1333 utf8::encode($arg) if utf8::is_utf8($arg);
49229f68 1334 $arg =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
2689f8a4 1335 }
1336
7e95ba12 1337 if ( blessed($path) ) { # action object
49229f68 1338 s|/|%2F|g for @args;
2689f8a4 1339 my $captures = [ map { s|/|%2F|g; $_; }
aaf72276 1340 ( scalar @args && ref $args[0] eq 'ARRAY'
1341 ? @{ shift(@args) }
1342 : ()) ];
7b346bc3 1343
1344 foreach my $capture (@$captures) {
1345 utf8::encode($capture) if utf8::is_utf8($capture);
1346 $capture =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
1347 }
1348
aa7e913e 1349 my $action = $path;
1350 $path = $c->dispatcher->uri_for_action($action, $captures);
1351 if (not defined $path) {
1352 $c->log->debug(qq/Can't find uri_for action '$action' @$captures/)
1353 if $c->debug;
1354 return undef;
1355 }
81e75875 1356 $path = '/' if $path eq '';
ea0e58d9 1357 }
1358
51674a63 1359 unshift(@args, $path);
1360
1361 unless (defined $path && $path =~ s!^/!!) { # in-place strip
1362 my $namespace = $c->namespace;
1363 if (defined $path) { # cheesy hack to handle path '../foo'
1364 $namespace =~ s{(?:^|/)[^/]+$}{} while $args[0] =~ s{^\.\./}{};
6601f2ad 1365 }
51674a63 1366 unshift(@args, $namespace || '');
1367 }
62a6df80 1368
189e2a51 1369 # join args with '/', or a blank string
51674a63 1370 my $args = join('/', grep { defined($_) } @args);
1371 $args =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
7a2295bc 1372 $args =~ s!^/+!!;
51674a63 1373 my $base = $c->req->base;
1374 my $class = ref($base);
1375 $base =~ s{(?<!/)$}{/};
1376
1377 my $query = '';
1378
1379 if (my @keys = keys %$params) {
1380 # somewhat lifted from URI::_query's query_form
1381 $query = '?'.join('&', map {
2f381252 1382 my $val = $params->{$_};
51674a63 1383 s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/go;
1384 s/ /+/g;
1385 my $key = $_;
51674a63 1386 $val = '' unless defined $val;
1387 (map {
1f851263 1388 my $param = "$_";
1389 utf8::encode( $param ) if utf8::is_utf8($param);
51674a63 1390 # using the URI::Escape pattern here so utf8 chars survive
1f851263 1391 $param =~ s/([^A-Za-z0-9\-_.!~*'() ])/$URI::Escape::escapes{$1}/go;
1392 $param =~ s/ /+/g;
1393 "${key}=$param"; } ( ref $val eq 'ARRAY' ? @$val : $val ));
51674a63 1394 } @keys);
1395 }
1396
1397 my $res = bless(\"${base}${args}${query}", $class);
d3e7a648 1398 $res;
fbcc39ad 1399}
1400
833b385e 1401=head2 $c->uri_for_action( $path, \@captures?, @args?, \%query_values? )
1402
1403=head2 $c->uri_for_action( $action, \@captures?, @args?, \%query_values? )
1404
1405=over
1406
1407=item $path
1408
1409A private path to the Catalyst action you want to create a URI for.
1410
1411This is a shortcut for calling C<< $c->dispatcher->get_action_by_path($path)
1412>> and passing the resulting C<$action> and the remaining arguments to C<<
1413$c->uri_for >>.
1414
1415You can also pass in a Catalyst::Action object, in which case it is passed to
1416C<< $c->uri_for >>.
1417
c9ec25f8 1418Note that although the path looks like a URI that dispatches to the wanted action, it is not a URI, but an internal path to that action.
1419
1420For example, if the action looks like:
1421
1422 package MyApp::Controller::Users;
1423
1424 sub lst : Path('the-list') {}
1425
1426You can use:
1427
1428 $c->uri_for_action('/users/lst')
1429
1430and it will create the URI /users/the-list.
1431
833b385e 1432=back
1433
1434=cut
1435
1436sub uri_for_action {
1437 my ( $c, $path, @args ) = @_;
62a6df80 1438 my $action = blessed($path)
1439 ? $path
833b385e 1440 : $c->dispatcher->get_action_by_path($path);
4ac0b9cb 1441 unless (defined $action) {
1442 croak "Can't find action for path '$path'";
1443 }
833b385e 1444 return $c->uri_for( $action, @args );
1445}
1446
b5ecfcf0 1447=head2 $c->welcome_message
ab2374d3 1448
1449Returns the Catalyst welcome HTML page.
1450
1451=cut
1452
1453sub welcome_message {
bf1f2c60 1454 my $c = shift;
1455 my $name = $c->config->{name};
1456 my $logo = $c->uri_for('/static/images/catalyst_logo.png');
1457 my $prefix = Catalyst::Utils::appprefix( ref $c );
80cdbbff 1458 $c->response->content_type('text/html; charset=utf-8');
ab2374d3 1459 return <<"EOF";
80cdbbff 1460<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1461 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1462<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
ab2374d3 1463 <head>
85d9fce6 1464 <meta http-equiv="Content-Language" content="en" />
1465 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
ab2374d3 1466 <title>$name on Catalyst $VERSION</title>
1467 <style type="text/css">
1468 body {
ab2374d3 1469 color: #000;
1470 background-color: #eee;
1471 }
1472 div#content {
1473 width: 640px;
80cdbbff 1474 margin-left: auto;
1475 margin-right: auto;
ab2374d3 1476 margin-top: 10px;
1477 margin-bottom: 10px;
1478 text-align: left;
1479 background-color: #ccc;
1480 border: 1px solid #aaa;
ab2374d3 1481 }
d84c4dab 1482 p, h1, h2 {
ab2374d3 1483 margin-left: 20px;
1484 margin-right: 20px;
16215972 1485 font-family: verdana, tahoma, sans-serif;
ab2374d3 1486 }
d84c4dab 1487 a {
1488 font-family: verdana, tahoma, sans-serif;
1489 }
d114e033 1490 :link, :visited {
1491 text-decoration: none;
1492 color: #b00;
1493 border-bottom: 1px dotted #bbb;
1494 }
1495 :link:hover, :visited:hover {
d114e033 1496 color: #555;
1497 }
ab2374d3 1498 div#topbar {
1499 margin: 0px;
1500 }
3e82a295 1501 pre {
3e82a295 1502 margin: 10px;
1503 padding: 8px;
1504 }
ab2374d3 1505 div#answers {
1506 padding: 8px;
1507 margin: 10px;
d114e033 1508 background-color: #fff;
ab2374d3 1509 border: 1px solid #aaa;
ab2374d3 1510 }
1511 h1 {
33108eaf 1512 font-size: 0.9em;
1513 font-weight: normal;
ab2374d3 1514 text-align: center;
1515 }
1516 h2 {
1517 font-size: 1.0em;
1518 }
1519 p {
1520 font-size: 0.9em;
1521 }
ae7c5252 1522 p img {
1523 float: right;
1524 margin-left: 10px;
1525 }
9619f23c 1526 span#appname {
1527 font-weight: bold;
33108eaf 1528 font-size: 1.6em;
ab2374d3 1529 }
1530 </style>
1531 </head>
1532 <body>
1533 <div id="content">
1534 <div id="topbar">
9619f23c 1535 <h1><span id="appname">$name</span> on <a href="http://catalyst.perl.org">Catalyst</a>
d84c4dab 1536 $VERSION</h1>
ab2374d3 1537 </div>
1538 <div id="answers">
ae7c5252 1539 <p>
80cdbbff 1540 <img src="$logo" alt="Catalyst Logo" />
ae7c5252 1541 </p>
596aaffe 1542 <p>Welcome to the world of Catalyst.
f92fd545 1543 This <a href="http://en.wikipedia.org/wiki/MVC">MVC</a>
1544 framework will make web development something you had
60dd6e1d 1545 never expected it to be: Fun, rewarding, and quick.</p>
ab2374d3 1546 <h2>What to do now?</h2>
4b8cb778 1547 <p>That really depends on what <b>you</b> want to do.
ab2374d3 1548 We do, however, provide you with a few starting points.</p>
1549 <p>If you want to jump right into web development with Catalyst
2f381252 1550 you might want to start with a tutorial.</p>
b607f8a0 1551<pre>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Tutorial.pod">Catalyst::Manual::Tutorial</a></code>
596aaffe 1552</pre>
1553<p>Afterwards you can go on to check out a more complete look at our features.</p>
1554<pre>
b607f8a0 1555<code>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Intro.pod">Catalyst::Manual::Intro</a>
1556<!-- Something else should go here, but the Catalyst::Manual link seems unhelpful -->
1557</code></pre>
ab2374d3 1558 <h2>What to do next?</h2>
f5681c92 1559 <p>Next it's time to write an actual application. Use the
80cdbbff 1560 helper scripts to generate <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AController%3A%3A&amp;mode=all">controllers</a>,
60dd6e1d 1561 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AModel%3A%3A&amp;mode=all">models</a>, and
1562 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AView%3A%3A&amp;mode=all">views</a>;
bf1f2c60 1563 they can save you a lot of work.</p>
c5f31918 1564 <pre><code>script/${prefix}_create.pl --help</code></pre>
bf1f2c60 1565 <p>Also, be sure to check out the vast and growing
802bf2cb 1566 collection of <a href="http://search.cpan.org/search?query=Catalyst">plugins for Catalyst on CPAN</a>;
bf1f2c60 1567 you are likely to find what you need there.
f5681c92 1568 </p>
1569
82245cc4 1570 <h2>Need help?</h2>
f5681c92 1571 <p>Catalyst has a very active community. Here are the main places to
1572 get in touch with us.</p>
16215972 1573 <ul>
1574 <li>
2b9a7d76 1575 <a href="http://dev.catalyst.perl.org">Wiki</a>
16215972 1576 </li>
1577 <li>
6d4c3368 1578 <a href="http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst">Mailing-List</a>
16215972 1579 </li>
1580 <li>
4eaf7c88 1581 <a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
16215972 1582 </li>
1583 </ul>
ab2374d3 1584 <h2>In conclusion</h2>
62a6df80 1585 <p>The Catalyst team hopes you will enjoy using Catalyst as much
f5681c92 1586 as we enjoyed making it. Please contact us if you have ideas
1587 for improvement or other feedback.</p>
ab2374d3 1588 </div>
1589 </div>
1590 </body>
1591</html>
1592EOF
1593}
1594
fbcc39ad 1595=head1 INTERNAL METHODS
1596
ae1e6b59 1597These methods are not meant to be used by end users.
1598
b5ecfcf0 1599=head2 $c->components
fbcc39ad 1600
e7f1cf73 1601Returns a hash of components.
fbcc39ad 1602
b5ecfcf0 1603=head2 $c->context_class
1f9cb7c1 1604
e7f1cf73 1605Returns or sets the context class.
1f9cb7c1 1606
b5ecfcf0 1607=head2 $c->counter
fbcc39ad 1608
ae1e6b59 1609Returns a hashref containing coderefs and execution counts (needed for
1610deep recursion detection).
fbcc39ad 1611
b5ecfcf0 1612=head2 $c->depth
fbcc39ad 1613
e7f1cf73 1614Returns the number of actions on the current internal execution stack.
fbcc39ad 1615
b5ecfcf0 1616=head2 $c->dispatch
fbcc39ad 1617
e7f1cf73 1618Dispatches a request to actions.
fbcc39ad 1619
1620=cut
1621
1622sub dispatch { my $c = shift; $c->dispatcher->dispatch( $c, @_ ) }
1623
b5ecfcf0 1624=head2 $c->dispatcher_class
1f9cb7c1 1625
e7f1cf73 1626Returns or sets the dispatcher class.
1f9cb7c1 1627
b5ecfcf0 1628=head2 $c->dump_these
7f92deef 1629
ae1e6b59 1630Returns a list of 2-element array references (name, structure) pairs
1631that will be dumped on the error page in debug mode.
7f92deef 1632
1633=cut
1634
1635sub dump_these {
1636 my $c = shift;
62a6df80 1637 [ Request => $c->req ],
1638 [ Response => $c->res ],
052a2d89 1639 [ Stash => $c->stash ],
1640 [ Config => $c->config ];
7f92deef 1641}
1642
b5ecfcf0 1643=head2 $c->engine_class
1f9cb7c1 1644
e7f1cf73 1645Returns or sets the engine class.
1f9cb7c1 1646
b5ecfcf0 1647=head2 $c->execute( $class, $coderef )
fbcc39ad 1648
0ef52a96 1649Execute a coderef in given class and catch exceptions. Errors are available
1650via $c->error.
fbcc39ad 1651
1652=cut
1653
1654sub execute {
1655 my ( $c, $class, $code ) = @_;
858828dd 1656 $class = $c->component($class) || $class;
fbcc39ad 1657 $c->state(0);
a0eca838 1658
197bd788 1659 if ( $c->depth >= $RECURSION ) {
f3414019 1660 my $action = $code->reverse();
91d08727 1661 $action = "/$action" unless $action =~ /->/;
f3414019 1662 my $error = qq/Deep recursion detected calling "${action}"/;
1627551a 1663 $c->log->error($error);
1664 $c->error($error);
1665 $c->state(0);
1666 return $c->state;
1667 }
1668
dc5f035e 1669 my $stats_info = $c->_stats_start_execute( $code ) if $c->use_stats;
22247e54 1670
8767c5a3 1671 push( @{ $c->stack }, $code );
62a6df80 1672
6f3df815 1673 no warnings 'recursion';
524b0e1c 1674 # N.B. This used to be combined, but I have seen $c get clobbered if so, and
1675 # I have no idea how, ergo $ret (which appears to fix the issue)
1676 eval { my $ret = $code->execute( $class, $c, @{ $c->req->args } ) || 0; $c->state( $ret ) };
22247e54 1677
dc5f035e 1678 $c->_stats_finish_execute( $stats_info ) if $c->use_stats and $stats_info;
62a6df80 1679
a6724a82 1680 my $last = pop( @{ $c->stack } );
fbcc39ad 1681
1682 if ( my $error = $@ ) {
79f5d571 1683 if ( blessed($error) and $error->isa('Catalyst::Exception::Detach') ) {
f87b7c21 1684 $error->rethrow if $c->depth > 1;
2f381252 1685 }
79f5d571 1686 elsif ( blessed($error) and $error->isa('Catalyst::Exception::Go') ) {
f87b7c21 1687 $error->rethrow if $c->depth > 0;
55424863 1688 }
fbcc39ad 1689 else {
1690 unless ( ref $error ) {
91d08727 1691 no warnings 'uninitialized';
fbcc39ad 1692 chomp $error;
f59def82 1693 my $class = $last->class;
1694 my $name = $last->name;
1695 $error = qq/Caught exception in $class->$name "$error"/;
fbcc39ad 1696 }
fbcc39ad 1697 $c->error($error);
fbcc39ad 1698 }
2688734f 1699 $c->state(0);
fbcc39ad 1700 }
1701 return $c->state;
1702}
1703
7a7d7af5 1704sub _stats_start_execute {
1705 my ( $c, $code ) = @_;
df960201 1706 my $appclass = ref($c) || $c;
a6724a82 1707 return if ( ( $code->name =~ /^_.*/ )
df960201 1708 && ( !$appclass->config->{show_internal_actions} ) );
7a7d7af5 1709
f3414019 1710 my $action_name = $code->reverse();
1711 $c->counter->{$action_name}++;
7a7d7af5 1712
f3414019 1713 my $action = $action_name;
a6724a82 1714 $action = "/$action" unless $action =~ /->/;
1715
7a7d7af5 1716 # determine if the call was the result of a forward
1717 # this is done by walking up the call stack and looking for a calling
1718 # sub of Catalyst::forward before the eval
1719 my $callsub = q{};
1720 for my $index ( 2 .. 11 ) {
1721 last
1722 if ( ( caller($index) )[0] eq 'Catalyst'
1723 && ( caller($index) )[3] eq '(eval)' );
1724
1725 if ( ( caller($index) )[3] =~ /forward$/ ) {
1726 $callsub = ( caller($index) )[3];
1727 $action = "-> $action";
1728 last;
1729 }
1730 }
1731
f3414019 1732 my $uid = $action_name . $c->counter->{$action_name};
74efc144 1733
a6724a82 1734 # is this a root-level call or a forwarded call?
1735 if ( $callsub =~ /forward$/ ) {
91740f34 1736 my $parent = $c->stack->[-1];
a6724a82 1737
1738 # forward, locate the caller
9c74923d 1739 if ( defined $parent && exists $c->counter->{"$parent"} ) {
69d8f33c 1740 $c->stats->profile(
62a6df80 1741 begin => $action,
69d8f33c 1742 parent => "$parent" . $c->counter->{"$parent"},
1743 uid => $uid,
1744 );
7a7d7af5 1745 }
1746 else {
1747
a6724a82 1748 # forward with no caller may come from a plugin
69d8f33c 1749 $c->stats->profile(
1750 begin => $action,
1751 uid => $uid,
1752 );
7a7d7af5 1753 }
1754 }
a6724a82 1755 else {
62a6df80 1756
a6724a82 1757 # root-level call
69d8f33c 1758 $c->stats->profile(
1759 begin => $action,
1760 uid => $uid,
1761 );
a6724a82 1762 }
dc5f035e 1763 return $action;
7a7d7af5 1764
7a7d7af5 1765}
1766
1767sub _stats_finish_execute {
1768 my ( $c, $info ) = @_;
69d8f33c 1769 $c->stats->profile( end => $info );
7a7d7af5 1770}
1771
b5ecfcf0 1772=head2 $c->finalize
fbcc39ad 1773
e7f1cf73 1774Finalizes the request.
fbcc39ad 1775
1776=cut
1777
1778sub finalize {
1779 my $c = shift;
1780
369c09bc 1781 for my $error ( @{ $c->error } ) {
1782 $c->log->error($error);
1783 }
1784
5050d7a7 1785 # Allow engine to handle finalize flow (for POE)
e63bdf38 1786 my $engine = $c->engine;
1787 if ( my $code = $engine->can('finalize') ) {
1788 $engine->$code($c);
fbcc39ad 1789 }
5050d7a7 1790 else {
fbcc39ad 1791
5050d7a7 1792 $c->finalize_uploads;
fbcc39ad 1793
5050d7a7 1794 # Error
1795 if ( $#{ $c->error } >= 0 ) {
1796 $c->finalize_error;
1797 }
1798
1799 $c->finalize_headers;
fbcc39ad 1800
5050d7a7 1801 # HEAD request
1802 if ( $c->request->method eq 'HEAD' ) {
1803 $c->response->body('');
1804 }
1805
1806 $c->finalize_body;
1807 }
62a6df80 1808
2bf54936 1809 $c->log_response;
10f204e1 1810
62a6df80 1811 if ($c->use_stats) {
596677b6 1812 my $elapsed = sprintf '%f', $c->stats->elapsed;
12bf12c0 1813 my $av = $elapsed == 0 ? '??' : sprintf '%.3f', 1 / $elapsed;
908e3d9e 1814 $c->log->info(
62a6df80 1815 "Request took ${elapsed}s ($av/s)\n" . $c->stats->report . "\n" );
908e3d9e 1816 }
fbcc39ad 1817
1818 return $c->response->status;
1819}
1820
b5ecfcf0 1821=head2 $c->finalize_body
fbcc39ad 1822
e7f1cf73 1823Finalizes body.
fbcc39ad 1824
1825=cut
1826
1827sub finalize_body { my $c = shift; $c->engine->finalize_body( $c, @_ ) }
1828
b5ecfcf0 1829=head2 $c->finalize_cookies
fbcc39ad 1830
e7f1cf73 1831Finalizes cookies.
fbcc39ad 1832
1833=cut
1834
147821ea 1835sub finalize_cookies { my $c = shift; $c->engine->finalize_cookies( $c, @_ ) }
fbcc39ad 1836
b5ecfcf0 1837=head2 $c->finalize_error
fbcc39ad 1838
e7f1cf73 1839Finalizes error.
fbcc39ad 1840
1841=cut
1842
1843sub finalize_error { my $c = shift; $c->engine->finalize_error( $c, @_ ) }
1844
b5ecfcf0 1845=head2 $c->finalize_headers
fbcc39ad 1846
e7f1cf73 1847Finalizes headers.
fbcc39ad 1848
1849=cut
1850
1851sub finalize_headers {
1852 my $c = shift;
1853
e63bdf38 1854 my $response = $c->response; #accessor calls can add up?
1855
fbcc39ad 1856 # Check if we already finalized headers
6680c772 1857 return if $response->finalized_headers;
fbcc39ad 1858
1859 # Handle redirects
e63bdf38 1860 if ( my $location = $response->redirect ) {
fbcc39ad 1861 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
e63bdf38 1862 $response->header( Location => $location );
a7caa492 1863
02570318 1864 if ( !$response->has_body ) {
39655cdc 1865 # Add a default body if none is already present
e63bdf38 1866 $response->body(
e422816e 1867 qq{<html><body><p>This item has moved <a href="$location">here</a>.</p></body></html>}
39655cdc 1868 );
1869 }
fbcc39ad 1870 }
1871
1872 # Content-Length
ac057d3b 1873 if ( defined $response->body && length $response->body && !$response->content_length ) {
775878ac 1874
8f62c91a 1875 # get the length from a filehandle
9c74923d 1876 if ( blessed( $response->body ) && $response->body->can('read') || ref( $response->body ) eq 'GLOB' )
197bd788 1877 {
34effbc7 1878 my $size = -s $response->body;
1879 if ( $size ) {
1880 $response->content_length( $size );
8f62c91a 1881 }
1882 else {
775878ac 1883 $c->log->warn('Serving filehandle without a content-length');
8f62c91a 1884 }
1885 }
1886 else {
b5d7a61f 1887 # everything should be bytes at this point, but just in case
5ab21903 1888 $response->content_length( length( $response->body ) );
8f62c91a 1889 }
fbcc39ad 1890 }
1891
1892 # Errors
e63bdf38 1893 if ( $response->status =~ /^(1\d\d|[23]04)$/ ) {
1894 $response->headers->remove_header("Content-Length");
1895 $response->body('');
fbcc39ad 1896 }
1897
1898 $c->finalize_cookies;
1899
1900 $c->engine->finalize_headers( $c, @_ );
1901
1902 # Done
6680c772 1903 $response->finalized_headers(1);
fbcc39ad 1904}
1905
b5ecfcf0 1906=head2 $c->finalize_output
fbcc39ad 1907
1908An alias for finalize_body.
1909
b5ecfcf0 1910=head2 $c->finalize_read
fbcc39ad 1911
e7f1cf73 1912Finalizes the input after reading is complete.
fbcc39ad 1913
1914=cut
1915
1916sub finalize_read { my $c = shift; $c->engine->finalize_read( $c, @_ ) }
1917
b5ecfcf0 1918=head2 $c->finalize_uploads
fbcc39ad 1919
ae1e6b59 1920Finalizes uploads. Cleans up any temporary files.
fbcc39ad 1921
1922=cut
1923
1924sub finalize_uploads { my $c = shift; $c->engine->finalize_uploads( $c, @_ ) }
1925
b5ecfcf0 1926=head2 $c->get_action( $action, $namespace )
fbcc39ad 1927
e7f1cf73 1928Gets an action in a given namespace.
fbcc39ad 1929
1930=cut
1931
684d10ed 1932sub get_action { my $c = shift; $c->dispatcher->get_action(@_) }
fbcc39ad 1933
b5ecfcf0 1934=head2 $c->get_actions( $action, $namespace )
a9dc674c 1935
ae1e6b59 1936Gets all actions of a given name in a namespace and all parent
1937namespaces.
a9dc674c 1938
1939=cut
1940
1941sub get_actions { my $c = shift; $c->dispatcher->get_actions( $c, @_ ) }
1942
e5ce5f04 1943=head2 $app->handle_request( @arguments )
fbcc39ad 1944
e7f1cf73 1945Called to handle each HTTP request.
fbcc39ad 1946
1947=cut
1948
1949sub handle_request {
1950 my ( $class, @arguments ) = @_;
1951
1952 # Always expect worst case!
1953 my $status = -1;
3640641e 1954 try {
dea1884f 1955 if ($class->debug) {
908e3d9e 1956 my $secs = time - $START || 1;
1957 my $av = sprintf '%.3f', $COUNT / $secs;
1958 my $time = localtime time;
1959 $class->log->info("*** Request $COUNT ($av/s) [$$] [$time] ***");
dea1884f 1960 }
908e3d9e 1961
1962 my $c = $class->prepare(@arguments);
1963 $c->dispatch;
62a6df80 1964 $status = $c->finalize;
fbcc39ad 1965 }
3640641e 1966 catch {
1967 chomp(my $error = $_);
1968 $class->log->error(qq/Caught exception in engine "$error"/);
1969 };
fbcc39ad 1970
1971 $COUNT++;
62a6df80 1972
6680c772 1973 if(my $coderef = $class->log->can('_flush')){
1974 $class->log->$coderef();
1975 }
fbcc39ad 1976 return $status;
1977}
1978
b5ecfcf0 1979=head2 $c->prepare( @arguments )
fbcc39ad 1980
ae1e6b59 1981Creates a Catalyst context from an engine-specific request (Apache, CGI,
1982etc.).
fbcc39ad 1983
1984=cut
1985
1986sub prepare {
1987 my ( $class, @arguments ) = @_;
1988
6680c772 1989 # XXX
1990 # After the app/ctxt split, this should become an attribute based on something passed
1991 # into the application.
3cec521a 1992 $class->context_class( ref $class || $class ) unless $class->context_class;
62a6df80 1993
6680c772 1994 my $c = $class->context_class->new({});
1995
1996 # For on-demand data
1997 $c->request->_context($c);
1998 $c->response->_context($c);
fbcc39ad 1999
b6d4ee6e 2000 #surely this is not the most efficient way to do things...
dc5f035e 2001 $c->stats($class->stats_class->new)->enable($c->use_stats);
4f0b7cf1 2002 if ( $c->debug || $c->config->{enable_catalyst_header} ) {
62a6df80 2003 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
908e3d9e 2004 }
2005
3640641e 2006 try {
2007 # Allow engine to direct the prepare flow (for POE)
2008 if ( my $prepare = $c->engine->can('prepare') ) {
2009 $c->engine->$prepare( $c, @arguments );
2010 }
2011 else {
2012 $c->prepare_request(@arguments);
2013 $c->prepare_connection;
2014 $c->prepare_query_parameters;
2015 $c->prepare_headers;
2016 $c->prepare_cookies;
2017 $c->prepare_path;
2018
2019 # Prepare the body for reading, either by prepare_body
2020 # or the user, if they are using $c->read
2021 $c->prepare_read;
2022
2023 # Parse the body unless the user wants it on-demand
2024 unless ( ref($c)->config->{parse_on_demand} ) {
2025 $c->prepare_body;
2026 }
878b821c 2027 }
5050d7a7 2028 }
3640641e 2029 # VERY ugly and probably shouldn't rely on ->finalize actually working
2030 catch {
2031 # failed prepare is always due to an invalid request, right?
2032 $c->response->status(400);
2033 $c->response->content_type('text/plain');
2034 $c->response->body('Bad Request');
2035 $c->finalize;
2036 die $_;
2037 };
fbcc39ad 2038
fbcc39ad 2039 my $method = $c->req->method || '';
2f381252 2040 my $path = $c->req->path;
2041 $path = '/' unless length $path;
fbcc39ad 2042 my $address = $c->req->address || '';
2043
10f204e1 2044 $c->log_request;
fbcc39ad 2045
e3a13771 2046 $c->prepare_action;
2047
fbcc39ad 2048 return $c;
2049}
2050
b5ecfcf0 2051=head2 $c->prepare_action
fbcc39ad 2052
b4b01a8a 2053Prepares action. See L<Catalyst::Dispatcher>.
fbcc39ad 2054
2055=cut
2056
2057sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
2058
b5ecfcf0 2059=head2 $c->prepare_body
fbcc39ad 2060
e7f1cf73 2061Prepares message body.
fbcc39ad 2062
2063=cut
2064
2065sub prepare_body {
2066 my $c = shift;
2067
0f56bbcf 2068 return if $c->request->_has_body;
fbcc39ad 2069
2070 # Initialize on-demand data
2071 $c->engine->prepare_body( $c, @_ );
2072 $c->prepare_parameters;
2073 $c->prepare_uploads;
fbcc39ad 2074}
2075
b5ecfcf0 2076=head2 $c->prepare_body_chunk( $chunk )
4bd82c41 2077
e7f1cf73 2078Prepares a chunk of data before sending it to L<HTTP::Body>.
4bd82c41 2079
b4b01a8a 2080See L<Catalyst::Engine>.
2081
4bd82c41 2082=cut
2083
4f5ebacd 2084sub prepare_body_chunk {
2085 my $c = shift;
4bd82c41 2086 $c->engine->prepare_body_chunk( $c, @_ );
2087}
2088
b5ecfcf0 2089=head2 $c->prepare_body_parameters
fbcc39ad 2090
e7f1cf73 2091Prepares body parameters.
fbcc39ad 2092
2093=cut
2094
2095sub prepare_body_parameters {
2096 my $c = shift;
2097 $c->engine->prepare_body_parameters( $c, @_ );
2098}
2099
b5ecfcf0 2100=head2 $c->prepare_connection
fbcc39ad 2101
e7f1cf73 2102Prepares connection.
fbcc39ad 2103
2104=cut
2105
2106sub prepare_connection {
2107 my $c = shift;
2108 $c->engine->prepare_connection( $c, @_ );
2109}
2110
b5ecfcf0 2111=head2 $c->prepare_cookies
fbcc39ad 2112
e7f1cf73 2113Prepares cookies.
fbcc39ad 2114
2115=cut
2116
2117sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
2118
b5ecfcf0 2119=head2 $c->prepare_headers
fbcc39ad 2120
e7f1cf73 2121Prepares headers.
fbcc39ad 2122
2123=cut
2124
2125sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
2126
b5ecfcf0 2127=head2 $c->prepare_parameters
fbcc39ad 2128
e7f1cf73 2129Prepares parameters.
fbcc39ad 2130
2131=cut
2132
2133sub prepare_parameters {
2134 my $c = shift;
2135 $c->prepare_body_parameters;
2136 $c->engine->prepare_parameters( $c, @_ );
2137}
2138
b5ecfcf0 2139=head2 $c->prepare_path
fbcc39ad 2140
e7f1cf73 2141Prepares path and base.
fbcc39ad 2142
2143=cut
2144
2145sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
2146
b5ecfcf0 2147=head2 $c->prepare_query_parameters
fbcc39ad 2148
e7f1cf73 2149Prepares query parameters.
fbcc39ad 2150
2151=cut
2152
2153sub prepare_query_parameters {
2154 my $c = shift;
2155
2156 $c->engine->prepare_query_parameters( $c, @_ );
10f204e1 2157}
fbcc39ad 2158
10f204e1 2159=head2 $c->log_request
2160
2161Writes information about the request to the debug logs. This includes:
2162
2163=over 4
2164
854e5dcd 2165=item * Request method, path, and remote IP address
10f204e1 2166
2167=item * Query keywords (see L<Catalyst::Request/query_keywords>)
2168
e7cbe1bf 2169=item * Request parameters
10f204e1 2170
2171=item * File uploads
2172
2173=back
fbcc39ad 2174
2175=cut
2176
10f204e1 2177sub log_request {
2178 my $c = shift;
fbcc39ad 2179
10f204e1 2180 return unless $c->debug;
fbcc39ad 2181
2bf54936 2182 my($dump) = grep {$_->[0] eq 'Request' } $c->dump_these;
2183 my $request = $dump->[1];
e7cbe1bf 2184
2185 my ( $method, $path, $address ) = ( $request->method, $request->path, $request->address );
10f204e1 2186 $method ||= '';
2187 $path = '/' unless length $path;
2188 $address ||= '';
2189 $c->log->debug(qq/"$method" request for "$path" from "$address"/);
2190
3a4abdb3 2191 $c->log_request_headers($request->headers);
e7cbe1bf 2192
2193 if ( my $keywords = $request->query_keywords ) {
10f204e1 2194 $c->log->debug("Query keywords are: $keywords");
fbcc39ad 2195 }
10f204e1 2196
9c74923d 2197 $c->log_request_parameters( query => $request->query_parameters, $request->_has_body ? (body => $request->body_parameters) : () );
10f204e1 2198
e7cbe1bf 2199 $c->log_request_uploads($request);
fbcc39ad 2200}
2201
10f204e1 2202=head2 $c->log_response
fbcc39ad 2203
75b65816 2204Writes information about the response to the debug logs by calling
2205C<< $c->log_response_status_line >> and C<< $c->log_response_headers >>.
fbcc39ad 2206
2207=cut
2208
75b65816 2209sub log_response {
2210 my $c = shift;
fbcc39ad 2211
75b65816 2212 return unless $c->debug;
fbcc39ad 2213
75b65816 2214 my($dump) = grep {$_->[0] eq 'Response' } $c->dump_these;
2215 my $response = $dump->[1];
2216
2217 $c->log_response_status_line($response);
2218 $c->log_response_headers($response->headers);
2219}
2220
2221=head2 $c->log_response_status_line($response)
2222
2223Writes one line of information about the response to the debug logs. This includes:
10f204e1 2224
2225=over 4
2226
2227=item * Response status code
2228
3a4abdb3 2229=item * Content-Type header (if present)
2230
2231=item * Content-Length header (if present)
10f204e1 2232
2233=back
fbcc39ad 2234
2235=cut
2236
75b65816 2237sub log_response_status_line {
2238 my ($c, $response) = @_;
fbcc39ad 2239
697bab77 2240 $c->log->debug(
2241 sprintf(
2242 'Response Code: %s; Content-Type: %s; Content-Length: %s',
2243 $response->status || 'unknown',
2244 $response->headers->header('Content-Type') || 'unknown',
2245 $response->headers->header('Content-Length') || 'unknown'
2246 )
2247 );
10f204e1 2248}
fbcc39ad 2249
75b65816 2250=head2 $c->log_response_headers($headers);
2251
2252Hook method which can be wrapped by plugins to log the responseheaders.
2253No-op in the default implementation.
fbcc39ad 2254
2255=cut
2256
75b65816 2257sub log_response_headers {}
fbcc39ad 2258
10f204e1 2259=head2 $c->log_request_parameters( query => {}, body => {} )
2260
2261Logs request parameters to debug logs
2262
10f204e1 2263=cut
2264
2265sub log_request_parameters {
2266 my $c = shift;
2267 my %all_params = @_;
2268
2bf54936 2269 return unless $c->debug;
e7cbe1bf 2270
10f204e1 2271 my $column_width = Catalyst::Utils::term_width() - 44;
2272 foreach my $type (qw(query body)) {
2bf54936 2273 my $params = $all_params{$type};
2274 next if ! keys %$params;
10f204e1 2275 my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ $column_width, 'Value' ] );
e7cbe1bf 2276 for my $key ( sort keys %$params ) {
2277 my $param = $params->{$key};
10f204e1 2278 my $value = defined($param) ? $param : '';
2279 $t->row( $key, ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
2280 }
2281 $c->log->debug( ucfirst($type) . " Parameters are:\n" . $t->draw );
2282 }
2283}
2284
2285=head2 $c->log_request_uploads
2286
2287Logs file uploads included in the request to the debug logs.
854e5dcd 2288The parameter name, filename, file type, and file size are all included in
10f204e1 2289the debug logs.
2290
2291=cut
fbcc39ad 2292
10f204e1 2293sub log_request_uploads {
2294 my $c = shift;
2bf54936 2295 my $request = shift;
e7cbe1bf 2296 return unless $c->debug;
2297 my $uploads = $request->uploads;
10f204e1 2298 if ( keys %$uploads ) {
8c113188 2299 my $t = Text::SimpleTable->new(
34d28dfd 2300 [ 12, 'Parameter' ],
2301 [ 26, 'Filename' ],
8c113188 2302 [ 18, 'Type' ],
2303 [ 9, 'Size' ]
2304 );
10f204e1 2305 for my $key ( sort keys %$uploads ) {
2306 my $upload = $uploads->{$key};
fbcc39ad 2307 for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
8c113188 2308 $t->row( $key, $u->filename, $u->type, $u->size );
fbcc39ad 2309 }
2310 }
2311 $c->log->debug( "File Uploads are:\n" . $t->draw );
2312 }
2313}
2314
3a4abdb3 2315=head2 $c->log_request_headers($headers);
2316
2317Hook method which can be wrapped by plugins to log the request headers.
2318No-op in the default implementation.
2319
2320=cut
2321
2322sub log_request_headers {}
2323
10f204e1 2324=head2 $c->log_headers($type => $headers)
2325
e7cbe1bf 2326Logs L<HTTP::Headers> (either request or response) to the debug logs.
10f204e1 2327
2328=cut
2329
2330sub log_headers {
2331 my $c = shift;
2332 my $type = shift;
2333 my $headers = shift; # an HTTP::Headers instance
2334
e7cbe1bf 2335 return unless $c->debug;
10f204e1 2336
f0e9921a 2337 my $column_width = Catalyst::Utils::term_width() - 28;
2338 my $t = Text::SimpleTable->new( [ 15, 'Header Name' ], [ $column_width, 'Value' ] );
e7cbe1bf 2339 $headers->scan(
10f204e1 2340 sub {
2341 my ( $name, $value ) = @_;
2342 $t->row( $name, $value );
2343 }
2344 );
2345 $c->log->debug( ucfirst($type) . " Headers:\n" . $t->draw );
2346}
2347
10f204e1 2348
2349=head2 $c->prepare_read
2350
2351Prepares the input for reading.
2352
2353=cut
2354
2355sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
2356
2357=head2 $c->prepare_request
2358
2359Prepares the engine request.
2360
2361=cut
2362
2363sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
2364
2365=head2 $c->prepare_uploads
2366
2367Prepares uploads.
2368
2369=cut
2370
2371sub prepare_uploads {
2372 my $c = shift;
2373
2374 $c->engine->prepare_uploads( $c, @_ );
2375}
2376
b5ecfcf0 2377=head2 $c->prepare_write
fbcc39ad 2378
e7f1cf73 2379Prepares the output for writing.
fbcc39ad 2380
2381=cut
2382
2383sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
2384
b5ecfcf0 2385=head2 $c->request_class
1f9cb7c1 2386
3f87d500 2387Returns or sets the request class. Defaults to L<Catalyst::Request>.
1f9cb7c1 2388
b5ecfcf0 2389=head2 $c->response_class
1f9cb7c1 2390
3f87d500 2391Returns or sets the response class. Defaults to L<Catalyst::Response>.
1f9cb7c1 2392
b5ecfcf0 2393=head2 $c->read( [$maxlength] )
fbcc39ad 2394
ae1e6b59 2395Reads a chunk of data from the request body. This method is designed to
2396be used in a while loop, reading C<$maxlength> bytes on every call.
2397C<$maxlength> defaults to the size of the request if not specified.
fbcc39ad 2398
4600a5a1 2399You have to set C<< MyApp->config(parse_on_demand => 1) >> to use this
ae1e6b59 2400directly.
fbcc39ad 2401
878b821c 2402Warning: If you use read(), Catalyst will not process the body,
2403so you will not be able to access POST parameters or file uploads via
2404$c->request. You must handle all body parsing yourself.
2405
fbcc39ad 2406=cut
2407
2408sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
2409
b5ecfcf0 2410=head2 $c->run
fbcc39ad 2411
2412Starts the engine.
2413
2414=cut
2415
0c6352ff 2416sub run {
2417 my $app = shift;
2418 $app->engine_loader->needs_psgi_engine_compat_hack ?
2419 $app->engine->run($app, @_) :
2420 $app->engine->run( $app, $app->_finalized_psgi_app, @_ );
2421}
fbcc39ad 2422
b5ecfcf0 2423=head2 $c->set_action( $action, $code, $namespace, $attrs )
fbcc39ad 2424
e7f1cf73 2425Sets an action in a given namespace.
fbcc39ad 2426
2427=cut
2428
2429sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
2430
b5ecfcf0 2431=head2 $c->setup_actions($component)
fbcc39ad 2432
e7f1cf73 2433Sets up actions for a component.
fbcc39ad 2434
2435=cut
2436
2437sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
2438
b5ecfcf0 2439=head2 $c->setup_components
fbcc39ad 2440
d261d153 2441This method is called internally to set up the application's components.
fbcc39ad 2442
d261d153 2443It finds modules by calling the L<locate_components> method, expands them to
2444package names with the L<expand_component_module> method, and then installs
2445each component into the application.
2446
2447The C<setup_components> config option is passed to both of the above methods.
fbcc39ad 2448
d261d153 2449Installation of each component is performed by the L<setup_component> method,
2450below.
2f381252 2451
fbcc39ad 2452=cut
2453
2454sub setup_components {
2455 my $class = shift;
2456
18de900e 2457 my $config = $class->config->{ setup_components };
62a6df80 2458
69c6b6cb 2459 my @comps = $class->locate_components($config);
b94b200c 2460 my %comps = map { $_ => 1 } @comps;
73e1183e 2461
8f6cebb2 2462 my $deprecatedcatalyst_component_names = grep { /::[CMV]::/ } @comps;
73e1183e 2463 $class->log->warn(qq{Your application is using the deprecated ::[MVC]:: type naming scheme.\n}.
2464 qq{Please switch your class names to ::Model::, ::View:: and ::Controller: as appropriate.\n}
8f6cebb2 2465 ) if $deprecatedcatalyst_component_names;
73e1183e 2466
b94b200c 2467 for my $component ( @comps ) {
dd91afb5 2468
2469 # We pass ignore_loaded here so that overlay files for (e.g.)
2470 # Model::DBI::Schema sub-classes are loaded - if it's in @comps
2471 # we know M::P::O found a file on disk so this is safe
2472
f5a4863c 2473 Catalyst::Utils::ensure_class_loaded( $component, { ignore_loaded => 1 } );
196f06d1 2474 }
2475
e7e4c469 2476 for my $component (@comps) {
5d02e790 2477 my $instance = $class->components->{ $component } = $class->setup_component($component);
2478 my @expanded_components = $instance->can('expand_modules')
2479 ? $instance->expand_modules( $component, $config )
2480 : $class->expand_component_module( $component, $config );
2481 for my $component (@expanded_components) {
05887b58 2482 next if $comps{$component};
e7e4c469 2483 $class->components->{ $component } = $class->setup_component($component);
fbcc39ad 2484 }
364d7324 2485 }
2486}
fbcc39ad 2487
d261d153 2488=head2 $c->locate_components( $setup_component_config )
2489
2490This method is meant to provide a list of component modules that should be
2491setup for the application. By default, it will use L<Module::Pluggable>.
2492
2493Specify a C<setup_components> config option to pass additional options directly
2494to L<Module::Pluggable>. To add additional search paths, specify a key named
2495C<search_extra> as an array reference. Items in the array beginning with C<::>
2496will have the application class name prepended to them.
2497
2498=cut
2499
2500sub locate_components {
2501 my $class = shift;
2502 my $config = shift;
2503
2504 my @paths = qw( ::Controller ::C ::Model ::M ::View ::V );
2505 my $extra = delete $config->{ search_extra } || [];
2506
2507 push @paths, @$extra;
2508
2509 my $locator = Module::Pluggable::Object->new(
2510 search_path => [ map { s/^(?=::)/$class/; $_; } @paths ],
2511 %$config
2512 );
2513
69c6b6cb 2514 # XXX think about ditching this sort entirely
2515 my @comps = sort { length $a <=> length $b } $locator->plugins;
d261d153 2516
2517 return @comps;
2518}
2519
2520=head2 $c->expand_component_module( $component, $setup_component_config )
2521
2522Components found by C<locate_components> will be passed to this method, which
2523is expected to return a list of component (package) names to be set up.
2524
d261d153 2525=cut
2526
2527sub expand_component_module {
2528 my ($class, $module) = @_;
05887b58 2529 return Devel::InnerPackage::list_packages( $module );
d261d153 2530}
2531
364d7324 2532=head2 $c->setup_component
fbcc39ad 2533
364d7324 2534=cut
fbcc39ad 2535
364d7324 2536sub setup_component {
2537 my( $class, $component ) = @_;
fbcc39ad 2538
364d7324 2539 unless ( $component->can( 'COMPONENT' ) ) {
2540 return $component;
2541 }
fbcc39ad 2542
364d7324 2543 my $suffix = Catalyst::Utils::class2classsuffix( $component );
2544 my $config = $class->config->{ $suffix } || {};
8f6cebb2 2545 # Stash catalyst_component_name in the config here, so that custom COMPONENT
d2598ac8 2546 # methods also pass it. local to avoid pointlessly shitting in config
2547 # for the debug screen, as $component is already the key name.
8f6cebb2 2548 local $config->{catalyst_component_name} = $component;
fbcc39ad 2549
364d7324 2550 my $instance = eval { $component->COMPONENT( $class, $config ); };
fbcc39ad 2551
2552 if ( my $error = $@ ) {
fbcc39ad 2553 chomp $error;
fbcc39ad 2554 Catalyst::Exception->throw(
364d7324 2555 message => qq/Couldn't instantiate component "$component", "$error"/
2556 );
fbcc39ad 2557 }
2558
7490de2a 2559 unless (blessed $instance) {
2560 my $metaclass = Moose::Util::find_meta($component);
2561 my $method_meta = $metaclass->find_method_by_name('COMPONENT');
2562 my $component_method_from = $method_meta->associated_metaclass->name;
637fa644 2563 my $value = defined($instance) ? $instance : 'undef';
7490de2a 2564 Catalyst::Exception->throw(
2565 message =>
637fa644 2566 qq/Couldn't instantiate component "$component", COMPONENT() method (from $component_method_from) didn't return an object-like value (value was $value)./
7490de2a 2567 );
2568 }
364d7324 2569 return $instance;
fbcc39ad 2570}
2571
b5ecfcf0 2572=head2 $c->setup_dispatcher
fbcc39ad 2573
ae1e6b59 2574Sets up dispatcher.
2575
fbcc39ad 2576=cut
2577
2578sub setup_dispatcher {
2579 my ( $class, $dispatcher ) = @_;
2580
2581 if ($dispatcher) {
2582 $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
2583 }
2584
cb69249e 2585 if ( my $env = Catalyst::Utils::env_value( $class, 'DISPATCHER' ) ) {
2586 $dispatcher = 'Catalyst::Dispatcher::' . $env;
fbcc39ad 2587 }
2588
2589 unless ($dispatcher) {
cb0354c6 2590 $dispatcher = $class->dispatcher_class;
fbcc39ad 2591 }
2592
e63bdf38 2593 Class::MOP::load_class($dispatcher);
fbcc39ad 2594
2595 # dispatcher instance
2596 $class->dispatcher( $dispatcher->new );
2597}
2598
b5ecfcf0 2599=head2 $c->setup_engine
fbcc39ad 2600
ae1e6b59 2601Sets up engine.
2602
fbcc39ad 2603=cut
2604
1e5dad00 2605sub engine_class {
a8153308 2606 my ($class, $requested_engine) = @_;
2607
2608 if (!$class->engine_loader || $requested_engine) {
2609 $class->engine_loader(
2610 Catalyst::EngineLoader->new({
2611 application_name => $class,
2612 (defined $requested_engine
2613 ? (requested_engine => $requested_engine) : ()),
2614 }),
2615 );
2616 }
8ee06de7 2617 $class->engine_loader->catalyst_engine_class;
1e5dad00 2618}
2619
fbcc39ad 2620sub setup_engine {
a26a6adb 2621 my ($class, $requested_engine) = @_;
1085c936 2622
a8153308 2623 my $engine = $class->engine_class($requested_engine);
1e5dad00 2624
2e1f92a3 2625 # Don't really setup_engine -- see _setup_psgi_app for explanation.
2626 return if $class->loading_psgi_file;
2627
e63bdf38 2628 Class::MOP::load_class($engine);
0e7f5826 2629
532f0516 2630 if ($ENV{MOD_PERL}) {
1e5dad00 2631 my $apache = $class->engine_loader->auto;
ab4df9f8 2632
2633 my $meta = find_meta($class);
2634 my $was_immutable = $meta->is_immutable;
2635 my %immutable_options = $meta->immutable_options;
2636 $meta->make_mutable if $was_immutable;
2637
2638 $meta->add_method(handler => sub {
9fe15721 2639 my $r = shift;
1e5dad00 2640 my $psgi_app = $class->psgi_app;
2641 $apache->call_app($r, $psgi_app);
9fe15721 2642 });
ab4df9f8 2643
2644 $meta->make_immutable(%immutable_options) if $was_immutable;
532f0516 2645 }
2646
fbcc39ad 2647 $class->engine( $engine->new );
9fe15721 2648
fcffcb05 2649 return;
2650}
2651
8f076801 2652sub _finalized_psgi_app {
c8f4781e 2653 my ($app) = @_;
a0eec1fb 2654
2655 unless ($app->_psgi_app) {
8f076801 2656 my $psgi_app = $app->_setup_psgi_app;
a0eec1fb 2657 $app->_psgi_app($psgi_app);
2658 }
2659
2660 return $app->_psgi_app;
c8f4781e 2661}
2662
8f076801 2663sub _setup_psgi_app {
fcffcb05 2664 my ($app) = @_;
2665
1085c936 2666 for my $home (Path::Class::Dir->new($app->config->{home})) {
fcffcb05 2667 my $psgi_file = $home->file(
2668 Catalyst::Utils::appprefix($app) . '.psgi',
2669 );
2670
1085c936 2671 next unless -e $psgi_file;
2e1f92a3 2672
2673 # If $psgi_file calls ->setup_engine, it's doing so to load
2674 # Catalyst::Engine::PSGI. But if it does that, we're only going to
2675 # throw away the loaded PSGI-app and load the 5.9 Catalyst::Engine
2676 # anyway. So set a flag (ick) that tells setup_engine not to populate
2677 # $c->engine or do any other things we might regret.
2678
2679 $app->loading_psgi_file(1);
1085c936 2680 my $psgi_app = Plack::Util::load_psgi($psgi_file);
2e1f92a3 2681 $app->loading_psgi_file(0);
1085c936 2682
2683 return $psgi_app
2684 unless $app->engine_loader->needs_psgi_engine_compat_hack;
2685
1085c936 2686 warn <<"EOW";
2687Found a legacy Catalyst::Engine::PSGI .psgi file at ${psgi_file}.
2688
2689Its content has been ignored. Please consult the Catalyst::Upgrading
2690documentation on how to upgrade from Catalyst::Engine::PSGI.
2691EOW
fcffcb05 2692 }
2693
f05b654b 2694 return $app->apply_default_middlewares($app->psgi_app);
8f076801 2695}
2696
1316cc64 2697=head2 $c->apply_default_middlewares
2698
2699Adds the following L<Plack> middlewares to your application, since they are
2700useful and commonly needed:
2701
2702L<Plack::Middleware::ReverseProxy>, (conditionally added based on the status
2703of your $ENV{REMOTE_ADDR}, and can be forced on with C<using_frontend_proxy>
2704or forced off with C<ignore_frontend_proxy>), L<Plack::Middleware::LighttpdScriptNameFix>
2705(if you are using Lighttpd), L<Plack::Middleware::IIS6ScriptNameFix> (always
2706applied since this middleware is smart enough to conditionally apply itself).
2707
2708Additionally if we detect we are using Nginx, we add a bit of custom middleware
2709to solve some problems with the way that server handles $ENV{PATH_INFO} and
2710$ENV{SCRIPT_NAME}
2711
2712=cut
2713
f05b654b 2714
2715sub apply_default_middlewares {
c72bc6eb 2716 my ($app, $psgi_app) = @_;
8f076801 2717
d89b863e 2718 $psgi_app = Plack::Middleware::Conditional->wrap(
c72bc6eb 2719 $psgi_app,
fcffcb05 2720 builder => sub { Plack::Middleware::ReverseProxy->wrap($_[0]) },
2721 condition => sub {
2722 my ($env) = @_;
2723 return if $app->config->{ignore_frontend_proxy};
2724 return $env->{REMOTE_ADDR} eq '127.0.0.1'
2725 || $app->config->{using_frontend_proxy};
2726 },
2727 );
d89b863e 2728
00fa37d0 2729 my $server_matches = sub {
2730 my ($re) = @_;
2731 return sub {
2732 my ($env) = @_;
2733 my $server = $env->{SERVER_SOFTWARE};
2734 return unless $server;
2735 return $server =~ $re ? 1 : 0;
2736 };
2737 };
2738
d89b863e 2739 # If we're running under Lighttpd, swap PATH_INFO and SCRIPT_NAME
2740 # http://lists.scsys.co.uk/pipermail/catalyst/2006-June/008361.html
d3670826 2741 $psgi_app = Plack::Middleware::LighttpdScriptNameFix->wrap($psgi_app);
d89b863e 2742
fb99321f 2743 # we're applying this unconditionally as the middleware itself already makes
2744 # sure it doesn't fuck things up if it's not running under one of the right
2745 # IIS versions
2746 $psgi_app = Plack::Middleware::IIS6ScriptNameFix->wrap($psgi_app);
a6fb59b7 2747
d89b863e 2748 return $psgi_app;
fcffcb05 2749}
2750
8f076801 2751=head2 $c->psgi_app
fcffcb05 2752
2753Returns a PSGI application code reference for the catalyst application
2754C<$c>. This is the bare application without any middlewares
8f076801 2755applied. C<${myapp}.psgi> is not taken into account.
2756
2757This is what you want to be using to retrieve the PSGI application code
2758reference of your Catalyst application for use in F<.psgi> files.
fcffcb05 2759
2760=cut
2761
8f076801 2762sub psgi_app {
fcffcb05