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