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