we agreed on neither enforcing en_US nor en_GB
[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
4ec26b6c 87our $VERSION = '5.90004';
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;
0cff119a 1350 # ->uri_for( $action, \@captures_and_args, \%query_values? )
1351 if( !@args && $action->number_of_args ) {
1352 my $expanded_action = $c->dispatcher->expand_action( $action );
1353
1354 my $num_captures = $expanded_action->number_of_captures;
1355 unshift @args, splice @$captures, $num_captures;
1356 }
1357
1358 $path = $c->dispatcher->uri_for_action($action, $captures);
aa7e913e 1359 if (not defined $path) {
1360 $c->log->debug(qq/Can't find uri_for action '$action' @$captures/)
1361 if $c->debug;
1362 return undef;
1363 }
81e75875 1364 $path = '/' if $path eq '';
ea0e58d9 1365 }
1366
51674a63 1367 unshift(@args, $path);
1368
1369 unless (defined $path && $path =~ s!^/!!) { # in-place strip
1370 my $namespace = $c->namespace;
1371 if (defined $path) { # cheesy hack to handle path '../foo'
1372 $namespace =~ s{(?:^|/)[^/]+$}{} while $args[0] =~ s{^\.\./}{};
6601f2ad 1373 }
51674a63 1374 unshift(@args, $namespace || '');
1375 }
62a6df80 1376
189e2a51 1377 # join args with '/', or a blank string
51674a63 1378 my $args = join('/', grep { defined($_) } @args);
1379 $args =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
7a2295bc 1380 $args =~ s!^/+!!;
51674a63 1381 my $base = $c->req->base;
1382 my $class = ref($base);
1383 $base =~ s{(?<!/)$}{/};
1384
1385 my $query = '';
1386
1387 if (my @keys = keys %$params) {
1388 # somewhat lifted from URI::_query's query_form
1389 $query = '?'.join('&', map {
2f381252 1390 my $val = $params->{$_};
51674a63 1391 s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/go;
1392 s/ /+/g;
1393 my $key = $_;
51674a63 1394 $val = '' unless defined $val;
1395 (map {
1f851263 1396 my $param = "$_";
1397 utf8::encode( $param ) if utf8::is_utf8($param);
51674a63 1398 # using the URI::Escape pattern here so utf8 chars survive
1f851263 1399 $param =~ s/([^A-Za-z0-9\-_.!~*'() ])/$URI::Escape::escapes{$1}/go;
1400 $param =~ s/ /+/g;
1401 "${key}=$param"; } ( ref $val eq 'ARRAY' ? @$val : $val ));
51674a63 1402 } @keys);
1403 }
1404
1405 my $res = bless(\"${base}${args}${query}", $class);
d3e7a648 1406 $res;
fbcc39ad 1407}
1408
833b385e 1409=head2 $c->uri_for_action( $path, \@captures?, @args?, \%query_values? )
1410
1411=head2 $c->uri_for_action( $action, \@captures?, @args?, \%query_values? )
1412
1413=over
1414
1415=item $path
1416
1417A private path to the Catalyst action you want to create a URI for.
1418
1419This is a shortcut for calling C<< $c->dispatcher->get_action_by_path($path)
1420>> and passing the resulting C<$action> and the remaining arguments to C<<
1421$c->uri_for >>.
1422
1423You can also pass in a Catalyst::Action object, in which case it is passed to
1424C<< $c->uri_for >>.
1425
c9ec25f8 1426Note 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.
1427
1428For example, if the action looks like:
1429
1430 package MyApp::Controller::Users;
1431
1432 sub lst : Path('the-list') {}
1433
1434You can use:
1435
1436 $c->uri_for_action('/users/lst')
1437
1438and it will create the URI /users/the-list.
1439
833b385e 1440=back
1441
1442=cut
1443
1444sub uri_for_action {
1445 my ( $c, $path, @args ) = @_;
62a6df80 1446 my $action = blessed($path)
1447 ? $path
833b385e 1448 : $c->dispatcher->get_action_by_path($path);
4ac0b9cb 1449 unless (defined $action) {
1450 croak "Can't find action for path '$path'";
1451 }
833b385e 1452 return $c->uri_for( $action, @args );
1453}
1454
b5ecfcf0 1455=head2 $c->welcome_message
ab2374d3 1456
1457Returns the Catalyst welcome HTML page.
1458
1459=cut
1460
1461sub welcome_message {
bf1f2c60 1462 my $c = shift;
1463 my $name = $c->config->{name};
1464 my $logo = $c->uri_for('/static/images/catalyst_logo.png');
1465 my $prefix = Catalyst::Utils::appprefix( ref $c );
80cdbbff 1466 $c->response->content_type('text/html; charset=utf-8');
ab2374d3 1467 return <<"EOF";
80cdbbff 1468<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1469 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1470<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
ab2374d3 1471 <head>
85d9fce6 1472 <meta http-equiv="Content-Language" content="en" />
1473 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
ab2374d3 1474 <title>$name on Catalyst $VERSION</title>
1475 <style type="text/css">
1476 body {
ab2374d3 1477 color: #000;
1478 background-color: #eee;
1479 }
1480 div#content {
1481 width: 640px;
80cdbbff 1482 margin-left: auto;
1483 margin-right: auto;
ab2374d3 1484 margin-top: 10px;
1485 margin-bottom: 10px;
1486 text-align: left;
1487 background-color: #ccc;
1488 border: 1px solid #aaa;
ab2374d3 1489 }
d84c4dab 1490 p, h1, h2 {
ab2374d3 1491 margin-left: 20px;
1492 margin-right: 20px;
16215972 1493 font-family: verdana, tahoma, sans-serif;
ab2374d3 1494 }
d84c4dab 1495 a {
1496 font-family: verdana, tahoma, sans-serif;
1497 }
d114e033 1498 :link, :visited {
1499 text-decoration: none;
1500 color: #b00;
1501 border-bottom: 1px dotted #bbb;
1502 }
1503 :link:hover, :visited:hover {
d114e033 1504 color: #555;
1505 }
ab2374d3 1506 div#topbar {
1507 margin: 0px;
1508 }
3e82a295 1509 pre {
3e82a295 1510 margin: 10px;
1511 padding: 8px;
1512 }
ab2374d3 1513 div#answers {
1514 padding: 8px;
1515 margin: 10px;
d114e033 1516 background-color: #fff;
ab2374d3 1517 border: 1px solid #aaa;
ab2374d3 1518 }
1519 h1 {
33108eaf 1520 font-size: 0.9em;
1521 font-weight: normal;
ab2374d3 1522 text-align: center;
1523 }
1524 h2 {
1525 font-size: 1.0em;
1526 }
1527 p {
1528 font-size: 0.9em;
1529 }
ae7c5252 1530 p img {
1531 float: right;
1532 margin-left: 10px;
1533 }
9619f23c 1534 span#appname {
1535 font-weight: bold;
33108eaf 1536 font-size: 1.6em;
ab2374d3 1537 }
1538 </style>
1539 </head>
1540 <body>
1541 <div id="content">
1542 <div id="topbar">
9619f23c 1543 <h1><span id="appname">$name</span> on <a href="http://catalyst.perl.org">Catalyst</a>
d84c4dab 1544 $VERSION</h1>
ab2374d3 1545 </div>
1546 <div id="answers">
ae7c5252 1547 <p>
80cdbbff 1548 <img src="$logo" alt="Catalyst Logo" />
ae7c5252 1549 </p>
596aaffe 1550 <p>Welcome to the world of Catalyst.
f92fd545 1551 This <a href="http://en.wikipedia.org/wiki/MVC">MVC</a>
1552 framework will make web development something you had
60dd6e1d 1553 never expected it to be: Fun, rewarding, and quick.</p>
ab2374d3 1554 <h2>What to do now?</h2>
4b8cb778 1555 <p>That really depends on what <b>you</b> want to do.
ab2374d3 1556 We do, however, provide you with a few starting points.</p>
1557 <p>If you want to jump right into web development with Catalyst
2f381252 1558 you might want to start with a tutorial.</p>
b607f8a0 1559<pre>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Tutorial.pod">Catalyst::Manual::Tutorial</a></code>
596aaffe 1560</pre>
1561<p>Afterwards you can go on to check out a more complete look at our features.</p>
1562<pre>
b607f8a0 1563<code>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Intro.pod">Catalyst::Manual::Intro</a>
1564<!-- Something else should go here, but the Catalyst::Manual link seems unhelpful -->
1565</code></pre>
ab2374d3 1566 <h2>What to do next?</h2>
f5681c92 1567 <p>Next it's time to write an actual application. Use the
80cdbbff 1568 helper scripts to generate <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AController%3A%3A&amp;mode=all">controllers</a>,
60dd6e1d 1569 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AModel%3A%3A&amp;mode=all">models</a>, and
1570 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AView%3A%3A&amp;mode=all">views</a>;
bf1f2c60 1571 they can save you a lot of work.</p>
c5f31918 1572 <pre><code>script/${prefix}_create.pl --help</code></pre>
bf1f2c60 1573 <p>Also, be sure to check out the vast and growing
802bf2cb 1574 collection of <a href="http://search.cpan.org/search?query=Catalyst">plugins for Catalyst on CPAN</a>;
bf1f2c60 1575 you are likely to find what you need there.
f5681c92 1576 </p>
1577
82245cc4 1578 <h2>Need help?</h2>
f5681c92 1579 <p>Catalyst has a very active community. Here are the main places to
1580 get in touch with us.</p>
16215972 1581 <ul>
1582 <li>
2b9a7d76 1583 <a href="http://dev.catalyst.perl.org">Wiki</a>
16215972 1584 </li>
1585 <li>
6d4c3368 1586 <a href="http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst">Mailing-List</a>
16215972 1587 </li>
1588 <li>
4eaf7c88 1589 <a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
16215972 1590 </li>
1591 </ul>
ab2374d3 1592 <h2>In conclusion</h2>
62a6df80 1593 <p>The Catalyst team hopes you will enjoy using Catalyst as much
f5681c92 1594 as we enjoyed making it. Please contact us if you have ideas
1595 for improvement or other feedback.</p>
ab2374d3 1596 </div>
1597 </div>
1598 </body>
1599</html>
1600EOF
1601}
1602
fbcc39ad 1603=head1 INTERNAL METHODS
1604
ae1e6b59 1605These methods are not meant to be used by end users.
1606
b5ecfcf0 1607=head2 $c->components
fbcc39ad 1608
e7f1cf73 1609Returns a hash of components.
fbcc39ad 1610
b5ecfcf0 1611=head2 $c->context_class
1f9cb7c1 1612
e7f1cf73 1613Returns or sets the context class.
1f9cb7c1 1614
b5ecfcf0 1615=head2 $c->counter
fbcc39ad 1616
ae1e6b59 1617Returns a hashref containing coderefs and execution counts (needed for
1618deep recursion detection).
fbcc39ad 1619
b5ecfcf0 1620=head2 $c->depth
fbcc39ad 1621
e7f1cf73 1622Returns the number of actions on the current internal execution stack.
fbcc39ad 1623
b5ecfcf0 1624=head2 $c->dispatch
fbcc39ad 1625
e7f1cf73 1626Dispatches a request to actions.
fbcc39ad 1627
1628=cut
1629
1630sub dispatch { my $c = shift; $c->dispatcher->dispatch( $c, @_ ) }
1631
b5ecfcf0 1632=head2 $c->dispatcher_class
1f9cb7c1 1633
e7f1cf73 1634Returns or sets the dispatcher class.
1f9cb7c1 1635
b5ecfcf0 1636=head2 $c->dump_these
7f92deef 1637
ae1e6b59 1638Returns a list of 2-element array references (name, structure) pairs
1639that will be dumped on the error page in debug mode.
7f92deef 1640
1641=cut
1642
1643sub dump_these {
1644 my $c = shift;
62a6df80 1645 [ Request => $c->req ],
1646 [ Response => $c->res ],
052a2d89 1647 [ Stash => $c->stash ],
1648 [ Config => $c->config ];
7f92deef 1649}
1650
b5ecfcf0 1651=head2 $c->engine_class
1f9cb7c1 1652
e7f1cf73 1653Returns or sets the engine class.
1f9cb7c1 1654
b5ecfcf0 1655=head2 $c->execute( $class, $coderef )
fbcc39ad 1656
0ef52a96 1657Execute a coderef in given class and catch exceptions. Errors are available
1658via $c->error.
fbcc39ad 1659
1660=cut
1661
1662sub execute {
1663 my ( $c, $class, $code ) = @_;
858828dd 1664 $class = $c->component($class) || $class;
fbcc39ad 1665 $c->state(0);
a0eca838 1666
197bd788 1667 if ( $c->depth >= $RECURSION ) {
f3414019 1668 my $action = $code->reverse();
91d08727 1669 $action = "/$action" unless $action =~ /->/;
f3414019 1670 my $error = qq/Deep recursion detected calling "${action}"/;
1627551a 1671 $c->log->error($error);
1672 $c->error($error);
1673 $c->state(0);
1674 return $c->state;
1675 }
1676
dc5f035e 1677 my $stats_info = $c->_stats_start_execute( $code ) if $c->use_stats;
22247e54 1678
8767c5a3 1679 push( @{ $c->stack }, $code );
62a6df80 1680
6f3df815 1681 no warnings 'recursion';
524b0e1c 1682 # N.B. This used to be combined, but I have seen $c get clobbered if so, and
1683 # I have no idea how, ergo $ret (which appears to fix the issue)
1684 eval { my $ret = $code->execute( $class, $c, @{ $c->req->args } ) || 0; $c->state( $ret ) };
22247e54 1685
dc5f035e 1686 $c->_stats_finish_execute( $stats_info ) if $c->use_stats and $stats_info;
62a6df80 1687
a6724a82 1688 my $last = pop( @{ $c->stack } );
fbcc39ad 1689
1690 if ( my $error = $@ ) {
79f5d571 1691 if ( blessed($error) and $error->isa('Catalyst::Exception::Detach') ) {
f87b7c21 1692 $error->rethrow if $c->depth > 1;
2f381252 1693 }
79f5d571 1694 elsif ( blessed($error) and $error->isa('Catalyst::Exception::Go') ) {
f87b7c21 1695 $error->rethrow if $c->depth > 0;
55424863 1696 }
fbcc39ad 1697 else {
1698 unless ( ref $error ) {
91d08727 1699 no warnings 'uninitialized';
fbcc39ad 1700 chomp $error;
f59def82 1701 my $class = $last->class;
1702 my $name = $last->name;
1703 $error = qq/Caught exception in $class->$name "$error"/;
fbcc39ad 1704 }
fbcc39ad 1705 $c->error($error);
fbcc39ad 1706 }
2688734f 1707 $c->state(0);
fbcc39ad 1708 }
1709 return $c->state;
1710}
1711
7a7d7af5 1712sub _stats_start_execute {
1713 my ( $c, $code ) = @_;
df960201 1714 my $appclass = ref($c) || $c;
a6724a82 1715 return if ( ( $code->name =~ /^_.*/ )
df960201 1716 && ( !$appclass->config->{show_internal_actions} ) );
7a7d7af5 1717
f3414019 1718 my $action_name = $code->reverse();
1719 $c->counter->{$action_name}++;
7a7d7af5 1720
f3414019 1721 my $action = $action_name;
a6724a82 1722 $action = "/$action" unless $action =~ /->/;
1723
7a7d7af5 1724 # determine if the call was the result of a forward
1725 # this is done by walking up the call stack and looking for a calling
1726 # sub of Catalyst::forward before the eval
1727 my $callsub = q{};
1728 for my $index ( 2 .. 11 ) {
1729 last
1730 if ( ( caller($index) )[0] eq 'Catalyst'
1731 && ( caller($index) )[3] eq '(eval)' );
1732
1733 if ( ( caller($index) )[3] =~ /forward$/ ) {
1734 $callsub = ( caller($index) )[3];
1735 $action = "-> $action";
1736 last;
1737 }
1738 }
1739
f3414019 1740 my $uid = $action_name . $c->counter->{$action_name};
74efc144 1741
a6724a82 1742 # is this a root-level call or a forwarded call?
1743 if ( $callsub =~ /forward$/ ) {
91740f34 1744 my $parent = $c->stack->[-1];
a6724a82 1745
1746 # forward, locate the caller
9c74923d 1747 if ( defined $parent && exists $c->counter->{"$parent"} ) {
69d8f33c 1748 $c->stats->profile(
62a6df80 1749 begin => $action,
69d8f33c 1750 parent => "$parent" . $c->counter->{"$parent"},
1751 uid => $uid,
1752 );
7a7d7af5 1753 }
1754 else {
1755
a6724a82 1756 # forward with no caller may come from a plugin
69d8f33c 1757 $c->stats->profile(
1758 begin => $action,
1759 uid => $uid,
1760 );
7a7d7af5 1761 }
1762 }
a6724a82 1763 else {
62a6df80 1764
a6724a82 1765 # root-level call
69d8f33c 1766 $c->stats->profile(
1767 begin => $action,
1768 uid => $uid,
1769 );
a6724a82 1770 }
dc5f035e 1771 return $action;
7a7d7af5 1772
7a7d7af5 1773}
1774
1775sub _stats_finish_execute {
1776 my ( $c, $info ) = @_;
69d8f33c 1777 $c->stats->profile( end => $info );
7a7d7af5 1778}
1779
b5ecfcf0 1780=head2 $c->finalize
fbcc39ad 1781
e7f1cf73 1782Finalizes the request.
fbcc39ad 1783
1784=cut
1785
1786sub finalize {
1787 my $c = shift;
1788
369c09bc 1789 for my $error ( @{ $c->error } ) {
1790 $c->log->error($error);
1791 }
1792
5050d7a7 1793 # Allow engine to handle finalize flow (for POE)
e63bdf38 1794 my $engine = $c->engine;
1795 if ( my $code = $engine->can('finalize') ) {
1796 $engine->$code($c);
fbcc39ad 1797 }
5050d7a7 1798 else {
fbcc39ad 1799
5050d7a7 1800 $c->finalize_uploads;
fbcc39ad 1801
5050d7a7 1802 # Error
1803 if ( $#{ $c->error } >= 0 ) {
1804 $c->finalize_error;
1805 }
1806
1807 $c->finalize_headers;
fbcc39ad 1808
5050d7a7 1809 # HEAD request
1810 if ( $c->request->method eq 'HEAD' ) {
1811 $c->response->body('');
1812 }
1813
1814 $c->finalize_body;
1815 }
62a6df80 1816
2bf54936 1817 $c->log_response;
10f204e1 1818
62a6df80 1819 if ($c->use_stats) {
596677b6 1820 my $elapsed = sprintf '%f', $c->stats->elapsed;
12bf12c0 1821 my $av = $elapsed == 0 ? '??' : sprintf '%.3f', 1 / $elapsed;
908e3d9e 1822 $c->log->info(
62a6df80 1823 "Request took ${elapsed}s ($av/s)\n" . $c->stats->report . "\n" );
908e3d9e 1824 }
fbcc39ad 1825
1826 return $c->response->status;
1827}
1828
b5ecfcf0 1829=head2 $c->finalize_body
fbcc39ad 1830
e7f1cf73 1831Finalizes body.
fbcc39ad 1832
1833=cut
1834
1835sub finalize_body { my $c = shift; $c->engine->finalize_body( $c, @_ ) }
1836
b5ecfcf0 1837=head2 $c->finalize_cookies
fbcc39ad 1838
e7f1cf73 1839Finalizes cookies.
fbcc39ad 1840
1841=cut
1842
147821ea 1843sub finalize_cookies { my $c = shift; $c->engine->finalize_cookies( $c, @_ ) }
fbcc39ad 1844
b5ecfcf0 1845=head2 $c->finalize_error
fbcc39ad 1846
e7f1cf73 1847Finalizes error.
fbcc39ad 1848
1849=cut
1850
1851sub finalize_error { my $c = shift; $c->engine->finalize_error( $c, @_ ) }
1852
b5ecfcf0 1853=head2 $c->finalize_headers
fbcc39ad 1854
e7f1cf73 1855Finalizes headers.
fbcc39ad 1856
1857=cut
1858
1859sub finalize_headers {
1860 my $c = shift;
1861
e63bdf38 1862 my $response = $c->response; #accessor calls can add up?
1863
fbcc39ad 1864 # Check if we already finalized headers
6680c772 1865 return if $response->finalized_headers;
fbcc39ad 1866
1867 # Handle redirects
e63bdf38 1868 if ( my $location = $response->redirect ) {
fbcc39ad 1869 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
e63bdf38 1870 $response->header( Location => $location );
a7caa492 1871
02570318 1872 if ( !$response->has_body ) {
39655cdc 1873 # Add a default body if none is already present
9c331634 1874 $response->body(<<"EOF");
1875<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
1876<html xmlns="http://www.w3.org/1999/xhtml">
1877 <head>
1878 <title>Moved</title>
1879 </head>
1880 <body>
1881 <p>This item has moved <a href="$location">here</a>.</p>
1882 </body>
1883</html>
1884EOF
d455230c 1885 $response->content_type('text/html; charset=utf-8');
39655cdc 1886 }
fbcc39ad 1887 }
1888
1889 # Content-Length
ac057d3b 1890 if ( defined $response->body && length $response->body && !$response->content_length ) {
775878ac 1891
8f62c91a 1892 # get the length from a filehandle
9c74923d 1893 if ( blessed( $response->body ) && $response->body->can('read') || ref( $response->body ) eq 'GLOB' )
197bd788 1894 {
34effbc7 1895 my $size = -s $response->body;
1896 if ( $size ) {
1897 $response->content_length( $size );
8f62c91a 1898 }
1899 else {
775878ac 1900 $c->log->warn('Serving filehandle without a content-length');
8f62c91a 1901 }
1902 }
1903 else {
b5d7a61f 1904 # everything should be bytes at this point, but just in case
5ab21903 1905 $response->content_length( length( $response->body ) );
8f62c91a 1906 }
fbcc39ad 1907 }
1908
1909 # Errors
e63bdf38 1910 if ( $response->status =~ /^(1\d\d|[23]04)$/ ) {
1911 $response->headers->remove_header("Content-Length");
1912 $response->body('');
fbcc39ad 1913 }
1914
1915 $c->finalize_cookies;
1916
1917 $c->engine->finalize_headers( $c, @_ );
1918
1919 # Done
6680c772 1920 $response->finalized_headers(1);
fbcc39ad 1921}
1922
b5ecfcf0 1923=head2 $c->finalize_output
fbcc39ad 1924
1925An alias for finalize_body.
1926
b5ecfcf0 1927=head2 $c->finalize_read
fbcc39ad 1928
e7f1cf73 1929Finalizes the input after reading is complete.
fbcc39ad 1930
1931=cut
1932
1933sub finalize_read { my $c = shift; $c->engine->finalize_read( $c, @_ ) }
1934
b5ecfcf0 1935=head2 $c->finalize_uploads
fbcc39ad 1936
ae1e6b59 1937Finalizes uploads. Cleans up any temporary files.
fbcc39ad 1938
1939=cut
1940
1941sub finalize_uploads { my $c = shift; $c->engine->finalize_uploads( $c, @_ ) }
1942
b5ecfcf0 1943=head2 $c->get_action( $action, $namespace )
fbcc39ad 1944
e7f1cf73 1945Gets an action in a given namespace.
fbcc39ad 1946
1947=cut
1948
684d10ed 1949sub get_action { my $c = shift; $c->dispatcher->get_action(@_) }
fbcc39ad 1950
b5ecfcf0 1951=head2 $c->get_actions( $action, $namespace )
a9dc674c 1952
ae1e6b59 1953Gets all actions of a given name in a namespace and all parent
1954namespaces.
a9dc674c 1955
1956=cut
1957
1958sub get_actions { my $c = shift; $c->dispatcher->get_actions( $c, @_ ) }
1959
e5ce5f04 1960=head2 $app->handle_request( @arguments )
fbcc39ad 1961
e7f1cf73 1962Called to handle each HTTP request.
fbcc39ad 1963
1964=cut
1965
1966sub handle_request {
1967 my ( $class, @arguments ) = @_;
1968
1969 # Always expect worst case!
1970 my $status = -1;
3640641e 1971 try {
dea1884f 1972 if ($class->debug) {
908e3d9e 1973 my $secs = time - $START || 1;
1974 my $av = sprintf '%.3f', $COUNT / $secs;
1975 my $time = localtime time;
1976 $class->log->info("*** Request $COUNT ($av/s) [$$] [$time] ***");
dea1884f 1977 }
908e3d9e 1978
1979 my $c = $class->prepare(@arguments);
1980 $c->dispatch;
62a6df80 1981 $status = $c->finalize;
fbcc39ad 1982 }
3640641e 1983 catch {
1984 chomp(my $error = $_);
1985 $class->log->error(qq/Caught exception in engine "$error"/);
1986 };
fbcc39ad 1987
1988 $COUNT++;
62a6df80 1989
6680c772 1990 if(my $coderef = $class->log->can('_flush')){
1991 $class->log->$coderef();
1992 }
fbcc39ad 1993 return $status;
1994}
1995
d536010b 1996=head2 $class->prepare( @arguments )
fbcc39ad 1997
ae1e6b59 1998Creates a Catalyst context from an engine-specific request (Apache, CGI,
1999etc.).
fbcc39ad 2000
2001=cut
2002
2003sub prepare {
2004 my ( $class, @arguments ) = @_;
2005
6680c772 2006 # XXX
2007 # After the app/ctxt split, this should become an attribute based on something passed
2008 # into the application.
3cec521a 2009 $class->context_class( ref $class || $class ) unless $class->context_class;
62a6df80 2010
6680c772 2011 my $c = $class->context_class->new({});
2012
2013 # For on-demand data
2014 $c->request->_context($c);
2015 $c->response->_context($c);
fbcc39ad 2016
b6d4ee6e 2017 #surely this is not the most efficient way to do things...
dc5f035e 2018 $c->stats($class->stats_class->new)->enable($c->use_stats);
4f0b7cf1 2019 if ( $c->debug || $c->config->{enable_catalyst_header} ) {
62a6df80 2020 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
908e3d9e 2021 }
2022
3640641e 2023 try {
2024 # Allow engine to direct the prepare flow (for POE)
2025 if ( my $prepare = $c->engine->can('prepare') ) {
2026 $c->engine->$prepare( $c, @arguments );
2027 }
2028 else {
2029 $c->prepare_request(@arguments);
2030 $c->prepare_connection;
2031 $c->prepare_query_parameters;
2032 $c->prepare_headers;
2033 $c->prepare_cookies;
2034 $c->prepare_path;
2035
2036 # Prepare the body for reading, either by prepare_body
2037 # or the user, if they are using $c->read
2038 $c->prepare_read;
2039
2040 # Parse the body unless the user wants it on-demand
2041 unless ( ref($c)->config->{parse_on_demand} ) {
2042 $c->prepare_body;
2043 }
878b821c 2044 }
5050d7a7 2045 }
3640641e 2046 # VERY ugly and probably shouldn't rely on ->finalize actually working
2047 catch {
2048 # failed prepare is always due to an invalid request, right?
2049 $c->response->status(400);
2050 $c->response->content_type('text/plain');
2051 $c->response->body('Bad Request');
2052 $c->finalize;
2053 die $_;
2054 };
fbcc39ad 2055
fbcc39ad 2056 my $method = $c->req->method || '';
2f381252 2057 my $path = $c->req->path;
2058 $path = '/' unless length $path;
fbcc39ad 2059 my $address = $c->req->address || '';
2060
10f204e1 2061 $c->log_request;
fbcc39ad 2062
e3a13771 2063 $c->prepare_action;
2064
fbcc39ad 2065 return $c;
2066}
2067
b5ecfcf0 2068=head2 $c->prepare_action
fbcc39ad 2069
b4b01a8a 2070Prepares action. See L<Catalyst::Dispatcher>.
fbcc39ad 2071
2072=cut
2073
2074sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
2075
b5ecfcf0 2076=head2 $c->prepare_body
fbcc39ad 2077
e7f1cf73 2078Prepares message body.
fbcc39ad 2079
2080=cut
2081
2082sub prepare_body {
2083 my $c = shift;
2084
0f56bbcf 2085 return if $c->request->_has_body;
fbcc39ad 2086
2087 # Initialize on-demand data
2088 $c->engine->prepare_body( $c, @_ );
2089 $c->prepare_parameters;
2090 $c->prepare_uploads;
fbcc39ad 2091}
2092
b5ecfcf0 2093=head2 $c->prepare_body_chunk( $chunk )
4bd82c41 2094
e7f1cf73 2095Prepares a chunk of data before sending it to L<HTTP::Body>.
4bd82c41 2096
b4b01a8a 2097See L<Catalyst::Engine>.
2098
4bd82c41 2099=cut
2100
4f5ebacd 2101sub prepare_body_chunk {
2102 my $c = shift;
4bd82c41 2103 $c->engine->prepare_body_chunk( $c, @_ );
2104}
2105
b5ecfcf0 2106=head2 $c->prepare_body_parameters
fbcc39ad 2107
e7f1cf73 2108Prepares body parameters.
fbcc39ad 2109
2110=cut
2111
2112sub prepare_body_parameters {
2113 my $c = shift;
2114 $c->engine->prepare_body_parameters( $c, @_ );
2115}
2116
b5ecfcf0 2117=head2 $c->prepare_connection
fbcc39ad 2118
e7f1cf73 2119Prepares connection.
fbcc39ad 2120
2121=cut
2122
2123sub prepare_connection {
2124 my $c = shift;
2125 $c->engine->prepare_connection( $c, @_ );
2126}
2127
b5ecfcf0 2128=head2 $c->prepare_cookies
fbcc39ad 2129
e7f1cf73 2130Prepares cookies.
fbcc39ad 2131
2132=cut
2133
2134sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
2135
b5ecfcf0 2136=head2 $c->prepare_headers
fbcc39ad 2137
e7f1cf73 2138Prepares headers.
fbcc39ad 2139
2140=cut
2141
2142sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
2143
b5ecfcf0 2144=head2 $c->prepare_parameters
fbcc39ad 2145
e7f1cf73 2146Prepares parameters.
fbcc39ad 2147
2148=cut
2149
2150sub prepare_parameters {
2151 my $c = shift;
2152 $c->prepare_body_parameters;
2153 $c->engine->prepare_parameters( $c, @_ );
2154}
2155
b5ecfcf0 2156=head2 $c->prepare_path
fbcc39ad 2157
e7f1cf73 2158Prepares path and base.
fbcc39ad 2159
2160=cut
2161
2162sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
2163
b5ecfcf0 2164=head2 $c->prepare_query_parameters
fbcc39ad 2165
e7f1cf73 2166Prepares query parameters.
fbcc39ad 2167
2168=cut
2169
2170sub prepare_query_parameters {
2171 my $c = shift;
2172
2173 $c->engine->prepare_query_parameters( $c, @_ );
10f204e1 2174}
fbcc39ad 2175
10f204e1 2176=head2 $c->log_request
2177
2178Writes information about the request to the debug logs. This includes:
2179
2180=over 4
2181
854e5dcd 2182=item * Request method, path, and remote IP address
10f204e1 2183
2184=item * Query keywords (see L<Catalyst::Request/query_keywords>)
2185
e7cbe1bf 2186=item * Request parameters
10f204e1 2187
2188=item * File uploads
2189
2190=back
fbcc39ad 2191
2192=cut
2193
10f204e1 2194sub log_request {
2195 my $c = shift;
fbcc39ad 2196
10f204e1 2197 return unless $c->debug;
fbcc39ad 2198
2bf54936 2199 my($dump) = grep {$_->[0] eq 'Request' } $c->dump_these;
2200 my $request = $dump->[1];
e7cbe1bf 2201
2202 my ( $method, $path, $address ) = ( $request->method, $request->path, $request->address );
10f204e1 2203 $method ||= '';
2204 $path = '/' unless length $path;
2205 $address ||= '';
2206 $c->log->debug(qq/"$method" request for "$path" from "$address"/);
2207
3a4abdb3 2208 $c->log_request_headers($request->headers);
e7cbe1bf 2209
2210 if ( my $keywords = $request->query_keywords ) {
10f204e1 2211 $c->log->debug("Query keywords are: $keywords");
fbcc39ad 2212 }
10f204e1 2213
9c74923d 2214 $c->log_request_parameters( query => $request->query_parameters, $request->_has_body ? (body => $request->body_parameters) : () );
10f204e1 2215
e7cbe1bf 2216 $c->log_request_uploads($request);
fbcc39ad 2217}
2218
10f204e1 2219=head2 $c->log_response
fbcc39ad 2220
75b65816 2221Writes information about the response to the debug logs by calling
2222C<< $c->log_response_status_line >> and C<< $c->log_response_headers >>.
fbcc39ad 2223
2224=cut
2225
75b65816 2226sub log_response {
2227 my $c = shift;
fbcc39ad 2228
75b65816 2229 return unless $c->debug;
fbcc39ad 2230
75b65816 2231 my($dump) = grep {$_->[0] eq 'Response' } $c->dump_these;
2232 my $response = $dump->[1];
2233
2234 $c->log_response_status_line($response);
2235 $c->log_response_headers($response->headers);
2236}
2237
2238=head2 $c->log_response_status_line($response)
2239
2240Writes one line of information about the response to the debug logs. This includes:
10f204e1 2241
2242=over 4
2243
2244=item * Response status code
2245
3a4abdb3 2246=item * Content-Type header (if present)
2247
2248=item * Content-Length header (if present)
10f204e1 2249
2250=back
fbcc39ad 2251
2252=cut
2253
75b65816 2254sub log_response_status_line {
2255 my ($c, $response) = @_;
fbcc39ad 2256
697bab77 2257 $c->log->debug(
2258 sprintf(
2259 'Response Code: %s; Content-Type: %s; Content-Length: %s',
2260 $response->status || 'unknown',
2261 $response->headers->header('Content-Type') || 'unknown',
2262 $response->headers->header('Content-Length') || 'unknown'
2263 )
2264 );
10f204e1 2265}
fbcc39ad 2266
75b65816 2267=head2 $c->log_response_headers($headers);
2268
2269Hook method which can be wrapped by plugins to log the responseheaders.
2270No-op in the default implementation.
fbcc39ad 2271
2272=cut
2273
75b65816 2274sub log_response_headers {}
fbcc39ad 2275
10f204e1 2276=head2 $c->log_request_parameters( query => {}, body => {} )
2277
2278Logs request parameters to debug logs
2279
10f204e1 2280=cut
2281
2282sub log_request_parameters {
2283 my $c = shift;
2284 my %all_params = @_;
2285
2bf54936 2286 return unless $c->debug;
e7cbe1bf 2287
10f204e1 2288 my $column_width = Catalyst::Utils::term_width() - 44;
2289 foreach my $type (qw(query body)) {
2bf54936 2290 my $params = $all_params{$type};
2291 next if ! keys %$params;
10f204e1 2292 my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ $column_width, 'Value' ] );
e7cbe1bf 2293 for my $key ( sort keys %$params ) {
2294 my $param = $params->{$key};
10f204e1 2295 my $value = defined($param) ? $param : '';
2296 $t->row( $key, ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
2297 }
2298 $c->log->debug( ucfirst($type) . " Parameters are:\n" . $t->draw );
2299 }
2300}
2301
2302=head2 $c->log_request_uploads
2303
2304Logs file uploads included in the request to the debug logs.
854e5dcd 2305The parameter name, filename, file type, and file size are all included in
10f204e1 2306the debug logs.
2307
2308=cut
fbcc39ad 2309
10f204e1 2310sub log_request_uploads {
2311 my $c = shift;
2bf54936 2312 my $request = shift;
e7cbe1bf 2313 return unless $c->debug;
2314 my $uploads = $request->uploads;
10f204e1 2315 if ( keys %$uploads ) {
8c113188 2316 my $t = Text::SimpleTable->new(
34d28dfd 2317 [ 12, 'Parameter' ],
2318 [ 26, 'Filename' ],
8c113188 2319 [ 18, 'Type' ],
2320 [ 9, 'Size' ]
2321 );
10f204e1 2322 for my $key ( sort keys %$uploads ) {
2323 my $upload = $uploads->{$key};
fbcc39ad 2324 for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
8c113188 2325 $t->row( $key, $u->filename, $u->type, $u->size );
fbcc39ad 2326 }
2327 }
2328 $c->log->debug( "File Uploads are:\n" . $t->draw );
2329 }
2330}
2331
3a4abdb3 2332=head2 $c->log_request_headers($headers);
2333
2334Hook method which can be wrapped by plugins to log the request headers.
2335No-op in the default implementation.
2336
2337=cut
2338
2339sub log_request_headers {}
2340
10f204e1 2341=head2 $c->log_headers($type => $headers)
2342
e7cbe1bf 2343Logs L<HTTP::Headers> (either request or response) to the debug logs.
10f204e1 2344
2345=cut
2346
2347sub log_headers {
2348 my $c = shift;
2349 my $type = shift;
2350 my $headers = shift; # an HTTP::Headers instance
2351
e7cbe1bf 2352 return unless $c->debug;
10f204e1 2353
f0e9921a 2354 my $column_width = Catalyst::Utils::term_width() - 28;
2355 my $t = Text::SimpleTable->new( [ 15, 'Header Name' ], [ $column_width, 'Value' ] );
e7cbe1bf 2356 $headers->scan(
10f204e1 2357 sub {
2358 my ( $name, $value ) = @_;
2359 $t->row( $name, $value );
2360 }
2361 );
2362 $c->log->debug( ucfirst($type) . " Headers:\n" . $t->draw );
2363}
2364
10f204e1 2365
2366=head2 $c->prepare_read
2367
2368Prepares the input for reading.
2369
2370=cut
2371
2372sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
2373
2374=head2 $c->prepare_request
2375
2376Prepares the engine request.
2377
2378=cut
2379
2380sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
2381
2382=head2 $c->prepare_uploads
2383
2384Prepares uploads.
2385
2386=cut
2387
2388sub prepare_uploads {
2389 my $c = shift;
2390
2391 $c->engine->prepare_uploads( $c, @_ );
2392}
2393
b5ecfcf0 2394=head2 $c->prepare_write
fbcc39ad 2395
e7f1cf73 2396Prepares the output for writing.
fbcc39ad 2397
2398=cut
2399
2400sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
2401
b5ecfcf0 2402=head2 $c->request_class
1f9cb7c1 2403
3f87d500 2404Returns or sets the request class. Defaults to L<Catalyst::Request>.
1f9cb7c1 2405
b5ecfcf0 2406=head2 $c->response_class
1f9cb7c1 2407
3f87d500 2408Returns or sets the response class. Defaults to L<Catalyst::Response>.
1f9cb7c1 2409
b5ecfcf0 2410=head2 $c->read( [$maxlength] )
fbcc39ad 2411
ae1e6b59 2412Reads a chunk of data from the request body. This method is designed to
2413be used in a while loop, reading C<$maxlength> bytes on every call.
2414C<$maxlength> defaults to the size of the request if not specified.
fbcc39ad 2415
4600a5a1 2416You have to set C<< MyApp->config(parse_on_demand => 1) >> to use this
ae1e6b59 2417directly.
fbcc39ad 2418
878b821c 2419Warning: If you use read(), Catalyst will not process the body,
2420so you will not be able to access POST parameters or file uploads via
2421$c->request. You must handle all body parsing yourself.
2422
fbcc39ad 2423=cut
2424
2425sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
2426
b5ecfcf0 2427=head2 $c->run
fbcc39ad 2428
2429Starts the engine.
2430
2431=cut
2432
0c6352ff 2433sub run {
2434 my $app = shift;
2435 $app->engine_loader->needs_psgi_engine_compat_hack ?
2436 $app->engine->run($app, @_) :
2437 $app->engine->run( $app, $app->_finalized_psgi_app, @_ );
2438}
fbcc39ad 2439
b5ecfcf0 2440=head2 $c->set_action( $action, $code, $namespace, $attrs )
fbcc39ad 2441
e7f1cf73 2442Sets an action in a given namespace.
fbcc39ad 2443
2444=cut
2445
2446sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
2447
b5ecfcf0 2448=head2 $c->setup_actions($component)
fbcc39ad 2449
e7f1cf73 2450Sets up actions for a component.
fbcc39ad 2451
2452=cut
2453
2454sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
2455
b5ecfcf0 2456=head2 $c->setup_components
fbcc39ad 2457
d261d153 2458This method is called internally to set up the application's components.
fbcc39ad 2459
d261d153 2460It finds modules by calling the L<locate_components> method, expands them to
2461package names with the L<expand_component_module> method, and then installs
2462each component into the application.
2463
2464The C<setup_components> config option is passed to both of the above methods.
fbcc39ad 2465
d261d153 2466Installation of each component is performed by the L<setup_component> method,
2467below.
2f381252 2468
fbcc39ad 2469=cut
2470
2471sub setup_components {
2472 my $class = shift;
2473
18de900e 2474 my $config = $class->config->{ setup_components };
62a6df80 2475
69c6b6cb 2476 my @comps = $class->locate_components($config);
b94b200c 2477 my %comps = map { $_ => 1 } @comps;
73e1183e 2478
8f6cebb2 2479 my $deprecatedcatalyst_component_names = grep { /::[CMV]::/ } @comps;
73e1183e 2480 $class->log->warn(qq{Your application is using the deprecated ::[MVC]:: type naming scheme.\n}.
2481 qq{Please switch your class names to ::Model::, ::View:: and ::Controller: as appropriate.\n}
8f6cebb2 2482 ) if $deprecatedcatalyst_component_names;
73e1183e 2483
b94b200c 2484 for my $component ( @comps ) {
dd91afb5 2485
2486 # We pass ignore_loaded here so that overlay files for (e.g.)
2487 # Model::DBI::Schema sub-classes are loaded - if it's in @comps
2488 # we know M::P::O found a file on disk so this is safe
2489
f5a4863c 2490 Catalyst::Utils::ensure_class_loaded( $component, { ignore_loaded => 1 } );
196f06d1 2491 }
2492
e7e4c469 2493 for my $component (@comps) {
5d02e790 2494 my $instance = $class->components->{ $component } = $class->setup_component($component);
2495 my @expanded_components = $instance->can('expand_modules')
2496 ? $instance->expand_modules( $component, $config )
2497 : $class->expand_component_module( $component, $config );
2498 for my $component (@expanded_components) {
05887b58 2499 next if $comps{$component};
e7e4c469 2500 $class->components->{ $component } = $class->setup_component($component);
fbcc39ad 2501 }
364d7324 2502 }
2503}
fbcc39ad 2504
d261d153 2505=head2 $c->locate_components( $setup_component_config )
2506
2507This method is meant to provide a list of component modules that should be
2508setup for the application. By default, it will use L<Module::Pluggable>.
2509
2510Specify a C<setup_components> config option to pass additional options directly
2511to L<Module::Pluggable>. To add additional search paths, specify a key named
2512C<search_extra> as an array reference. Items in the array beginning with C<::>
2513will have the application class name prepended to them.
2514
2515=cut
2516
2517sub locate_components {
2518 my $class = shift;
2519 my $config = shift;
2520
2521 my @paths = qw( ::Controller ::C ::Model ::M ::View ::V );
2522 my $extra = delete $config->{ search_extra } || [];
2523
2524 push @paths, @$extra;
2525
2526 my $locator = Module::Pluggable::Object->new(
2527 search_path => [ map { s/^(?=::)/$class/; $_; } @paths ],
2528 %$config
2529 );
2530
69c6b6cb 2531 # XXX think about ditching this sort entirely
2532 my @comps = sort { length $a <=> length $b } $locator->plugins;
d261d153 2533
2534 return @comps;
2535}
2536
2537=head2 $c->expand_component_module( $component, $setup_component_config )
2538
2539Components found by C<locate_components> will be passed to this method, which
2540is expected to return a list of component (package) names to be set up.
2541
d261d153 2542=cut
2543
2544sub expand_component_module {
2545 my ($class, $module) = @_;
05887b58 2546 return Devel::InnerPackage::list_packages( $module );
d261d153 2547}
2548
364d7324 2549=head2 $c->setup_component
fbcc39ad 2550
364d7324 2551=cut
fbcc39ad 2552
364d7324 2553sub setup_component {
2554 my( $class, $component ) = @_;
fbcc39ad 2555
364d7324 2556 unless ( $component->can( 'COMPONENT' ) ) {
2557 return $component;
2558 }
fbcc39ad 2559
364d7324 2560 my $suffix = Catalyst::Utils::class2classsuffix( $component );
2561 my $config = $class->config->{ $suffix } || {};
8f6cebb2 2562 # Stash catalyst_component_name in the config here, so that custom COMPONENT
d2598ac8 2563 # methods also pass it. local to avoid pointlessly shitting in config
2564 # for the debug screen, as $component is already the key name.
8f6cebb2 2565 local $config->{catalyst_component_name} = $component;
fbcc39ad 2566
364d7324 2567 my $instance = eval { $component->COMPONENT( $class, $config ); };
fbcc39ad 2568
2569 if ( my $error = $@ ) {
fbcc39ad 2570 chomp $error;
fbcc39ad 2571 Catalyst::Exception->throw(
364d7324 2572 message => qq/Couldn't instantiate component "$component", "$error"/
2573 );
fbcc39ad 2574 }
2575
7490de2a 2576 unless (blessed $instance) {
2577 my $metaclass = Moose::Util::find_meta($component);
2578 my $method_meta = $metaclass->find_method_by_name('COMPONENT');
2579 my $component_method_from = $method_meta->associated_metaclass->name;
637fa644 2580 my $value = defined($instance) ? $instance : 'undef';
7490de2a 2581 Catalyst::Exception->throw(
2582 message =>
637fa644 2583 qq/Couldn't instantiate component "$component", COMPONENT() method (from $component_method_from) didn't return an object-like value (value was $value)./
7490de2a 2584 );
2585 }
364d7324 2586 return $instance;
fbcc39ad 2587}
2588
b5ecfcf0 2589=head2 $c->setup_dispatcher
fbcc39ad 2590
ae1e6b59 2591Sets up dispatcher.
2592
fbcc39ad 2593=cut
2594
2595sub setup_dispatcher {
2596 my ( $class, $dispatcher ) = @_;
2597
2598 if ($dispatcher) {
2599 $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
2600 }
2601
cb69249e 2602 if ( my $env = Catalyst::Utils::env_value( $class, 'DISPATCHER' ) ) {
2603 $dispatcher = 'Catalyst::Dispatcher::' . $env;
fbcc39ad 2604 }
2605
2606 unless ($dispatcher) {
cb0354c6 2607 $dispatcher = $class->dispatcher_class;
fbcc39ad 2608 }
2609
e63bdf38 2610 Class::MOP::load_class($dispatcher);
fbcc39ad 2611
2612 # dispatcher instance
2613 $class->dispatcher( $dispatcher->new );
2614}
2615
b5ecfcf0 2616=head2 $c->setup_engine
fbcc39ad 2617
ae1e6b59 2618Sets up engine.
2619
fbcc39ad 2620=cut
2621
1e5dad00 2622sub engine_class {
a8153308 2623 my ($class, $requested_engine) = @_;
2624
2625 if (!$class->engine_loader || $requested_engine) {
2626 $class->engine_loader(
2627 Catalyst::EngineLoader->new({
2628 application_name => $class,
2629 (defined $requested_engine
65420d46 2630 ? (catalyst_engine_class => $requested_engine) : ()),
a8153308 2631 }),
2632 );
2633 }
65420d46 2634
8ee06de7 2635 $class->engine_loader->catalyst_engine_class;
1e5dad00 2636}
2637
fbcc39ad 2638sub setup_engine {
a26a6adb 2639 my ($class, $requested_engine) = @_;
1085c936 2640
65420d46 2641 my $engine = do {
2642 my $loader = $class->engine_loader;
2643
2644 if (!$loader || $requested_engine) {
2645 $loader = Catalyst::EngineLoader->new({
2646 application_name => $class,
2647 (defined $requested_engine
2648 ? (requested_engine => $requested_engine) : ()),
2649 }),
2650
2651 $class->engine_loader($loader);
2652 }
2653
2654 $loader->catalyst_engine_class;
2655 };
1e5dad00 2656
2e1f92a3 2657 # Don't really setup_engine -- see _setup_psgi_app for explanation.
2658 return if $class->loading_psgi_file;
2659
e63bdf38 2660 Class::MOP::load_class($engine);
0e7f5826 2661
532f0516 2662 if ($ENV{MOD_PERL}) {
1e5dad00 2663 my $apache = $class->engine_loader->auto;
ab4df9f8 2664
2665 my $meta = find_meta($class);
2666 my $was_immutable = $meta->is_immutable;
2667 my %immutable_options = $meta->immutable_options;
2668 $meta->make_mutable if $was_immutable;
2669
2670 $meta->add_method(handler => sub {
9fe15721 2671 my $r = shift;
1e5dad00 2672 my $psgi_app = $class->psgi_app;
2673 $apache->call_app($r, $psgi_app);
9fe15721 2674 });
ab4df9f8 2675
2676 $meta->make_immutable(%immutable_options) if $was_immutable;
532f0516 2677 }
2678
fbcc39ad 2679 $class->engine( $engine->new );
9fe15721 2680
fcffcb05 2681 return;
2682}
2683
8f076801 2684sub _finalized_psgi_app {
c8f4781e 2685 my ($app) = @_;
a0eec1fb 2686
2687 unless ($app->_psgi_app) {
8f076801 2688 my $psgi_app = $app->_setup_psgi_app;
a0eec1fb 2689 $app->_psgi_app($psgi_app);
2690 }
2691
2692 return $app->_psgi_app;
c8f4781e 2693}
2694
8f076801 2695sub _setup_psgi_app {
fcffcb05 2696 my ($app) = @_;
2697
1085c936 2698 for my $home (Path::Class::Dir->new($app->config->{home})) {
fcffcb05 2699 my $psgi_file = $home->file(
2700 Catalyst::Utils::appprefix($app) . '.psgi',
2701 );
2702
1085c936 2703 next unless -e $psgi_file;
2e1f92a3 2704
2705 # If $psgi_file calls ->setup_engine, it's doing so to load
2706 # Catalyst::Engine::PSGI. But if it does that, we're only going to
2707 # throw away the loaded PSGI-app and load the 5.9 Catalyst::Engine
2708 # anyway. So set a flag (ick) that tells setup_engine not to populate
2709 # $c->engine or do any other things we might regret.
2710
2711 $app->loading_psgi_file(1);
1085c936 2712 my $psgi_app = Plack::Util::load_psgi($psgi_file);
2e1f92a3 2713 $app->loading_psgi_file(0);
1085c936 2714
2715 return $psgi_app
2716 unless $app->engine_loader->needs_psgi_engine_compat_hack;
2717
1085c936 2718 warn <<"EOW";
2719Found a legacy Catalyst::Engine::PSGI .psgi file at ${psgi_file}.
2720
2721Its content has been ignored. Please consult the Catalyst::Upgrading
2722documentation on how to upgrade from Catalyst::Engine::PSGI.
2723EOW
fcffcb05 2724 }
2725
f05b654b 2726 return $app->apply_default_middlewares($app->psgi_app);
8f076801 2727}
2728
1316cc64 2729=head2 $c->apply_default_middlewares
2730
2731Adds the following L<Plack> middlewares to your application, since they are
2732useful and commonly needed:
2733
2734L<Plack::Middleware::ReverseProxy>, (conditionally added based on the status
2735of your $ENV{REMOTE_ADDR}, and can be forced on with C<using_frontend_proxy>
2736or forced off with C<ignore_frontend_proxy>), L<Plack::Middleware::LighttpdScriptNameFix>
2737(if you are using Lighttpd), L<Plack::Middleware::IIS6ScriptNameFix> (always
2738applied since this middleware is smart enough to conditionally apply itself).
2739
2740Additionally if we detect we are using Nginx, we add a bit of custom middleware
2741to solve some problems with the way that server handles $ENV{PATH_INFO} and
2742$ENV{SCRIPT_NAME}
2743
2744=cut
2745
f05b654b 2746
2747sub apply_default_middlewares {
c72bc6eb 2748 my ($app, $psgi_app) = @_;
8f076801 2749
d89b863e 2750 $psgi_app = Plack::Middleware::Conditional->wrap(
c72bc6eb 2751 $psgi_app,
fcffcb05 2752 builder => sub { Plack::Middleware::ReverseProxy->wrap($_[0]) },
2753 condition => sub {
2754 my ($env) = @_;
2755 return if $app->config->{ignore_frontend_proxy};
2756 return $env->{REMOTE_ADDR} eq '127.0.0.1'
2757 || $app->config->{using_frontend_proxy};
2758 },
2759 );
d89b863e 2760
2761 # If we're running under Lighttpd, swap PATH_INFO and SCRIPT_NAME
2762 # http://lists.scsys.co.uk/pipermail/catalyst/2006-June/008361.html
d3670826 2763 $psgi_app = Plack::Middleware::LighttpdScriptNameFix->wrap($psgi_app);
d89b863e 2764
fb99321f 2765 # we're applying this unconditionally as the middleware itself already makes
2766 # sure it doesn't fuck things up if it's not running under one of the right