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