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