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