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