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