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