De-uglify a comment
[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 ();
8f62c91a 19use File::stat;
c50f595c 20use Module::Pluggable::Object ();
c50f595c 21use Text::SimpleTable ();
22use Path::Class::Dir ();
23use Path::Class::File ();
c50f595c 24use URI ();
933ba403 25use URI::http;
26use URI::https;
5513038d 27use Tree::Simple qw/use_weak_refs/;
28use Tree::Simple::Visitor::FindByUID;
269408a4 29use Class::C3::Adopt::NEXT;
196f06d1 30use List::MoreUtils qw/uniq/;
261c571e 31use attributes;
532f0516 32use String::RewritePrefix;
b1ededd4 33use Catalyst::EngineLoader;
5789a3d8 34use utf8;
108201b5 35use Carp qw/croak carp shortmess/;
3640641e 36use Try::Tiny;
ad79be34 37use Plack::Middleware::Conditional;
38use Plack::Middleware::ReverseProxy;
fb99321f 39use Plack::Middleware::IIS6ScriptNameFix;
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
a0eec1fb 78 setup_finished _psgi_app/;
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
1f440f55 87our $VERSION = '5.89002';
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
869 # This is here so $c->comp( '::M::' ) works
870 my $query = ref $name ? $name : qr{$name}i;
b4b01a8a 871
2f381252 872 my @result = grep { m{$query} } keys %{ $c->components };
873 return map { $c->_filter_component( $_, @args ) } @result if ref $name;
b4b01a8a 874
2f381252 875 if( $result[ 0 ] ) {
108201b5 876 $c->log->warn( Carp::shortmess(qq(Found results for "${name}" using regexp fallback)) );
2f381252 877 $c->log->warn( 'Relying on the regexp fallback behavior for component resolution' );
878 $c->log->warn( 'is unreliable and unsafe. You have been warned' );
879 return $c->_filter_component( $result[ 0 ], @args );
880 }
881
882 # I would expect to return an empty list here, but that breaks back-compat
b4b01a8a 883 }
884
2f381252 885 # fallback
b4b01a8a 886 return sort keys %{ $c->components };
887}
888
b4b01a8a 889=head2 CLASS DATA AND HELPER CLASSES
fbcc39ad 890
b5ecfcf0 891=head2 $c->config
fbcc39ad 892
0ef52a96 893Returns or takes a hashref containing the application's configuration.
894
61b1d329 895 __PACKAGE__->config( { db => 'dsn:SQLite:foo.db' } );
81557adf 896
18a9655c 897You can also use a C<YAML>, C<XML> or L<Config::General> config file
898like C<myapp.conf> in your applications home directory. See
cc95842f 899L<Catalyst::Plugin::ConfigLoader>.
a6ad13b6 900
6df30f7e 901=head3 Cascading configuration
a6ad13b6 902
b3542016 903The config method is present on all Catalyst components, and configuration
904will be merged when an application is started. Configuration loaded with
905L<Catalyst::Plugin::ConfigLoader> takes precedence over other configuration,
62a6df80 906followed by configuration in your top level C<MyApp> class. These two
a51d14ff 907configurations are merged, and then configuration data whose hash key matches a
b3542016 908component name is merged with configuration for that component.
909
910The configuration for a component is then passed to the C<new> method when a
911component is constructed.
912
913For example:
914
915 MyApp->config({ 'Model::Foo' => { bar => 'baz', overrides => 'me' } });
790ff9aa 916 MyApp::Model::Foo->config({ quux => 'frob', overrides => 'this' });
62a6df80 917
918will mean that C<MyApp::Model::Foo> receives the following data when
b3542016 919constructed:
920
921 MyApp::Model::Foo->new({
922 bar => 'baz',
923 quux => 'frob',
924 overrides => 'me',
925 });
b4b01a8a 926
f8a54681 927It's common practice to use a Moose attribute
928on the receiving component to access the config value.
929
930 package MyApp::Model::Foo;
931
932 use Moose;
933
934 # this attr will receive 'baz' at construction time
9c74923d 935 has 'bar' => (
f8a54681 936 is => 'rw',
937 isa => 'Str',
938 );
939
940You can then get the value 'baz' by calling $c->model('Foo')->bar
9c74923d 941(or $self->bar inside code in the model).
942
943B<NOTE:> you MUST NOT call C<< $self->config >> or C<< __PACKAGE__->config >>
944as a way of reading config within your code, as this B<will not> give you the
945correctly merged config back. You B<MUST> take the config values supplied to
946the constructor and use those instead.
f8a54681 947
3643e890 948=cut
949
4090e3bb 950around config => sub {
951 my $orig = shift;
3643e890 952 my $c = shift;
953
fcf89172 954 croak('Setting config after setup has been run is not allowed.')
955 if ( @_ and $c->setup_finished );
3643e890 956
4090e3bb 957 $c->$orig(@_);
958};
3643e890 959
b5ecfcf0 960=head2 $c->log
0ef52a96 961
86418559 962Returns the logging object instance. Unless it is already set, Catalyst
963sets this up with a L<Catalyst::Log> object. To use your own log class,
964set the logger with the C<< __PACKAGE__->log >> method prior to calling
9e7673af 965C<< __PACKAGE__->setup >>.
966
967 __PACKAGE__->log( MyLogger->new );
968 __PACKAGE__->setup;
969
970And later:
0ef52a96 971
ae1e6b59 972 $c->log->info( 'Now logging with my own logger!' );
0ef52a96 973
86418559 974Your log class should implement the methods described in
975L<Catalyst::Log>.
af3ff00e 976
b4b01a8a 977
978=head2 $c->debug
979
c74d3f0c 980Returns 1 if debug mode is enabled, 0 otherwise.
b4b01a8a 981
7e5c67f2 982You can enable debug mode in several ways:
983
984=over
985
62a6df80 986=item By calling myapp_server.pl with the -d flag
987
7e5c67f2 988=item With the environment variables MYAPP_DEBUG, or CATALYST_DEBUG
989
990=item The -Debug option in your MyApp.pm
991
8eae92ad 992=item By declaring C<sub debug { 1 }> in your MyApp.pm.
7e5c67f2 993
994=back
c74d3f0c 995
c8083f4e 996The first three also set the log level to 'debug'.
997
8eae92ad 998Calling C<< $c->debug(1) >> has no effect.
e80e8542 999
af3ff00e 1000=cut
1001
b4b01a8a 1002sub debug { 0 }
1003
1004=head2 $c->dispatcher
1005
2887a7f1 1006Returns the dispatcher instance. See L<Catalyst::Dispatcher>.
b4b01a8a 1007
1008=head2 $c->engine
1009
2887a7f1 1010Returns the engine instance. See L<Catalyst::Engine>.
b4b01a8a 1011
1012
f7b672ef 1013=head2 UTILITY METHODS
66e28e3f 1014
b5ecfcf0 1015=head2 $c->path_to(@path)
01033d73 1016
cc95842f 1017Merges C<@path> with C<< $c->config->{home} >> and returns a
4e392da6 1018L<Path::Class::Dir> object. Note you can usually use this object as
1019a filename, but sometimes you will have to explicitly stringify it
18a9655c 1020yourself by calling the C<< ->stringify >> method.
01033d73 1021
1022For example:
1023
1024 $c->path_to( 'db', 'sqlite.db' );
1025
1026=cut
1027
1028sub path_to {
1029 my ( $c, @path ) = @_;
a738ab68 1030 my $path = Path::Class::Dir->new( $c->config->{home}, @path );
01033d73 1031 if ( -d $path ) { return $path }
a738ab68 1032 else { return Path::Class::File->new( $c->config->{home}, @path ) }
01033d73 1033}
1034
b5ecfcf0 1035=head2 $c->plugin( $name, $class, @args )
0ef52a96 1036
10011c19 1037Helper method for plugins. It creates a class data accessor/mutator and
ae1e6b59 1038loads and instantiates the given class.
0ef52a96 1039
1040 MyApp->plugin( 'prototype', 'HTML::Prototype' );
1041
1042 $c->prototype->define_javascript_functions;
4e68badc 1043
6b2a933b 1044B<Note:> This method of adding plugins is deprecated. The ability
4e68badc 1045to add plugins like this B<will be removed> in a Catalyst 5.81.
6b2a933b 1046Please do not use this functionality in new code.
0ef52a96 1047
1048=cut
1049
1050sub plugin {
1051 my ( $class, $name, $plugin, @args ) = @_;
6b2a933b 1052
4e68badc 1053 # See block comment in t/unit_core_plugin.t
b3542016 1054 $class->log->warn(qq/Adding plugin using the ->plugin method is deprecated, and will be removed in Catalyst 5.81/);
4e68badc 1055
97b58e17 1056 $class->_register_plugin( $plugin, 1 );
0ef52a96 1057
1058 eval { $plugin->import };
1059 $class->mk_classdata($name);
1060 my $obj;
1061 eval { $obj = $plugin->new(@args) };
1062
1063 if ($@) {
1064 Catalyst::Exception->throw( message =>
1065 qq/Couldn't instantiate instant plugin "$plugin", "$@"/ );
1066 }
1067
1068 $class->$name($obj);
1069 $class->log->debug(qq/Initialized instant plugin "$plugin" as "$name"/)
1070 if $class->debug;
1071}
1072
b5ecfcf0 1073=head2 MyApp->setup
fbcc39ad 1074
e7f1cf73 1075Initializes the dispatcher and engine, loads any plugins, and loads the
ae1e6b59 1076model, view, and controller components. You may also specify an array
1077of plugins to load here, if you choose to not load them in the C<use
1078Catalyst> line.
fbcc39ad 1079
0ef52a96 1080 MyApp->setup;
1081 MyApp->setup( qw/-Debug/ );
fbcc39ad 1082
1083=cut
1084
1085sub setup {
0319a12c 1086 my ( $class, @arguments ) = @_;
c2f3cc1b 1087 croak('Running setup more than once')
1088 if ( $class->setup_finished );
5168a5fc 1089
fbcc39ad 1090 unless ( $class->isa('Catalyst') ) {
953b0e15 1091
fbcc39ad 1092 Catalyst::Exception->throw(
1093 message => qq/'$class' does not inherit from Catalyst/ );
1c99e125 1094 }
0319a12c 1095
fbcc39ad 1096 if ( $class->arguments ) {
1097 @arguments = ( @arguments, @{ $class->arguments } );
1098 }
1099
1100 # Process options
1101 my $flags = {};
1102
1103 foreach (@arguments) {
1104
1105 if (/^-Debug$/) {
1106 $flags->{log} =
1107 ( $flags->{log} ) ? 'debug,' . $flags->{log} : 'debug';
1108 }
1109 elsif (/^-(\w+)=?(.*)$/) {
1110 $flags->{ lc $1 } = $2;
1111 }
1112 else {
1113 push @{ $flags->{plugins} }, $_;
1114 }
1115 }
1116
99f187d6 1117 $class->setup_home( delete $flags->{home} );
1118
fbcc39ad 1119 $class->setup_log( delete $flags->{log} );
1120 $class->setup_plugins( delete $flags->{plugins} );
1121 $class->setup_dispatcher( delete $flags->{dispatcher} );
acbecf08 1122 if (my $engine = delete $flags->{engine}) {
1123 $class->log->warn("Specifying the engine in ->setup is no longer supported, XXX FIXME");
1124 }
1125 $class->setup_engine();
dc5f035e 1126 $class->setup_stats( delete $flags->{stats} );
fbcc39ad 1127
1128 for my $flag ( sort keys %{$flags} ) {
1129
1130 if ( my $code = $class->can( 'setup_' . $flag ) ) {
1131 &$code( $class, delete $flags->{$flag} );
1132 }
1133 else {
1134 $class->log->warn(qq/Unknown flag "$flag"/);
1135 }
1136 }
1137
0eb4af72 1138 eval { require Catalyst::Devel; };
1139 if( !$@ && $ENV{CATALYST_SCRIPT_GEN} && ( $ENV{CATALYST_SCRIPT_GEN} < $Catalyst::Devel::CATALYST_SCRIPT_GEN ) ) {
1140 $class->log->warn(<<"EOF");
4ff0d824 1141You are running an old script!
1142
34a83d89 1143 Please update by running (this will overwrite existing files):
1144 catalyst.pl -force -scripts $class
1145
1146 or (this will not overwrite existing files):
1147 catalyst.pl -scripts $class
1cf0345b 1148
4ff0d824 1149EOF
0eb4af72 1150 }
62a6df80 1151
fbcc39ad 1152 if ( $class->debug ) {
6601f2ad 1153 my @plugins = map { "$_ " . ( $_->VERSION || '' ) } $class->registered_plugins;
fbcc39ad 1154
1155 if (@plugins) {
39fc2ce1 1156 my $column_width = Catalyst::Utils::term_width() - 6;
1157 my $t = Text::SimpleTable->new($column_width);
8c113188 1158 $t->row($_) for @plugins;
1cf0345b 1159 $class->log->debug( "Loaded plugins:\n" . $t->draw . "\n" );
fbcc39ad 1160 }
1161
1162 my $dispatcher = $class->dispatcher;
1163 my $engine = $class->engine;
1164 my $home = $class->config->{home};
1165
01ce7075 1166 $class->log->debug(sprintf(q/Loaded dispatcher "%s"/, blessed($dispatcher)));
1167 $class->log->debug(sprintf(q/Loaded engine "%s"/, blessed($engine)));
fbcc39ad 1168
1169 $home
1170 ? ( -d $home )
1171 ? $class->log->debug(qq/Found home "$home"/)
1172 : $class->log->debug(qq/Home "$home" doesn't exist/)
1173 : $class->log->debug(q/Couldn't find home/);
1174 }
1175
54f4bfef 1176 # Call plugins setup, this is stupid and evil.
16b7c476 1177 # Also screws C3 badly on 5.10, hack to avoid.
fbcc39ad 1178 {
1179 no warnings qw/redefine/;
1180 local *setup = sub { };
16b7c476 1181 $class->setup unless $Catalyst::__AM_RESTARTING;
fbcc39ad 1182 }
1183
1184 # Initialize our data structure
1185 $class->components( {} );
1186
1187 $class->setup_components;
1188
1189 if ( $class->debug ) {
39fc2ce1 1190 my $column_width = Catalyst::Utils::term_width() - 8 - 9;
1191 my $t = Text::SimpleTable->new( [ $column_width, 'Class' ], [ 8, 'Type' ] );
684d10ed 1192 for my $comp ( sort keys %{ $class->components } ) {
1193 my $type = ref $class->components->{$comp} ? 'instance' : 'class';
1194 $t->row( $comp, $type );
1195 }
1cf0345b 1196 $class->log->debug( "Loaded components:\n" . $t->draw . "\n" )
8c113188 1197 if ( keys %{ $class->components } );
fbcc39ad 1198 }
1199
1200 # Add our self to components, since we are also a component
96d8d513 1201 if( $class->isa('Catalyst::Controller') ){
1202 $class->components->{$class} = $class;
1203 }
fbcc39ad 1204
1205 $class->setup_actions;
1206
1207 if ( $class->debug ) {
1208 my $name = $class->config->{name} || 'Application';
1209 $class->log->info("$name powered by Catalyst $Catalyst::VERSION");
1210 }
3643e890 1211
62a6df80 1212 # Make sure that the application class becomes immutable at this point,
acca8cd5 1213 B::Hooks::EndOfScope::on_scope_end {
df861f8e 1214 return if $@;
e106a59f 1215 my $meta = Class::MOP::get_metaclass_by_name($class);
4ffa3785 1216 if (
1217 $meta->is_immutable
1218 && ! { $meta->immutable_options }->{replace_constructor}
1219 && (
1220 $class->isa('Class::Accessor::Fast')
1221 || $class->isa('Class::Accessor')
1222 )
1223 ) {
81ef9afd 1224 warn "You made your application class ($class) immutable, "
4ffa3785 1225 . "but did not inline the\nconstructor. "
1226 . "This will break catalyst, as your app \@ISA "
1227 . "Class::Accessor(::Fast)?\nPlease pass "
1228 . "(replace_constructor => 1)\nwhen making your class immutable.\n";
6e5505d4 1229 }
83b8cda1 1230 $meta->make_immutable(
1231 replace_constructor => 1,
83b8cda1 1232 ) unless $meta->is_immutable;
acca8cd5 1233 };
3d041c32 1234
647a3de1 1235 if ($class->config->{case_sensitive}) {
1236 $class->log->warn($class . "->config->{case_sensitive} is set.");
1237 $class->log->warn("This setting is deprecated and planned to be removed in Catalyst 5.81.");
1238 }
1239
a5d07d29 1240 $class->setup_finalize;
647a3de1 1241 # Should be the last thing we do so that user things hooking
1242 # setup_finalize can log..
1243 $class->log->_flush() if $class->log->can('_flush');
64ceb36b 1244 return 1; # Explicit return true as people have __PACKAGE__->setup as the last thing in their class. HATE.
a5d07d29 1245}
1246
23c63a17 1247=head2 $app->setup_finalize
1248
128a7cee 1249A hook to attach modifiers to. This method does not do anything except set the
1250C<setup_finished> accessor.
23c63a17 1251
128a7cee 1252Applying method modifiers to the C<setup> method doesn't work, because of quirky thingsdone for plugin setup.
23c63a17 1253
128a7cee 1254Example:
23c63a17 1255
128a7cee 1256 after setup_finalize => sub {
1257 my $app = shift;
23c63a17 1258
128a7cee 1259 ## do stuff here..
1260 };
23c63a17 1261
1262=cut
1263
a5d07d29 1264sub setup_finalize {
1265 my ($class) = @_;
3643e890 1266 $class->setup_finished(1);
fbcc39ad 1267}
1268
d71da6fe 1269=head2 $c->uri_for( $path?, @args?, \%query_values? )
fbcc39ad 1270
ee8963de 1271=head2 $c->uri_for( $action, \@captures?, @args?, \%query_values? )
9df7c5d9 1272
ee8963de 1273Constructs an absolute L<URI> object based on the application root, the
1274provided path, and the additional arguments and query parameters provided.
186d5270 1275When used as a string, provides a textual URI. If you need more flexibility
92981fc3 1276than this (i.e. the option to provide relative URIs etc.) see
186d5270 1277L<Catalyst::Plugin::SmartURI>.
ee8963de 1278
d71da6fe 1279If no arguments are provided, the URI for the current action is returned.
1280To return the current action and also provide @args, use
1d3a0700 1281C<< $c->uri_for( $c->action, @args ) >>.
d71da6fe 1282
ee8963de 1283If the first argument is a string, it is taken as a public URI path relative
1284to C<< $c->namespace >> (if it doesn't begin with a forward slash) or
e7e4c469 1285relative to the application root (if it does). It is then merged with
ee8963de 1286C<< $c->request->base >>; any C<@args> are appended as additional path
1287components; and any C<%query_values> are appended as C<?foo=bar> parameters.
1288
1289If the first argument is a L<Catalyst::Action> it represents an action which
1290will have its path resolved using C<< $c->dispatcher->uri_for_action >>. The
1291optional C<\@captures> argument (an arrayref) allows passing the captured
1292variables that are needed to fill in the paths of Chained and Regex actions;
1293once the path is resolved, C<uri_for> continues as though a path was
1294provided, appending any arguments or parameters and creating an absolute
1295URI.
1296
e7e4c469 1297The captures for the current request can be found in
ee8963de 1298C<< $c->request->captures >>, and actions can be resolved using
1299C<< Catalyst::Controller->action_for($name) >>. If you have a private action
1300path, use C<< $c->uri_for_action >> instead.
1301
1302 # Equivalent to $c->req->uri
e7e4c469 1303 $c->uri_for($c->action, $c->req->captures,
ee8963de 1304 @{ $c->req->args }, $c->req->params);
62a6df80 1305
9df7c5d9 1306 # For the Foo action in the Bar controller
ee8963de 1307 $c->uri_for($c->controller('Bar')->action_for('Foo'));
9df7c5d9 1308
ee8963de 1309 # Path to a static resource
1310 $c->uri_for('/static/images/logo.png');
d5e3d528 1311
4cf1dd00 1312=cut
1313
fbcc39ad 1314sub uri_for {
00e6a2b7 1315 my ( $c, $path, @args ) = @_;
00e6a2b7 1316
7069eab5 1317 if (blessed($path) && $path->isa('Catalyst::Controller')) {
1318 $path = $path->path_prefix;
1319 $path =~ s{/+\z}{};
1320 $path .= '/';
1321 }
1322
2689f8a4 1323 undef($path) if (defined $path && $path eq '');
1324
1325 my $params =
1326 ( scalar @args && ref $args[$#args] eq 'HASH' ? pop @args : {} );
1327
1328 carp "uri_for called with undef argument" if grep { ! defined $_ } @args;
a4f2cdc8 1329 foreach my $arg (@args) {
1330 utf8::encode($arg) if utf8::is_utf8($arg);
49229f68 1331 $arg =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
2689f8a4 1332 }
1333
7e95ba12 1334 if ( blessed($path) ) { # action object
49229f68 1335 s|/|%2F|g for @args;
2689f8a4 1336 my $captures = [ map { s|/|%2F|g; $_; }
aaf72276 1337 ( scalar @args && ref $args[0] eq 'ARRAY'
1338 ? @{ shift(@args) }
1339 : ()) ];
7b346bc3 1340
1341 foreach my $capture (@$captures) {
1342 utf8::encode($capture) if utf8::is_utf8($capture);
1343 $capture =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
1344 }
1345
aa7e913e 1346 my $action = $path;
1347 $path = $c->dispatcher->uri_for_action($action, $captures);
1348 if (not defined $path) {
1349 $c->log->debug(qq/Can't find uri_for action '$action' @$captures/)
1350 if $c->debug;
1351 return undef;
1352 }
81e75875 1353 $path = '/' if $path eq '';
ea0e58d9 1354 }
1355
51674a63 1356 unshift(@args, $path);
1357
1358 unless (defined $path && $path =~ s!^/!!) { # in-place strip
1359 my $namespace = $c->namespace;
1360 if (defined $path) { # cheesy hack to handle path '../foo'
1361 $namespace =~ s{(?:^|/)[^/]+$}{} while $args[0] =~ s{^\.\./}{};
6601f2ad 1362 }
51674a63 1363 unshift(@args, $namespace || '');
1364 }
62a6df80 1365
189e2a51 1366 # join args with '/', or a blank string
51674a63 1367 my $args = join('/', grep { defined($_) } @args);
1368 $args =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
7a2295bc 1369 $args =~ s!^/+!!;
51674a63 1370 my $base = $c->req->base;
1371 my $class = ref($base);
1372 $base =~ s{(?<!/)$}{/};
1373
1374 my $query = '';
1375
1376 if (my @keys = keys %$params) {
1377 # somewhat lifted from URI::_query's query_form
1378 $query = '?'.join('&', map {
2f381252 1379 my $val = $params->{$_};
51674a63 1380 s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/go;
1381 s/ /+/g;
1382 my $key = $_;
51674a63 1383 $val = '' unless defined $val;
1384 (map {
1f851263 1385 my $param = "$_";
1386 utf8::encode( $param ) if utf8::is_utf8($param);
51674a63 1387 # using the URI::Escape pattern here so utf8 chars survive
1f851263 1388 $param =~ s/([^A-Za-z0-9\-_.!~*'() ])/$URI::Escape::escapes{$1}/go;
1389 $param =~ s/ /+/g;
1390 "${key}=$param"; } ( ref $val eq 'ARRAY' ? @$val : $val ));
51674a63 1391 } @keys);
1392 }
1393
1394 my $res = bless(\"${base}${args}${query}", $class);
d3e7a648 1395 $res;
fbcc39ad 1396}
1397
833b385e 1398=head2 $c->uri_for_action( $path, \@captures?, @args?, \%query_values? )
1399
1400=head2 $c->uri_for_action( $action, \@captures?, @args?, \%query_values? )
1401
1402=over
1403
1404=item $path
1405
1406A private path to the Catalyst action you want to create a URI for.
1407
1408This is a shortcut for calling C<< $c->dispatcher->get_action_by_path($path)
1409>> and passing the resulting C<$action> and the remaining arguments to C<<
1410$c->uri_for >>.
1411
1412You can also pass in a Catalyst::Action object, in which case it is passed to
1413C<< $c->uri_for >>.
1414
c9ec25f8 1415Note 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.
1416
1417For example, if the action looks like:
1418
1419 package MyApp::Controller::Users;
1420
1421 sub lst : Path('the-list') {}
1422
1423You can use:
1424
1425 $c->uri_for_action('/users/lst')
1426
1427and it will create the URI /users/the-list.
1428
833b385e 1429=back
1430
1431=cut
1432
1433sub uri_for_action {
1434 my ( $c, $path, @args ) = @_;
62a6df80 1435 my $action = blessed($path)
1436 ? $path
833b385e 1437 : $c->dispatcher->get_action_by_path($path);
4ac0b9cb 1438 unless (defined $action) {
1439 croak "Can't find action for path '$path'";
1440 }
833b385e 1441 return $c->uri_for( $action, @args );
1442}
1443
b5ecfcf0 1444=head2 $c->welcome_message
ab2374d3 1445
1446Returns the Catalyst welcome HTML page.
1447
1448=cut
1449
1450sub welcome_message {
bf1f2c60 1451 my $c = shift;
1452 my $name = $c->config->{name};
1453 my $logo = $c->uri_for('/static/images/catalyst_logo.png');
1454 my $prefix = Catalyst::Utils::appprefix( ref $c );
80cdbbff 1455 $c->response->content_type('text/html; charset=utf-8');
ab2374d3 1456 return <<"EOF";
80cdbbff 1457<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1458 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1459<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
ab2374d3 1460 <head>
85d9fce6 1461 <meta http-equiv="Content-Language" content="en" />
1462 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
ab2374d3 1463 <title>$name on Catalyst $VERSION</title>
1464 <style type="text/css">
1465 body {
ab2374d3 1466 color: #000;
1467 background-color: #eee;
1468 }
1469 div#content {
1470 width: 640px;
80cdbbff 1471 margin-left: auto;
1472 margin-right: auto;
ab2374d3 1473 margin-top: 10px;
1474 margin-bottom: 10px;
1475 text-align: left;
1476 background-color: #ccc;
1477 border: 1px solid #aaa;
ab2374d3 1478 }
d84c4dab 1479 p, h1, h2 {
ab2374d3 1480 margin-left: 20px;
1481 margin-right: 20px;
16215972 1482 font-family: verdana, tahoma, sans-serif;
ab2374d3 1483 }
d84c4dab 1484 a {
1485 font-family: verdana, tahoma, sans-serif;
1486 }
d114e033 1487 :link, :visited {
1488 text-decoration: none;
1489 color: #b00;
1490 border-bottom: 1px dotted #bbb;
1491 }
1492 :link:hover, :visited:hover {
d114e033 1493 color: #555;
1494 }
ab2374d3 1495 div#topbar {
1496 margin: 0px;
1497 }
3e82a295 1498 pre {
3e82a295 1499 margin: 10px;
1500 padding: 8px;
1501 }
ab2374d3 1502 div#answers {
1503 padding: 8px;
1504 margin: 10px;
d114e033 1505 background-color: #fff;
ab2374d3 1506 border: 1px solid #aaa;
ab2374d3 1507 }
1508 h1 {
33108eaf 1509 font-size: 0.9em;
1510 font-weight: normal;
ab2374d3 1511 text-align: center;
1512 }
1513 h2 {
1514 font-size: 1.0em;
1515 }
1516 p {
1517 font-size: 0.9em;
1518 }
ae7c5252 1519 p img {
1520 float: right;
1521 margin-left: 10px;
1522 }
9619f23c 1523 span#appname {
1524 font-weight: bold;
33108eaf 1525 font-size: 1.6em;
ab2374d3 1526 }
1527 </style>
1528 </head>
1529 <body>
1530 <div id="content">
1531 <div id="topbar">
9619f23c 1532 <h1><span id="appname">$name</span> on <a href="http://catalyst.perl.org">Catalyst</a>
d84c4dab 1533 $VERSION</h1>
ab2374d3 1534 </div>
1535 <div id="answers">
ae7c5252 1536 <p>
80cdbbff 1537 <img src="$logo" alt="Catalyst Logo" />
ae7c5252 1538 </p>
596aaffe 1539 <p>Welcome to the world of Catalyst.
f92fd545 1540 This <a href="http://en.wikipedia.org/wiki/MVC">MVC</a>
1541 framework will make web development something you had
60dd6e1d 1542 never expected it to be: Fun, rewarding, and quick.</p>
ab2374d3 1543 <h2>What to do now?</h2>
4b8cb778 1544 <p>That really depends on what <b>you</b> want to do.
ab2374d3 1545 We do, however, provide you with a few starting points.</p>
1546 <p>If you want to jump right into web development with Catalyst
2f381252 1547 you might want to start with a tutorial.</p>
b607f8a0 1548<pre>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Tutorial.pod">Catalyst::Manual::Tutorial</a></code>
596aaffe 1549</pre>
1550<p>Afterwards you can go on to check out a more complete look at our features.</p>
1551<pre>
b607f8a0 1552<code>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Intro.pod">Catalyst::Manual::Intro</a>
1553<!-- Something else should go here, but the Catalyst::Manual link seems unhelpful -->
1554</code></pre>
ab2374d3 1555 <h2>What to do next?</h2>
f5681c92 1556 <p>Next it's time to write an actual application. Use the
80cdbbff 1557 helper scripts to generate <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AController%3A%3A&amp;mode=all">controllers</a>,
60dd6e1d 1558 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AModel%3A%3A&amp;mode=all">models</a>, and
1559 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AView%3A%3A&amp;mode=all">views</a>;
bf1f2c60 1560 they can save you a lot of work.</p>
c5f31918 1561 <pre><code>script/${prefix}_create.pl --help</code></pre>
bf1f2c60 1562 <p>Also, be sure to check out the vast and growing
802bf2cb 1563 collection of <a href="http://search.cpan.org/search?query=Catalyst">plugins for Catalyst on CPAN</a>;
bf1f2c60 1564 you are likely to find what you need there.
f5681c92 1565 </p>
1566
82245cc4 1567 <h2>Need help?</h2>
f5681c92 1568 <p>Catalyst has a very active community. Here are the main places to
1569 get in touch with us.</p>
16215972 1570 <ul>
1571 <li>
2b9a7d76 1572 <a href="http://dev.catalyst.perl.org">Wiki</a>
16215972 1573 </li>
1574 <li>
6d4c3368 1575 <a href="http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst">Mailing-List</a>
16215972 1576 </li>
1577 <li>
4eaf7c88 1578 <a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
16215972 1579 </li>
1580 </ul>
ab2374d3 1581 <h2>In conclusion</h2>
62a6df80 1582 <p>The Catalyst team hopes you will enjoy using Catalyst as much
f5681c92 1583 as we enjoyed making it. Please contact us if you have ideas
1584 for improvement or other feedback.</p>
ab2374d3 1585 </div>
1586 </div>
1587 </body>
1588</html>
1589EOF
1590}
1591
fbcc39ad 1592=head1 INTERNAL METHODS
1593
ae1e6b59 1594These methods are not meant to be used by end users.
1595
b5ecfcf0 1596=head2 $c->components
fbcc39ad 1597
e7f1cf73 1598Returns a hash of components.
fbcc39ad 1599
b5ecfcf0 1600=head2 $c->context_class
1f9cb7c1 1601
e7f1cf73 1602Returns or sets the context class.
1f9cb7c1 1603
b5ecfcf0 1604=head2 $c->counter
fbcc39ad 1605
ae1e6b59 1606Returns a hashref containing coderefs and execution counts (needed for
1607deep recursion detection).
fbcc39ad 1608
b5ecfcf0 1609=head2 $c->depth
fbcc39ad 1610
e7f1cf73 1611Returns the number of actions on the current internal execution stack.
fbcc39ad 1612
b5ecfcf0 1613=head2 $c->dispatch
fbcc39ad 1614
e7f1cf73 1615Dispatches a request to actions.
fbcc39ad 1616
1617=cut
1618
1619sub dispatch { my $c = shift; $c->dispatcher->dispatch( $c, @_ ) }
1620
b5ecfcf0 1621=head2 $c->dispatcher_class
1f9cb7c1 1622
e7f1cf73 1623Returns or sets the dispatcher class.
1f9cb7c1 1624
b5ecfcf0 1625=head2 $c->dump_these
7f92deef 1626
ae1e6b59 1627Returns a list of 2-element array references (name, structure) pairs
1628that will be dumped on the error page in debug mode.
7f92deef 1629
1630=cut
1631
1632sub dump_these {
1633 my $c = shift;
62a6df80 1634 [ Request => $c->req ],
1635 [ Response => $c->res ],
052a2d89 1636 [ Stash => $c->stash ],
1637 [ Config => $c->config ];
7f92deef 1638}
1639
b5ecfcf0 1640=head2 $c->engine_class
1f9cb7c1 1641
e7f1cf73 1642Returns or sets the engine class.
1f9cb7c1 1643
b5ecfcf0 1644=head2 $c->execute( $class, $coderef )
fbcc39ad 1645
0ef52a96 1646Execute a coderef in given class and catch exceptions. Errors are available
1647via $c->error.
fbcc39ad 1648
1649=cut
1650
1651sub execute {
1652 my ( $c, $class, $code ) = @_;
858828dd 1653 $class = $c->component($class) || $class;
fbcc39ad 1654 $c->state(0);
a0eca838 1655
197bd788 1656 if ( $c->depth >= $RECURSION ) {
f3414019 1657 my $action = $code->reverse();
91d08727 1658 $action = "/$action" unless $action =~ /->/;
f3414019 1659 my $error = qq/Deep recursion detected calling "${action}"/;
1627551a 1660 $c->log->error($error);
1661 $c->error($error);
1662 $c->state(0);
1663 return $c->state;
1664 }
1665
dc5f035e 1666 my $stats_info = $c->_stats_start_execute( $code ) if $c->use_stats;
22247e54 1667
8767c5a3 1668 push( @{ $c->stack }, $code );
62a6df80 1669
6f3df815 1670 no warnings 'recursion';
524b0e1c 1671 # N.B. This used to be combined, but I have seen $c get clobbered if so, and
1672 # I have no idea how, ergo $ret (which appears to fix the issue)
1673 eval { my $ret = $code->execute( $class, $c, @{ $c->req->args } ) || 0; $c->state( $ret ) };
22247e54 1674
dc5f035e 1675 $c->_stats_finish_execute( $stats_info ) if $c->use_stats and $stats_info;
62a6df80 1676
a6724a82 1677 my $last = pop( @{ $c->stack } );
fbcc39ad 1678
1679 if ( my $error = $@ ) {
79f5d571 1680 if ( blessed($error) and $error->isa('Catalyst::Exception::Detach') ) {
f87b7c21 1681 $error->rethrow if $c->depth > 1;
2f381252 1682 }
79f5d571 1683 elsif ( blessed($error) and $error->isa('Catalyst::Exception::Go') ) {
f87b7c21 1684 $error->rethrow if $c->depth > 0;
55424863 1685 }
fbcc39ad 1686 else {
1687 unless ( ref $error ) {
91d08727 1688 no warnings 'uninitialized';
fbcc39ad 1689 chomp $error;
f59def82 1690 my $class = $last->class;
1691 my $name = $last->name;
1692 $error = qq/Caught exception in $class->$name "$error"/;
fbcc39ad 1693 }
fbcc39ad 1694 $c->error($error);
1695 $c->state(0);
1696 }
1697 }
1698 return $c->state;
1699}
1700
7a7d7af5 1701sub _stats_start_execute {
1702 my ( $c, $code ) = @_;
df960201 1703 my $appclass = ref($c) || $c;
a6724a82 1704 return if ( ( $code->name =~ /^_.*/ )
df960201 1705 && ( !$appclass->config->{show_internal_actions} ) );
7a7d7af5 1706
f3414019 1707 my $action_name = $code->reverse();
1708 $c->counter->{$action_name}++;
7a7d7af5 1709
f3414019 1710 my $action = $action_name;
a6724a82 1711 $action = "/$action" unless $action =~ /->/;
1712
7a7d7af5 1713 # determine if the call was the result of a forward
1714 # this is done by walking up the call stack and looking for a calling
1715 # sub of Catalyst::forward before the eval
1716 my $callsub = q{};
1717 for my $index ( 2 .. 11 ) {
1718 last
1719 if ( ( caller($index) )[0] eq 'Catalyst'
1720 && ( caller($index) )[3] eq '(eval)' );
1721
1722 if ( ( caller($index) )[3] =~ /forward$/ ) {
1723 $callsub = ( caller($index) )[3];
1724 $action = "-> $action";
1725 last;
1726 }
1727 }
1728
f3414019 1729 my $uid = $action_name . $c->counter->{$action_name};
74efc144 1730
a6724a82 1731 # is this a root-level call or a forwarded call?
1732 if ( $callsub =~ /forward$/ ) {
91740f34 1733 my $parent = $c->stack->[-1];
a6724a82 1734
1735 # forward, locate the caller
9c74923d 1736 if ( defined $parent && exists $c->counter->{"$parent"} ) {
69d8f33c 1737 $c->stats->profile(
62a6df80 1738 begin => $action,
69d8f33c 1739 parent => "$parent" . $c->counter->{"$parent"},
1740 uid => $uid,
1741 );
7a7d7af5 1742 }
1743 else {
1744
a6724a82 1745 # forward with no caller may come from a plugin
69d8f33c 1746 $c->stats->profile(
1747 begin => $action,
1748 uid => $uid,
1749 );
7a7d7af5 1750 }
1751 }
a6724a82 1752 else {
62a6df80 1753
a6724a82 1754 # root-level call
69d8f33c 1755 $c->stats->profile(
1756 begin => $action,
1757 uid => $uid,
1758 );
a6724a82 1759 }
dc5f035e 1760 return $action;
7a7d7af5 1761
7a7d7af5 1762}
1763
1764sub _stats_finish_execute {
1765 my ( $c, $info ) = @_;
69d8f33c 1766 $c->stats->profile( end => $info );
7a7d7af5 1767}
1768
b5ecfcf0 1769=head2 $c->finalize
fbcc39ad 1770
e7f1cf73 1771Finalizes the request.
fbcc39ad 1772
1773=cut
1774
1775sub finalize {
1776 my $c = shift;
1777
369c09bc 1778 for my $error ( @{ $c->error } ) {
1779 $c->log->error($error);
1780 }
1781
5050d7a7 1782 # Allow engine to handle finalize flow (for POE)
e63bdf38 1783 my $engine = $c->engine;
1784 if ( my $code = $engine->can('finalize') ) {
1785 $engine->$code($c);
fbcc39ad 1786 }
5050d7a7 1787 else {
fbcc39ad 1788
5050d7a7 1789 $c->finalize_uploads;
fbcc39ad 1790
5050d7a7 1791 # Error
1792 if ( $#{ $c->error } >= 0 ) {
1793 $c->finalize_error;
1794 }
1795
1796 $c->finalize_headers;
fbcc39ad 1797
5050d7a7 1798 # HEAD request
1799 if ( $c->request->method eq 'HEAD' ) {
1800 $c->response->body('');
1801 }
1802
1803 $c->finalize_body;
1804 }
62a6df80 1805
2bf54936 1806 $c->log_response;
10f204e1 1807
62a6df80 1808 if ($c->use_stats) {
596677b6 1809 my $elapsed = sprintf '%f', $c->stats->elapsed;
12bf12c0 1810 my $av = $elapsed == 0 ? '??' : sprintf '%.3f', 1 / $elapsed;
908e3d9e 1811 $c->log->info(
62a6df80 1812 "Request took ${elapsed}s ($av/s)\n" . $c->stats->report . "\n" );
908e3d9e 1813 }
fbcc39ad 1814
1815 return $c->response->status;
1816}
1817
b5ecfcf0 1818=head2 $c->finalize_body
fbcc39ad 1819
e7f1cf73 1820Finalizes body.
fbcc39ad 1821
1822=cut
1823
1824sub finalize_body { my $c = shift; $c->engine->finalize_body( $c, @_ ) }
1825
b5ecfcf0 1826=head2 $c->finalize_cookies
fbcc39ad 1827
e7f1cf73 1828Finalizes cookies.
fbcc39ad 1829
1830=cut
1831
147821ea 1832sub finalize_cookies { my $c = shift; $c->engine->finalize_cookies( $c, @_ ) }
fbcc39ad 1833
b5ecfcf0 1834=head2 $c->finalize_error
fbcc39ad 1835
e7f1cf73 1836Finalizes error.
fbcc39ad 1837
1838=cut
1839
1840sub finalize_error { my $c = shift; $c->engine->finalize_error( $c, @_ ) }
1841
b5ecfcf0 1842=head2 $c->finalize_headers
fbcc39ad 1843
e7f1cf73 1844Finalizes headers.
fbcc39ad 1845
1846=cut
1847
1848sub finalize_headers {
1849 my $c = shift;
1850
e63bdf38 1851 my $response = $c->response; #accessor calls can add up?
1852
fbcc39ad 1853 # Check if we already finalized headers
6680c772 1854 return if $response->finalized_headers;
fbcc39ad 1855
1856 # Handle redirects
e63bdf38 1857 if ( my $location = $response->redirect ) {
fbcc39ad 1858 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
e63bdf38 1859 $response->header( Location => $location );
a7caa492 1860
02570318 1861 if ( !$response->has_body ) {
39655cdc 1862 # Add a default body if none is already present
e63bdf38 1863 $response->body(
e422816e 1864 qq{<html><body><p>This item has moved <a href="$location">here</a>.</p></body></html>}
39655cdc 1865 );
1866 }
fbcc39ad 1867 }
1868
1869 # Content-Length
ac057d3b 1870 if ( defined $response->body && length $response->body && !$response->content_length ) {
775878ac 1871
8f62c91a 1872 # get the length from a filehandle
9c74923d 1873 if ( blessed( $response->body ) && $response->body->can('read') || ref( $response->body ) eq 'GLOB' )
197bd788 1874 {
e63bdf38 1875 my $stat = stat $response->body;
3b6a1db1 1876 if ( $stat && $stat->size > 0 ) {
e63bdf38 1877 $response->content_length( $stat->size );
8f62c91a 1878 }
1879 else {
775878ac 1880 $c->log->warn('Serving filehandle without a content-length');
8f62c91a 1881 }
1882 }
1883 else {
b5d7a61f 1884 # everything should be bytes at this point, but just in case
5ab21903 1885 $response->content_length( length( $response->body ) );
8f62c91a 1886 }
fbcc39ad 1887 }
1888
1889 # Errors
e63bdf38 1890 if ( $response->status =~ /^(1\d\d|[23]04)$/ ) {
1891 $response->headers->remove_header("Content-Length");
1892 $response->body('');
fbcc39ad 1893 }
1894
1895 $c->finalize_cookies;
1896
1897 $c->engine->finalize_headers( $c, @_ );
1898
1899 # Done
6680c772 1900 $response->finalized_headers(1);
fbcc39ad 1901}
1902
b5ecfcf0 1903=head2 $c->finalize_output
fbcc39ad 1904
1905An alias for finalize_body.
1906
b5ecfcf0 1907=head2 $c->finalize_read
fbcc39ad 1908
e7f1cf73 1909Finalizes the input after reading is complete.
fbcc39ad 1910
1911=cut
1912
1913sub finalize_read { my $c = shift; $c->engine->finalize_read( $c, @_ ) }
1914
b5ecfcf0 1915=head2 $c->finalize_uploads
fbcc39ad 1916
ae1e6b59 1917Finalizes uploads. Cleans up any temporary files.
fbcc39ad 1918
1919=cut
1920
1921sub finalize_uploads { my $c = shift; $c->engine->finalize_uploads( $c, @_ ) }
1922
b5ecfcf0 1923=head2 $c->get_action( $action, $namespace )
fbcc39ad 1924
e7f1cf73 1925Gets an action in a given namespace.
fbcc39ad 1926
1927=cut
1928
684d10ed 1929sub get_action { my $c = shift; $c->dispatcher->get_action(@_) }
fbcc39ad 1930
b5ecfcf0 1931=head2 $c->get_actions( $action, $namespace )
a9dc674c 1932
ae1e6b59 1933Gets all actions of a given name in a namespace and all parent
1934namespaces.
a9dc674c 1935
1936=cut
1937
1938sub get_actions { my $c = shift; $c->dispatcher->get_actions( $c, @_ ) }
1939
e5ce5f04 1940=head2 $app->handle_request( @arguments )
fbcc39ad 1941
e7f1cf73 1942Called to handle each HTTP request.
fbcc39ad 1943
1944=cut
1945
1946sub handle_request {
1947 my ( $class, @arguments ) = @_;
1948
1949 # Always expect worst case!
1950 my $status = -1;
3640641e 1951 try {
dea1884f 1952 if ($class->debug) {
908e3d9e 1953 my $secs = time - $START || 1;
1954 my $av = sprintf '%.3f', $COUNT / $secs;
1955 my $time = localtime time;
1956 $class->log->info("*** Request $COUNT ($av/s) [$$] [$time] ***");
dea1884f 1957 }
908e3d9e 1958
1959 my $c = $class->prepare(@arguments);
1960 $c->dispatch;
62a6df80 1961 $status = $c->finalize;
fbcc39ad 1962 }
3640641e 1963 catch {
1964 chomp(my $error = $_);
1965 $class->log->error(qq/Caught exception in engine "$error"/);
1966 };
fbcc39ad 1967
1968 $COUNT++;
62a6df80 1969
6680c772 1970 if(my $coderef = $class->log->can('_flush')){
1971 $class->log->$coderef();
1972 }
fbcc39ad 1973 return $status;
1974}
1975
b5ecfcf0 1976=head2 $c->prepare( @arguments )
fbcc39ad 1977
ae1e6b59 1978Creates a Catalyst context from an engine-specific request (Apache, CGI,
1979etc.).
fbcc39ad 1980
1981=cut
1982
1983sub prepare {
1984 my ( $class, @arguments ) = @_;
1985
6680c772 1986 # XXX
1987 # After the app/ctxt split, this should become an attribute based on something passed
1988 # into the application.
3cec521a 1989 $class->context_class( ref $class || $class ) unless $class->context_class;
62a6df80 1990
6680c772 1991 my $c = $class->context_class->new({});
1992
1993 # For on-demand data
1994 $c->request->_context($c);
1995 $c->response->_context($c);
fbcc39ad 1996
b6d4ee6e 1997 #surely this is not the most efficient way to do things...
dc5f035e 1998 $c->stats($class->stats_class->new)->enable($c->use_stats);
4f0b7cf1 1999 if ( $c->debug || $c->config->{enable_catalyst_header} ) {
62a6df80 2000 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
908e3d9e 2001 }
2002
3640641e 2003 try {
2004 # Allow engine to direct the prepare flow (for POE)
2005 if ( my $prepare = $c->engine->can('prepare') ) {
2006 $c->engine->$prepare( $c, @arguments );
2007 }
2008 else {
2009 $c->prepare_request(@arguments);
2010 $c->prepare_connection;
2011 $c->prepare_query_parameters;
2012 $c->prepare_headers;
2013 $c->prepare_cookies;
2014 $c->prepare_path;
2015
2016 # Prepare the body for reading, either by prepare_body
2017 # or the user, if they are using $c->read
2018 $c->prepare_read;
2019
2020 # Parse the body unless the user wants it on-demand
2021 unless ( ref($c)->config->{parse_on_demand} ) {
2022 $c->prepare_body;
2023 }
878b821c 2024 }
5050d7a7 2025 }
3640641e 2026 # VERY ugly and probably shouldn't rely on ->finalize actually working
2027 catch {
2028 # failed prepare is always due to an invalid request, right?
2029 $c->response->status(400);
2030 $c->response->content_type('text/plain');
2031 $c->response->body('Bad Request');
2032 $c->finalize;
2033 die $_;
2034 };
fbcc39ad 2035
fbcc39ad 2036 my $method = $c->req->method || '';
2f381252 2037 my $path = $c->req->path;
2038 $path = '/' unless length $path;
fbcc39ad 2039 my $address = $c->req->address || '';
2040
10f204e1 2041 $c->log_request;
fbcc39ad 2042
e3a13771 2043 $c->prepare_action;
2044
fbcc39ad 2045 return $c;
2046}
2047
b5ecfcf0 2048=head2 $c->prepare_action
fbcc39ad 2049
b4b01a8a 2050Prepares action. See L<Catalyst::Dispatcher>.
fbcc39ad 2051
2052=cut
2053
2054sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
2055
b5ecfcf0 2056=head2 $c->prepare_body
fbcc39ad 2057
e7f1cf73 2058Prepares message body.
fbcc39ad 2059
2060=cut
2061
2062sub prepare_body {
2063 my $c = shift;
2064
0f56bbcf 2065 return if $c->request->_has_body;
fbcc39ad 2066
2067 # Initialize on-demand data
2068 $c->engine->prepare_body( $c, @_ );
2069 $c->prepare_parameters;
2070 $c->prepare_uploads;
fbcc39ad 2071}
2072
b5ecfcf0 2073=head2 $c->prepare_body_chunk( $chunk )
4bd82c41 2074
e7f1cf73 2075Prepares a chunk of data before sending it to L<HTTP::Body>.
4bd82c41 2076
b4b01a8a 2077See L<Catalyst::Engine>.
2078
4bd82c41 2079=cut
2080
4f5ebacd 2081sub prepare_body_chunk {
2082 my $c = shift;
4bd82c41 2083 $c->engine->prepare_body_chunk( $c, @_ );
2084}
2085
b5ecfcf0 2086=head2 $c->prepare_body_parameters
fbcc39ad 2087
e7f1cf73 2088Prepares body parameters.
fbcc39ad 2089
2090=cut
2091
2092sub prepare_body_parameters {
2093 my $c = shift;
2094 $c->engine->prepare_body_parameters( $c, @_ );
2095}
2096
b5ecfcf0 2097=head2 $c->prepare_connection
fbcc39ad 2098
e7f1cf73 2099Prepares connection.
fbcc39ad 2100
2101=cut
2102
2103sub prepare_connection {
2104 my $c = shift;
2105 $c->engine->prepare_connection( $c, @_ );
2106}
2107
b5ecfcf0 2108=head2 $c->prepare_cookies
fbcc39ad 2109
e7f1cf73 2110Prepares cookies.
fbcc39ad 2111
2112=cut
2113
2114sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
2115
b5ecfcf0 2116=head2 $c->prepare_headers
fbcc39ad 2117
e7f1cf73 2118Prepares headers.
fbcc39ad 2119
2120=cut
2121
2122sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
2123
b5ecfcf0 2124=head2 $c->prepare_parameters
fbcc39ad 2125
e7f1cf73 2126Prepares parameters.
fbcc39ad 2127
2128=cut
2129
2130sub prepare_parameters {
2131 my $c = shift;
2132 $c->prepare_body_parameters;
2133 $c->engine->prepare_parameters( $c, @_ );
2134}
2135
b5ecfcf0 2136=head2 $c->prepare_path
fbcc39ad 2137
e7f1cf73 2138Prepares path and base.
fbcc39ad 2139
2140=cut
2141
2142sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
2143
b5ecfcf0 2144=head2 $c->prepare_query_parameters
fbcc39ad 2145
e7f1cf73 2146Prepares query parameters.
fbcc39ad 2147
2148=cut
2149
2150sub prepare_query_parameters {
2151 my $c = shift;
2152
2153 $c->engine->prepare_query_parameters( $c, @_ );
10f204e1 2154}
fbcc39ad 2155
10f204e1 2156=head2 $c->log_request
2157
2158Writes information about the request to the debug logs. This includes:
2159
2160=over 4
2161
854e5dcd 2162=item * Request method, path, and remote IP address
10f204e1 2163
2164=item * Query keywords (see L<Catalyst::Request/query_keywords>)
2165
e7cbe1bf 2166=item * Request parameters
10f204e1 2167
2168=item * File uploads
2169
2170=back
fbcc39ad 2171
2172=cut
2173
10f204e1 2174sub log_request {
2175 my $c = shift;
fbcc39ad 2176
10f204e1 2177 return unless $c->debug;
fbcc39ad 2178
2bf54936 2179 my($dump) = grep {$_->[0] eq 'Request' } $c->dump_these;
2180 my $request = $dump->[1];
e7cbe1bf 2181
2182 my ( $method, $path, $address ) = ( $request->method, $request->path, $request->address );
10f204e1 2183 $method ||= '';
2184 $path = '/' unless length $path;
2185 $address ||= '';
2186 $c->log->debug(qq/"$method" request for "$path" from "$address"/);
2187
3a4abdb3 2188 $c->log_request_headers($request->headers);
e7cbe1bf 2189
2190 if ( my $keywords = $request->query_keywords ) {
10f204e1 2191 $c->log->debug("Query keywords are: $keywords");
fbcc39ad 2192 }
10f204e1 2193
9c74923d 2194 $c->log_request_parameters( query => $request->query_parameters, $request->_has_body ? (body => $request->body_parameters) : () );
10f204e1 2195
e7cbe1bf 2196 $c->log_request_uploads($request);
fbcc39ad 2197}
2198
10f204e1 2199=head2 $c->log_response
fbcc39ad 2200
75b65816 2201Writes information about the response to the debug logs by calling
2202C<< $c->log_response_status_line >> and C<< $c->log_response_headers >>.
fbcc39ad 2203
2204=cut
2205
75b65816 2206sub log_response {
2207 my $c = shift;
fbcc39ad 2208
75b65816 2209 return unless $c->debug;
fbcc39ad 2210
75b65816 2211 my($dump) = grep {$_->[0] eq 'Response' } $c->dump_these;
2212 my $response = $dump->[1];
2213
2214 $c->log_response_status_line($response);
2215 $c->log_response_headers($response->headers);
2216}
2217
2218=head2 $c->log_response_status_line($response)
2219
2220Writes one line of information about the response to the debug logs. This includes:
10f204e1 2221
2222=over 4
2223
2224=item * Response status code
2225
3a4abdb3 2226=item * Content-Type header (if present)
2227
2228=item * Content-Length header (if present)
10f204e1 2229
2230=back
fbcc39ad 2231
2232=cut
2233
75b65816 2234sub log_response_status_line {
2235 my ($c, $response) = @_;
fbcc39ad 2236
697bab77 2237 $c->log->debug(
2238 sprintf(
2239 'Response Code: %s; Content-Type: %s; Content-Length: %s',
2240 $response->status || 'unknown',
2241 $response->headers->header('Content-Type') || 'unknown',
2242 $response->headers->header('Content-Length') || 'unknown'
2243 )
2244 );
10f204e1 2245}
fbcc39ad 2246
75b65816 2247=head2 $c->log_response_headers($headers);
2248
2249Hook method which can be wrapped by plugins to log the responseheaders.
2250No-op in the default implementation.
fbcc39ad 2251
2252=cut
2253
75b65816 2254sub log_response_headers {}
fbcc39ad 2255
10f204e1 2256=head2 $c->log_request_parameters( query => {}, body => {} )
2257
2258Logs request parameters to debug logs
2259
10f204e1 2260=cut
2261
2262sub log_request_parameters {
2263 my $c = shift;
2264 my %all_params = @_;
2265
2bf54936 2266 return unless $c->debug;
e7cbe1bf 2267
10f204e1 2268 my $column_width = Catalyst::Utils::term_width() - 44;
2269 foreach my $type (qw(query body)) {
2bf54936 2270 my $params = $all_params{$type};
2271 next if ! keys %$params;
10f204e1 2272 my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ $column_width, 'Value' ] );
e7cbe1bf 2273 for my $key ( sort keys %$params ) {
2274 my $param = $params->{$key};
10f204e1 2275 my $value = defined($param) ? $param : '';
2276 $t->row( $key, ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
2277 }
2278 $c->log->debug( ucfirst($type) . " Parameters are:\n" . $t->draw );
2279 }
2280}
2281
2282=head2 $c->log_request_uploads
2283
2284Logs file uploads included in the request to the debug logs.
854e5dcd 2285The parameter name, filename, file type, and file size are all included in
10f204e1 2286the debug logs.
2287
2288=cut
fbcc39ad 2289
10f204e1 2290sub log_request_uploads {
2291 my $c = shift;
2bf54936 2292 my $request = shift;
e7cbe1bf 2293 return unless $c->debug;
2294 my $uploads = $request->uploads;
10f204e1 2295 if ( keys %$uploads ) {
8c113188 2296 my $t = Text::SimpleTable->new(
34d28dfd 2297 [ 12, 'Parameter' ],
2298 [ 26, 'Filename' ],
8c113188 2299 [ 18, 'Type' ],
2300 [ 9, 'Size' ]
2301 );
10f204e1 2302 for my $key ( sort keys %$uploads ) {
2303 my $upload = $uploads->{$key};
fbcc39ad 2304 for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
8c113188 2305 $t->row( $key, $u->filename, $u->type, $u->size );
fbcc39ad 2306 }
2307 }
2308 $c->log->debug( "File Uploads are:\n" . $t->draw );
2309 }
2310}
2311
3a4abdb3 2312=head2 $c->log_request_headers($headers);
2313
2314Hook method which can be wrapped by plugins to log the request headers.
2315No-op in the default implementation.
2316
2317=cut
2318
2319sub log_request_headers {}
2320
10f204e1 2321=head2 $c->log_headers($type => $headers)
2322
e7cbe1bf 2323Logs L<HTTP::Headers> (either request or response) to the debug logs.
10f204e1 2324
2325=cut
2326
2327sub log_headers {
2328 my $c = shift;
2329 my $type = shift;
2330 my $headers = shift; # an HTTP::Headers instance
2331
e7cbe1bf 2332 return unless $c->debug;
10f204e1 2333
f0e9921a 2334 my $column_width = Catalyst::Utils::term_width() - 28;
2335 my $t = Text::SimpleTable->new( [ 15, 'Header Name' ], [ $column_width, 'Value' ] );
e7cbe1bf 2336 $headers->scan(
10f204e1 2337 sub {
2338 my ( $name, $value ) = @_;
2339 $t->row( $name, $value );
2340 }
2341 );
2342 $c->log->debug( ucfirst($type) . " Headers:\n" . $t->draw );
2343}
2344
10f204e1 2345
2346=head2 $c->prepare_read
2347
2348Prepares the input for reading.
2349
2350=cut
2351
2352sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
2353
2354=head2 $c->prepare_request
2355
2356Prepares the engine request.
2357
2358=cut
2359
2360sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
2361
2362=head2 $c->prepare_uploads
2363
2364Prepares uploads.
2365
2366=cut
2367
2368sub prepare_uploads {
2369 my $c = shift;
2370
2371 $c->engine->prepare_uploads( $c, @_ );
2372}
2373
b5ecfcf0 2374=head2 $c->prepare_write
fbcc39ad 2375
e7f1cf73 2376Prepares the output for writing.
fbcc39ad 2377
2378=cut
2379
2380sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
2381
b5ecfcf0 2382=head2 $c->request_class
1f9cb7c1 2383
3f87d500 2384Returns or sets the request class. Defaults to L<Catalyst::Request>.
1f9cb7c1 2385
b5ecfcf0 2386=head2 $c->response_class
1f9cb7c1 2387
3f87d500 2388Returns or sets the response class. Defaults to L<Catalyst::Response>.
1f9cb7c1 2389
b5ecfcf0 2390=head2 $c->read( [$maxlength] )
fbcc39ad 2391
ae1e6b59 2392Reads a chunk of data from the request body. This method is designed to
2393be used in a while loop, reading C<$maxlength> bytes on every call.
2394C<$maxlength> defaults to the size of the request if not specified.
fbcc39ad 2395
4600a5a1 2396You have to set C<< MyApp->config(parse_on_demand => 1) >> to use this
ae1e6b59 2397directly.
fbcc39ad 2398
878b821c 2399Warning: If you use read(), Catalyst will not process the body,
2400so you will not be able to access POST parameters or file uploads via
2401$c->request. You must handle all body parsing yourself.
2402
fbcc39ad 2403=cut
2404
2405sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
2406
b5ecfcf0 2407=head2 $c->run
fbcc39ad 2408
2409Starts the engine.
2410
2411=cut
2412
8f076801 2413sub run { my $c = shift; return $c->engine->run( $c, $c->_finalized_psgi_app, @_ ) }
fbcc39ad 2414
b5ecfcf0 2415=head2 $c->set_action( $action, $code, $namespace, $attrs )
fbcc39ad 2416
e7f1cf73 2417Sets an action in a given namespace.
fbcc39ad 2418
2419=cut
2420
2421sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
2422
b5ecfcf0 2423=head2 $c->setup_actions($component)
fbcc39ad 2424
e7f1cf73 2425Sets up actions for a component.
fbcc39ad 2426
2427=cut
2428
2429sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
2430
b5ecfcf0 2431=head2 $c->setup_components
fbcc39ad 2432
d261d153 2433This method is called internally to set up the application's components.
fbcc39ad 2434
d261d153 2435It finds modules by calling the L<locate_components> method, expands them to
2436package names with the L<expand_component_module> method, and then installs
2437each component into the application.
2438
2439The C<setup_components> config option is passed to both of the above methods.
fbcc39ad 2440
d261d153 2441Installation of each component is performed by the L<setup_component> method,
2442below.
2f381252 2443
fbcc39ad 2444=cut
2445
2446sub setup_components {
2447 my $class = shift;
2448
18de900e 2449 my $config = $class->config->{ setup_components };
62a6df80 2450
69c6b6cb 2451 my @comps = $class->locate_components($config);
b94b200c 2452 my %comps = map { $_ => 1 } @comps;
73e1183e 2453
8f6cebb2 2454 my $deprecatedcatalyst_component_names = grep { /::[CMV]::/ } @comps;
73e1183e 2455 $class->log->warn(qq{Your application is using the deprecated ::[MVC]:: type naming scheme.\n}.
2456 qq{Please switch your class names to ::Model::, ::View:: and ::Controller: as appropriate.\n}
8f6cebb2 2457 ) if $deprecatedcatalyst_component_names;
73e1183e 2458
b94b200c 2459 for my $component ( @comps ) {
dd91afb5 2460
2461 # We pass ignore_loaded here so that overlay files for (e.g.)
2462 # Model::DBI::Schema sub-classes are loaded - if it's in @comps
2463 # we know M::P::O found a file on disk so this is safe
2464
f5a4863c 2465 Catalyst::Utils::ensure_class_loaded( $component, { ignore_loaded => 1 } );
196f06d1 2466 }
2467
e7e4c469 2468 for my $component (@comps) {
5d02e790 2469 my $instance = $class->components->{ $component } = $class->setup_component($component);
2470 my @expanded_components = $instance->can('expand_modules')
2471 ? $instance->expand_modules( $component, $config )
2472 : $class->expand_component_module( $component, $config );
2473 for my $component (@expanded_components) {
05887b58 2474 next if $comps{$component};
e7e4c469 2475 $class->components->{ $component } = $class->setup_component($component);
fbcc39ad 2476 }
364d7324 2477 }
2478}
fbcc39ad 2479
d261d153 2480=head2 $c->locate_components( $setup_component_config )
2481
2482This method is meant to provide a list of component modules that should be
2483setup for the application. By default, it will use L<Module::Pluggable>.
2484
2485Specify a C<setup_components> config option to pass additional options directly
2486to L<Module::Pluggable>. To add additional search paths, specify a key named
2487C<search_extra> as an array reference. Items in the array beginning with C<::>
2488will have the application class name prepended to them.
2489
2490=cut
2491
2492sub locate_components {
2493 my $class = shift;
2494 my $config = shift;
2495
2496 my @paths = qw( ::Controller ::C ::Model ::M ::View ::V );
2497 my $extra = delete $config->{ search_extra } || [];
2498
2499 push @paths, @$extra;
2500
2501 my $locator = Module::Pluggable::Object->new(
2502 search_path => [ map { s/^(?=::)/$class/; $_; } @paths ],
2503 %$config
2504 );
2505
69c6b6cb 2506 # XXX think about ditching this sort entirely
2507 my @comps = sort { length $a <=> length $b } $locator->plugins;
d261d153 2508
2509 return @comps;
2510}
2511
2512=head2 $c->expand_component_module( $component, $setup_component_config )
2513
2514Components found by C<locate_components> will be passed to this method, which
2515is expected to return a list of component (package) names to be set up.
2516
d261d153 2517=cut
2518
2519sub expand_component_module {
2520 my ($class, $module) = @_;
05887b58 2521 return Devel::InnerPackage::list_packages( $module );
d261d153 2522}
2523
364d7324 2524=head2 $c->setup_component
fbcc39ad 2525
364d7324 2526=cut
fbcc39ad 2527
364d7324 2528sub setup_component {
2529 my( $class, $component ) = @_;
fbcc39ad 2530
364d7324 2531 unless ( $component->can( 'COMPONENT' ) ) {
2532 return $component;
2533 }
fbcc39ad 2534
364d7324 2535 my $suffix = Catalyst::Utils::class2classsuffix( $component );
2536 my $config = $class->config->{ $suffix } || {};
8f6cebb2 2537 # Stash catalyst_component_name in the config here, so that custom COMPONENT
d2598ac8 2538 # methods also pass it. local to avoid pointlessly shitting in config
2539 # for the debug screen, as $component is already the key name.
8f6cebb2 2540 local $config->{catalyst_component_name} = $component;
fbcc39ad 2541
364d7324 2542 my $instance = eval { $component->COMPONENT( $class, $config ); };
fbcc39ad 2543
2544 if ( my $error = $@ ) {
fbcc39ad 2545 chomp $error;
fbcc39ad 2546 Catalyst::Exception->throw(
364d7324 2547 message => qq/Couldn't instantiate component "$component", "$error"/
2548 );
fbcc39ad 2549 }
2550
7490de2a 2551 unless (blessed $instance) {
2552 my $metaclass = Moose::Util::find_meta($component);
2553 my $method_meta = $metaclass->find_method_by_name('COMPONENT');
2554 my $component_method_from = $method_meta->associated_metaclass->name;
637fa644 2555 my $value = defined($instance) ? $instance : 'undef';
7490de2a 2556 Catalyst::Exception->throw(
2557 message =>
637fa644 2558 qq/Couldn't instantiate component "$component", COMPONENT() method (from $component_method_from) didn't return an object-like value (value was $value)./
7490de2a 2559 );
2560 }
364d7324 2561 return $instance;
fbcc39ad 2562}
2563
b5ecfcf0 2564=head2 $c->setup_dispatcher
fbcc39ad 2565
ae1e6b59 2566Sets up dispatcher.
2567
fbcc39ad 2568=cut
2569
2570sub setup_dispatcher {
2571 my ( $class, $dispatcher ) = @_;
2572
2573 if ($dispatcher) {
2574 $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
2575 }
2576
cb69249e 2577 if ( my $env = Catalyst::Utils::env_value( $class, 'DISPATCHER' ) ) {
2578 $dispatcher = 'Catalyst::Dispatcher::' . $env;
fbcc39ad 2579 }
2580
2581 unless ($dispatcher) {
cb0354c6 2582 $dispatcher = $class->dispatcher_class;
fbcc39ad 2583 }
2584
e63bdf38 2585 Class::MOP::load_class($dispatcher);
fbcc39ad 2586
2587 # dispatcher instance
2588 $class->dispatcher( $dispatcher->new );
2589}
2590
b5ecfcf0 2591=head2 $c->setup_engine
fbcc39ad 2592
ae1e6b59 2593Sets up engine.
2594
fbcc39ad 2595=cut
2596
1e5dad00 2597sub engine_class {
2598 my $class = shift;
2599 $class->engine_loader->catalyst_engine_class(@_);
2600}
2601
fbcc39ad 2602sub setup_engine {
acbecf08 2603 my ($class) = @_;
fbcc39ad 2604
b1ededd4 2605 $class->engine_loader(Catalyst::EngineLoader->new(application_name => $class));
1e5dad00 2606
acbecf08 2607 my $engine = $class->engine_class;
e63bdf38 2608 Class::MOP::load_class($engine);
0e7f5826 2609
532f0516 2610 if ($ENV{MOD_PERL}) {
1e5dad00 2611 my $apache = $class->engine_loader->auto;
532f0516 2612 # FIXME - Immutable
9fe15721 2613 $class->meta->add_method(handler => sub {
2614 my $r = shift;
1e5dad00 2615 my $psgi_app = $class->psgi_app;
2616 $apache->call_app($r, $psgi_app);
9fe15721 2617 });
532f0516 2618 }
2619
fbcc39ad 2620 $class->engine( $engine->new );
9fe15721 2621
fcffcb05 2622 return;
2623}
2624
8f076801 2625sub _finalized_psgi_app {
c8f4781e 2626 my ($app) = @_;
a0eec1fb 2627
2628 unless ($app->_psgi_app) {
8f076801 2629 my $psgi_app = $app->_setup_psgi_app;
a0eec1fb 2630 $app->_psgi_app($psgi_app);
2631 }
2632
2633 return $app->_psgi_app;
c8f4781e 2634}
2635
8f076801 2636sub _setup_psgi_app {
fcffcb05 2637 my ($app) = @_;
2638
2639 if (my $home = Path::Class::Dir->new($app->config->{home})) {
2640 my $psgi_file = $home->file(
2641 Catalyst::Utils::appprefix($app) . '.psgi',
2642 );
2643
2644 return Plack::Util::load_psgi($psgi_file)
2645 if -e $psgi_file;
2646 }
2647
c72bc6eb 2648 return $app->_wrapped_legacy_psgi_app($app->psgi_app);
8f076801 2649}
2650
2651# Note - this is for back compatibility. Catalyst should not know or care about
2652# how it's deployed. The recommended way of configuring this is now to
2653# use the ReverseProxy middleware yourself if you want it in a .psgi
2654# file.
2655sub _wrapped_legacy_psgi_app {
c72bc6eb 2656 my ($app, $psgi_app) = @_;
8f076801 2657
d89b863e 2658 $psgi_app = Plack::Middleware::Conditional->wrap(
c72bc6eb 2659 $psgi_app,
fcffcb05 2660 builder => sub { Plack::Middleware::ReverseProxy->wrap($_[0]) },
2661 condition => sub {
2662 my ($env) = @_;
2663 return if $app->config->{ignore_frontend_proxy};
2664 return $env->{REMOTE_ADDR} eq '127.0.0.1'
2665 || $app->config->{using_frontend_proxy};
2666 },
2667 );
d89b863e 2668
00fa37d0 2669 my $server_matches = sub {
2670 my ($re) = @_;
2671 return sub {
2672 my ($env) = @_;
2673 my $server = $env->{SERVER_SOFTWARE};
2674 return unless $server;
2675 return $server =~ $re ? 1 : 0;
2676 };
2677 };
2678
d89b863e 2679 # If we're running under Lighttpd, swap PATH_INFO and SCRIPT_NAME
2680 # http://lists.scsys.co.uk/pipermail/catalyst/2006-June/008361.html
2681 # Thanks to Mark Blythe for this fix
2682 #
2683 # Note that this has probably the same effect as
2684 # Plack::Middleware::LighttpdScriptNameFix and we should switch to that if
2685 # we can.
2686 $psgi_app = Plack::Middleware::Conditional->wrap(
2687 $psgi_app,
00fa37d0 2688 condition => $server_matches->(qr/lighttpd/),
2689 builder => sub {
d89b863e 2690 my ($to_wrap) = @_;
2691 return sub {
2692 my ($env) = @_;
2693 $env->{PATH_INFO} ||= delete $env->{SCRIPT_NAME};
2694 return $to_wrap->($env);
2695 };
2696 },
d89b863e 2697 );
2698
a6fb59b7 2699 $psgi_app = Plack::Middleware::Conditional->wrap(
2700 $psgi_app,
00fa37d0 2701 condition => $server_matches->(qr/^nginx/),
2702 builder => sub {
a6fb59b7 2703 my ($to_wrap) = @_;
2704 return sub {
2705 my ($env) = @_;
f725259b 2706 my $script_name = $env->{SCRIPT_NAME};
2707 $env->{PATH_INFO} =~ s/^$script_name//g;
2708 return $to_wrap->($env);
2709 };
2710 },
f725259b 2711 );
2712
fb99321f 2713 # we're applying this unconditionally as the middleware itself already makes
2714 # sure it doesn't fuck things up if it's not running under one of the right
2715 # IIS versions
2716 $psgi_app = Plack::Middleware::IIS6ScriptNameFix->wrap($psgi_app);
a6fb59b7 2717
d89b863e 2718 return $psgi_app;
fcffcb05 2719}
2720
8f076801 2721=head2 $c->psgi_app
fcffcb05 2722
2723Returns a PSGI application code reference for the catalyst application
2724C<$c>. This is the bare application without any middlewares
8f076801 2725applied. C<${myapp}.psgi> is not taken into account.
2726
2727This is what you want to be using to retrieve the PSGI application code
2728reference of your Catalyst application for use in F<.psgi> files.
fcffcb05 2729
2730=cut
2731
8f076801 2732sub psgi_app {
fcffcb05 2733 my ($app) = @_;
2734 return $app->engine->build_psgi_app($app);
fbcc39ad 2735}
2736
b5ecfcf0 2737=head2 $c->setup_home
fbcc39ad 2738
ae1e6b59 2739Sets up the home directory.
2740
fbcc39ad 2741=cut
2742
2743sub setup_home {
2744 my ( $class, $home ) = @_;
2745
cb69249e 2746 if ( my $env = Catalyst::Utils::env_value( $class, 'HOME' ) ) {
2747 $home = $env;
fbcc39ad 2748 }
2749
b6d4ee6e 2750 $home ||= Catalyst::Utils::home($class);
fbcc39ad 2751
2752 if ($home) {
e63bdf38 2753 #I remember recently being scolded for assigning config values like this
fbcc39ad 2754 $class->config->{home} ||= $home;
a738ab68 2755 $class->config->{root} ||= Path::Class::Dir->new($home)->subdir('root');
fbcc39ad 2756 }
2757}
2758
b5ecfcf0 2759=head2 $c->setup_log
fbcc39ad 2760
0fa676a7 2761Sets up log by instantiating a L<Catalyst::Log|Catalyst::Log> object and
2762passing it to C<log()>. Pass in a comma-delimited list of levels to set the