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