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