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