Fix regex special characters screwing things up by not using regexes
[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
e66329da 81our $VERSION = '5.80016';
4ed63588 82
83{
84 my $dev_version = $VERSION =~ /_\d{2}$/;
85 *_IS_DEVELOPMENT_VERSION = sub () { $dev_version };
86}
87
c3f6d73a 88$VERSION = eval $VERSION;
189e2a51 89
fbcc39ad 90sub import {
91 my ( $class, @arguments ) = @_;
92
93 # We have to limit $class to Catalyst to avoid pushing Catalyst upon every
94 # callers @ISA.
95 return unless $class eq 'Catalyst';
96
84ff88cf 97 my $caller = caller();
98 return if $caller eq 'main';
269408a4 99
100 # Kill Adopt::NEXT warnings if we're a non-RC version
4ed63588 101 unless (_IS_DEVELOPMENT_VERSION()) {
8833fe2c 102 Class::C3::Adopt::NEXT->unimport(qr/^Catalyst::/);
269408a4 103 }
104
84ff88cf 105 my $meta = Moose::Meta::Class->initialize($caller);
fbcc39ad 106 unless ( $caller->isa('Catalyst') ) {
84ff88cf 107 my @superclasses = ($meta->superclasses, $class, 'Catalyst::Controller');
108 $meta->superclasses(@superclasses);
109 }
1cad29ab 110 # Avoid possible C3 issues if 'Moose::Object' is already on RHS of MyApp
111 $meta->superclasses(grep { $_ ne 'Moose::Object' } $meta->superclasses);
112
84ff88cf 113 unless( $meta->has_method('meta') ){
114 $meta->add_method(meta => sub { Moose::Meta::Class->initialize("${caller}") } );
fbcc39ad 115 }
116
117 $caller->arguments( [@arguments] );
118 $caller->setup_home;
119}
fc7ec1d9 120
e6bfaa20 121sub _application { $_[0] }
122
fc7ec1d9 123=head1 NAME
124
125Catalyst - The Elegant MVC Web Application Framework
126
127=head1 SYNOPSIS
128
e7ad3b81 129See the L<Catalyst::Manual> distribution for comprehensive
130documentation and tutorials.
131
86418559 132 # Install Catalyst::Devel for helpers and other development tools
b4b01a8a 133 # use the helper to create a new application
91864987 134 catalyst.pl MyApp
fc7ec1d9 135
136 # add models, views, controllers
2f381252 137 script/myapp_create.pl model MyDatabase DBIC::Schema create=static dbi:SQLite:/path/to/db
cc95842f 138 script/myapp_create.pl view MyTemplate TT
0ef52a96 139 script/myapp_create.pl controller Search
fc7ec1d9 140
e7f1cf73 141 # built in testserver -- use -r to restart automatically on changes
cc95842f 142 # --help to see all available options
ae4e40a7 143 script/myapp_server.pl
fc7ec1d9 144
0ef52a96 145 # command line testing interface
ae4e40a7 146 script/myapp_test.pl /yada
fc7ec1d9 147
b4b01a8a 148 ### in lib/MyApp.pm
0ef52a96 149 use Catalyst qw/-Debug/; # include plugins here as well
62a6df80 150
85d9fce6 151 ### In lib/MyApp/Controller/Root.pm (autocreated)
0ef52a96 152 sub foo : Global { # called for /foo, /foo/1, /foo/1/2, etc.
ae1e6b59 153 my ( $self, $c, @args ) = @_; # args are qw/1 2/ for /foo/1/2
154 $c->stash->{template} = 'foo.tt'; # set the template
0ef52a96 155 # lookup something from db -- stash vars are passed to TT
62a6df80 156 $c->stash->{data} =
b4b01a8a 157 $c->model('Database::Foo')->search( { country => $args[0] } );
0ef52a96 158 if ( $c->req->params->{bar} ) { # access GET or POST parameters
159 $c->forward( 'bar' ); # process another action
62a6df80 160 # do something else after forward returns
0ef52a96 161 }
162 }
62a6df80 163
ae1e6b59 164 # The foo.tt TT template can use the stash data from the database
0ef52a96 165 [% WHILE (item = data.next) %]
166 [% item.foo %]
167 [% END %]
62a6df80 168
0ef52a96 169 # called for /bar/of/soap, /bar/of/soap/10, etc.
170 sub bar : Path('/bar/of/soap') { ... }
fc7ec1d9 171
ae1e6b59 172 # called for all actions, from the top-most controller downwards
62a6df80 173 sub auto : Private {
0ef52a96 174 my ( $self, $c ) = @_;
b4b01a8a 175 if ( !$c->user_exists ) { # Catalyst::Plugin::Authentication
0ef52a96 176 $c->res->redirect( '/login' ); # require login
177 return 0; # abort request and go immediately to end()
178 }
ae1e6b59 179 return 1; # success; carry on to next action
0ef52a96 180 }
62a6df80 181
ae1e6b59 182 # called after all actions are finished
62a6df80 183 sub end : Private {
5a8ed4fe 184 my ( $self, $c ) = @_;
0ef52a96 185 if ( scalar @{ $c->error } ) { ... } # handle errors
186 return if $c->res->body; # already have a response
187 $c->forward( 'MyApp::View::TT' ); # render template
5a8ed4fe 188 }
189
0ef52a96 190 ### in MyApp/Controller/Foo.pm
191 # called for /foo/bar
192 sub bar : Local { ... }
62a6df80 193
5400c668 194 # called for /blargle
195 sub blargle : Global { ... }
62a6df80 196
5400c668 197 # an index action matches /foo, but not /foo/1, etc.
198 sub index : Private { ... }
62a6df80 199
0ef52a96 200 ### in MyApp/Controller/Foo/Bar.pm
201 # called for /foo/bar/baz
202 sub baz : Local { ... }
62a6df80 203
b4b01a8a 204 # first Root auto is called, then Foo auto, then this
0ef52a96 205 sub auto : Private { ... }
62a6df80 206
0ef52a96 207 # powerful regular expression paths are also possible
208 sub details : Regex('^product/(\w+)/details$') {
5a8ed4fe 209 my ( $self, $c ) = @_;
0ef52a96 210 # extract the (\w+) from the URI
2982e768 211 my $product = $c->req->captures->[0];
5a8ed4fe 212 }
fc7ec1d9 213
0ef52a96 214See L<Catalyst::Manual::Intro> for additional information.
3803e98f 215
fc7ec1d9 216=head1 DESCRIPTION
217
86418559 218Catalyst is a modern framework for making web applications without the
219pain usually associated with this process. This document is a reference
220to the main Catalyst application. If you are a new user, we suggest you
221start with L<Catalyst::Manual::Tutorial> or L<Catalyst::Manual::Intro>.
fc7ec1d9 222
223See L<Catalyst::Manual> for more documentation.
224
ae1e6b59 225Catalyst plugins can be loaded by naming them as arguments to the "use
226Catalyst" statement. Omit the C<Catalyst::Plugin::> prefix from the
227plugin name, i.e., C<Catalyst::Plugin::My::Module> becomes
228C<My::Module>.
fc7ec1d9 229
0ef52a96 230 use Catalyst qw/My::Module/;
fc7ec1d9 231
836e1134 232If your plugin starts with a name other than C<Catalyst::Plugin::>, you can
233fully qualify the name by using a unary plus:
234
235 use Catalyst qw/
236 My::Module
237 +Fully::Qualified::Plugin::Name
238 /;
239
ae1e6b59 240Special flags like C<-Debug> and C<-Engine> can also be specified as
241arguments when Catalyst is loaded:
fc7ec1d9 242
243 use Catalyst qw/-Debug My::Module/;
244
ae1e6b59 245The position of plugins and flags in the chain is important, because
86418559 246they are loaded in the order in which they appear.
fc7ec1d9 247
23f9d934 248The following flags are supported:
249
b5ecfcf0 250=head2 -Debug
23f9d934 251
f8ad6ea5 252Enables debug output. You can also force this setting from the system
86418559 253environment with CATALYST_DEBUG or <MYAPP>_DEBUG. The environment
254settings override the application, with <MYAPP>_DEBUG having the highest
255priority.
fc7ec1d9 256
b5ecfcf0 257=head2 -Engine
fc7ec1d9 258
ae1e6b59 259Forces Catalyst to use a specific engine. Omit the
260C<Catalyst::Engine::> prefix of the engine name, i.e.:
fc7ec1d9 261
0ef52a96 262 use Catalyst qw/-Engine=CGI/;
fc7ec1d9 263
b5ecfcf0 264=head2 -Home
fbcc39ad 265
ae1e6b59 266Forces Catalyst to use a specific home directory, e.g.:
267
86418559 268 use Catalyst qw[-Home=/usr/mst];
fbcc39ad 269
cc95842f 270This can also be done in the shell environment by setting either the
271C<CATALYST_HOME> environment variable or C<MYAPP_HOME>; where C<MYAPP>
272is replaced with the uppercased name of your application, any "::" in
273the name will be replaced with underscores, e.g. MyApp::Web should use
274MYAPP_WEB_HOME. If both variables are set, the MYAPP_HOME one will be used.
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');
e112461a 335 $c->forward(qw/MyApp::Model::DBIC::Foo do_stuff/);
0ef52a96 336 $c->forward('MyApp::View::TT');
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');
345 die $c->error if $c->error;
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;
2e60292e 351
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;
357
358in an action that is forwarded to is going to return a scalar,
359i.e. how many items are in that array, which is probably not what you want.
360If you need to return an array then return a reference to it,
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
12c48597 420The relationship between C<go> and
421L<< visit|/"$c->visit( $action [, \@captures, \@arguments ] )" >> is the same as
422the relationship between
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
2e60292e 507Contains the return value of the last executed action.
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.
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
8eae92ad 937Calling C<< $c->debug(1) >> has no effect.
e80e8542 938
af3ff00e 939=cut
940
b4b01a8a 941sub debug { 0 }
942
943=head2 $c->dispatcher
944
2887a7f1 945Returns the dispatcher instance. See L<Catalyst::Dispatcher>.
b4b01a8a 946
947=head2 $c->engine
948
2887a7f1 949Returns the engine instance. See L<Catalyst::Engine>.
b4b01a8a 950
951
f7b672ef 952=head2 UTILITY METHODS
66e28e3f 953
b5ecfcf0 954=head2 $c->path_to(@path)
01033d73 955
cc95842f 956Merges C<@path> with C<< $c->config->{home} >> and returns a
4e392da6 957L<Path::Class::Dir> object. Note you can usually use this object as
958a filename, but sometimes you will have to explicitly stringify it
18a9655c 959yourself by calling the C<< ->stringify >> method.
01033d73 960
961For example:
962
963 $c->path_to( 'db', 'sqlite.db' );
964
965=cut
966
967sub path_to {
968 my ( $c, @path ) = @_;
a738ab68 969 my $path = Path::Class::Dir->new( $c->config->{home}, @path );
01033d73 970 if ( -d $path ) { return $path }
a738ab68 971 else { return Path::Class::File->new( $c->config->{home}, @path ) }
01033d73 972}
973
b5ecfcf0 974=head2 $c->plugin( $name, $class, @args )
0ef52a96 975
10011c19 976Helper method for plugins. It creates a class data accessor/mutator and
ae1e6b59 977loads and instantiates the given class.
0ef52a96 978
979 MyApp->plugin( 'prototype', 'HTML::Prototype' );
980
981 $c->prototype->define_javascript_functions;
4e68badc 982
6b2a933b 983B<Note:> This method of adding plugins is deprecated. The ability
4e68badc 984to add plugins like this B<will be removed> in a Catalyst 5.81.
6b2a933b 985Please do not use this functionality in new code.
0ef52a96 986
987=cut
988
989sub plugin {
990 my ( $class, $name, $plugin, @args ) = @_;
6b2a933b 991
4e68badc 992 # See block comment in t/unit_core_plugin.t
b3542016 993 $class->log->warn(qq/Adding plugin using the ->plugin method is deprecated, and will be removed in Catalyst 5.81/);
4e68badc 994
97b58e17 995 $class->_register_plugin( $plugin, 1 );
0ef52a96 996
997 eval { $plugin->import };
998 $class->mk_classdata($name);
999 my $obj;
1000 eval { $obj = $plugin->new(@args) };
1001
1002 if ($@) {
1003 Catalyst::Exception->throw( message =>
1004 qq/Couldn't instantiate instant plugin "$plugin", "$@"/ );
1005 }
1006
1007 $class->$name($obj);
1008 $class->log->debug(qq/Initialized instant plugin "$plugin" as "$name"/)
1009 if $class->debug;
1010}
1011
b5ecfcf0 1012=head2 MyApp->setup
fbcc39ad 1013
e7f1cf73 1014Initializes the dispatcher and engine, loads any plugins, and loads the
ae1e6b59 1015model, view, and controller components. You may also specify an array
1016of plugins to load here, if you choose to not load them in the C<use
1017Catalyst> line.
fbcc39ad 1018
0ef52a96 1019 MyApp->setup;
1020 MyApp->setup( qw/-Debug/ );
fbcc39ad 1021
1022=cut
1023
1024sub setup {
0319a12c 1025 my ( $class, @arguments ) = @_;
c2f3cc1b 1026 croak('Running setup more than once')
1027 if ( $class->setup_finished );
5168a5fc 1028
fbcc39ad 1029 unless ( $class->isa('Catalyst') ) {
953b0e15 1030
fbcc39ad 1031 Catalyst::Exception->throw(
1032 message => qq/'$class' does not inherit from Catalyst/ );
1c99e125 1033 }
0319a12c 1034
fbcc39ad 1035 if ( $class->arguments ) {
1036 @arguments = ( @arguments, @{ $class->arguments } );
1037 }
1038
1039 # Process options
1040 my $flags = {};
1041
1042 foreach (@arguments) {
1043
1044 if (/^-Debug$/) {
1045 $flags->{log} =
1046 ( $flags->{log} ) ? 'debug,' . $flags->{log} : 'debug';
1047 }
1048 elsif (/^-(\w+)=?(.*)$/) {
1049 $flags->{ lc $1 } = $2;
1050 }
1051 else {
1052 push @{ $flags->{plugins} }, $_;
1053 }
1054 }
1055
99f187d6 1056 $class->setup_home( delete $flags->{home} );
1057
fbcc39ad 1058 $class->setup_log( delete $flags->{log} );
1059 $class->setup_plugins( delete $flags->{plugins} );
1060 $class->setup_dispatcher( delete $flags->{dispatcher} );
1061 $class->setup_engine( delete $flags->{engine} );
dc5f035e 1062 $class->setup_stats( delete $flags->{stats} );
fbcc39ad 1063
1064 for my $flag ( sort keys %{$flags} ) {
1065
1066 if ( my $code = $class->can( 'setup_' . $flag ) ) {
1067 &$code( $class, delete $flags->{$flag} );
1068 }
1069 else {
1070 $class->log->warn(qq/Unknown flag "$flag"/);
1071 }
1072 }
1073
0eb4af72 1074 eval { require Catalyst::Devel; };
1075 if( !$@ && $ENV{CATALYST_SCRIPT_GEN} && ( $ENV{CATALYST_SCRIPT_GEN} < $Catalyst::Devel::CATALYST_SCRIPT_GEN ) ) {
1076 $class->log->warn(<<"EOF");
4ff0d824 1077You are running an old script!
1078
34a83d89 1079 Please update by running (this will overwrite existing files):
1080 catalyst.pl -force -scripts $class
1081
1082 or (this will not overwrite existing files):
1083 catalyst.pl -scripts $class
1cf0345b 1084
4ff0d824 1085EOF
0eb4af72 1086 }
62a6df80 1087
fbcc39ad 1088 if ( $class->debug ) {
6601f2ad 1089 my @plugins = map { "$_ " . ( $_->VERSION || '' ) } $class->registered_plugins;
fbcc39ad 1090
1091 if (@plugins) {
39fc2ce1 1092 my $column_width = Catalyst::Utils::term_width() - 6;
1093 my $t = Text::SimpleTable->new($column_width);
8c113188 1094 $t->row($_) for @plugins;
1cf0345b 1095 $class->log->debug( "Loaded plugins:\n" . $t->draw . "\n" );
fbcc39ad 1096 }
1097
1098 my $dispatcher = $class->dispatcher;
1099 my $engine = $class->engine;
1100 my $home = $class->config->{home};
1101
01ce7075 1102 $class->log->debug(sprintf(q/Loaded dispatcher "%s"/, blessed($dispatcher)));
1103 $class->log->debug(sprintf(q/Loaded engine "%s"/, blessed($engine)));
fbcc39ad 1104
1105 $home
1106 ? ( -d $home )
1107 ? $class->log->debug(qq/Found home "$home"/)
1108 : $class->log->debug(qq/Home "$home" doesn't exist/)
1109 : $class->log->debug(q/Couldn't find home/);
1110 }
1111
54f4bfef 1112 # Call plugins setup, this is stupid and evil.
16b7c476 1113 # Also screws C3 badly on 5.10, hack to avoid.
fbcc39ad 1114 {
1115 no warnings qw/redefine/;
1116 local *setup = sub { };
16b7c476 1117 $class->setup unless $Catalyst::__AM_RESTARTING;
fbcc39ad 1118 }
1119
1120 # Initialize our data structure
1121 $class->components( {} );
1122
1123 $class->setup_components;
1124
1125 if ( $class->debug ) {
39fc2ce1 1126 my $column_width = Catalyst::Utils::term_width() - 8 - 9;
1127 my $t = Text::SimpleTable->new( [ $column_width, 'Class' ], [ 8, 'Type' ] );
684d10ed 1128 for my $comp ( sort keys %{ $class->components } ) {
1129 my $type = ref $class->components->{$comp} ? 'instance' : 'class';
1130 $t->row( $comp, $type );
1131 }
1cf0345b 1132 $class->log->debug( "Loaded components:\n" . $t->draw . "\n" )
8c113188 1133 if ( keys %{ $class->components } );
fbcc39ad 1134 }
1135
1136 # Add our self to components, since we are also a component
96d8d513 1137 if( $class->isa('Catalyst::Controller') ){
1138 $class->components->{$class} = $class;
1139 }
fbcc39ad 1140
1141 $class->setup_actions;
1142
1143 if ( $class->debug ) {
1144 my $name = $class->config->{name} || 'Application';
1145 $class->log->info("$name powered by Catalyst $Catalyst::VERSION");
1146 }
3643e890 1147
62a6df80 1148 # Make sure that the application class becomes immutable at this point,
acca8cd5 1149 B::Hooks::EndOfScope::on_scope_end {
df861f8e 1150 return if $@;
e106a59f 1151 my $meta = Class::MOP::get_metaclass_by_name($class);
4ffa3785 1152 if (
1153 $meta->is_immutable
1154 && ! { $meta->immutable_options }->{replace_constructor}
1155 && (
1156 $class->isa('Class::Accessor::Fast')
1157 || $class->isa('Class::Accessor')
1158 )
1159 ) {
81ef9afd 1160 warn "You made your application class ($class) immutable, "
4ffa3785 1161 . "but did not inline the\nconstructor. "
1162 . "This will break catalyst, as your app \@ISA "
1163 . "Class::Accessor(::Fast)?\nPlease pass "
1164 . "(replace_constructor => 1)\nwhen making your class immutable.\n";
6e5505d4 1165 }
83b8cda1 1166 $meta->make_immutable(
1167 replace_constructor => 1,
83b8cda1 1168 ) unless $meta->is_immutable;
acca8cd5 1169 };
3d041c32 1170
647a3de1 1171 if ($class->config->{case_sensitive}) {
1172 $class->log->warn($class . "->config->{case_sensitive} is set.");
1173 $class->log->warn("This setting is deprecated and planned to be removed in Catalyst 5.81.");
1174 }
1175
a5d07d29 1176 $class->setup_finalize;
647a3de1 1177 # Should be the last thing we do so that user things hooking
1178 # setup_finalize can log..
1179 $class->log->_flush() if $class->log->can('_flush');
64ceb36b 1180 return 1; # Explicit return true as people have __PACKAGE__->setup as the last thing in their class. HATE.
a5d07d29 1181}
1182
23c63a17 1183
1184=head2 $app->setup_finalize
1185
1186A hook to attach modifiers to.
4bc471c9 1187Using C<< after setup => sub{}; >> doesn't work, because of quirky things done for plugin setup.
23c63a17 1188Also better than C< setup_finished(); >, as that is a getter method.
1189
1190 sub setup_finalize {
1191
1192 my $app = shift;
1193
1194 ## do stuff, i.e., determine a primary key column for sessions stored in a DB
1195
1196 $app->next::method(@_);
1197
1198
1199 }
1200
1201=cut
1202
a5d07d29 1203sub setup_finalize {
1204 my ($class) = @_;
3643e890 1205 $class->setup_finished(1);
fbcc39ad 1206}
1207
d71da6fe 1208=head2 $c->uri_for( $path?, @args?, \%query_values? )
fbcc39ad 1209
ee8963de 1210=head2 $c->uri_for( $action, \@captures?, @args?, \%query_values? )
9df7c5d9 1211
ee8963de 1212Constructs an absolute L<URI> object based on the application root, the
1213provided path, and the additional arguments and query parameters provided.
1214When used as a string, provides a textual URI.
1215
d71da6fe 1216If no arguments are provided, the URI for the current action is returned.
1217To return the current action and also provide @args, use
9c48a04e 1218C<< $c->uri_for( $c->action, @args ) >>.
d71da6fe 1219
ee8963de 1220If the first argument is a string, it is taken as a public URI path relative
1221to C<< $c->namespace >> (if it doesn't begin with a forward slash) or
e7e4c469 1222relative to the application root (if it does). It is then merged with
ee8963de 1223C<< $c->request->base >>; any C<@args> are appended as additional path
1224components; and any C<%query_values> are appended as C<?foo=bar> parameters.
1225
1226If the first argument is a L<Catalyst::Action> it represents an action which
1227will have its path resolved using C<< $c->dispatcher->uri_for_action >>. The
1228optional C<\@captures> argument (an arrayref) allows passing the captured
1229variables that are needed to fill in the paths of Chained and Regex actions;
1230once the path is resolved, C<uri_for> continues as though a path was
1231provided, appending any arguments or parameters and creating an absolute
1232URI.
1233
e7e4c469 1234The captures for the current request can be found in
ee8963de 1235C<< $c->request->captures >>, and actions can be resolved using
1236C<< Catalyst::Controller->action_for($name) >>. If you have a private action
1237path, use C<< $c->uri_for_action >> instead.
1238
1239 # Equivalent to $c->req->uri
e7e4c469 1240 $c->uri_for($c->action, $c->req->captures,
ee8963de 1241 @{ $c->req->args }, $c->req->params);
62a6df80 1242
9df7c5d9 1243 # For the Foo action in the Bar controller
ee8963de 1244 $c->uri_for($c->controller('Bar')->action_for('Foo'));
9df7c5d9 1245
ee8963de 1246 # Path to a static resource
1247 $c->uri_for('/static/images/logo.png');
d5e3d528 1248
4cf1dd00 1249=cut
1250
fbcc39ad 1251sub uri_for {
00e6a2b7 1252 my ( $c, $path, @args ) = @_;
00e6a2b7 1253
7069eab5 1254 if (blessed($path) && $path->isa('Catalyst::Controller')) {
1255 $path = $path->path_prefix;
1256 $path =~ s{/+\z}{};
1257 $path .= '/';
1258 }
1259
7e95ba12 1260 if ( blessed($path) ) { # action object
36c67dc1 1261 my $captures = [ map { s|/|%2F|; $_; }
aaf72276 1262 ( scalar @args && ref $args[0] eq 'ARRAY'
1263 ? @{ shift(@args) }
1264 : ()) ];
aa7e913e 1265 my $action = $path;
1266 $path = $c->dispatcher->uri_for_action($action, $captures);
1267 if (not defined $path) {
1268 $c->log->debug(qq/Can't find uri_for action '$action' @$captures/)
1269 if $c->debug;
1270 return undef;
1271 }
81e75875 1272 $path = '/' if $path eq '';
ea0e58d9 1273 }
1274
51674a63 1275 undef($path) if (defined $path && $path eq '');
00e6a2b7 1276
97b58e17 1277 my $params =
1278 ( scalar @args && ref $args[$#args] eq 'HASH' ? pop @args : {} );
8327e2e2 1279
cbb93105 1280 carp "uri_for called with undef argument" if grep { ! defined $_ } @args;
f9155483 1281 s/([^$URI::uric])/$URI::Escape::escapes{$1}/go for @args;
36c67dc1 1282 s|/|%2F| for @args;
51674a63 1283
1284 unshift(@args, $path);
1285
1286 unless (defined $path && $path =~ s!^/!!) { # in-place strip
1287 my $namespace = $c->namespace;
1288 if (defined $path) { # cheesy hack to handle path '../foo'
1289 $namespace =~ s{(?:^|/)[^/]+$}{} while $args[0] =~ s{^\.\./}{};
6601f2ad 1290 }
51674a63 1291 unshift(@args, $namespace || '');
1292 }
62a6df80 1293
189e2a51 1294 # join args with '/', or a blank string
51674a63 1295 my $args = join('/', grep { defined($_) } @args);
1296 $args =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
7a2295bc 1297 $args =~ s!^/+!!;
51674a63 1298 my $base = $c->req->base;
1299 my $class = ref($base);
1300 $base =~ s{(?<!/)$}{/};
1301
1302 my $query = '';
1303
1304 if (my @keys = keys %$params) {
1305 # somewhat lifted from URI::_query's query_form
1306 $query = '?'.join('&', map {
2f381252 1307 my $val = $params->{$_};
51674a63 1308 s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/go;
1309 s/ /+/g;
1310 my $key = $_;
51674a63 1311 $val = '' unless defined $val;
1312 (map {
1f851263 1313 my $param = "$_";
1314 utf8::encode( $param ) if utf8::is_utf8($param);
51674a63 1315 # using the URI::Escape pattern here so utf8 chars survive
1f851263 1316 $param =~ s/([^A-Za-z0-9\-_.!~*'() ])/$URI::Escape::escapes{$1}/go;
1317 $param =~ s/ /+/g;
1318 "${key}=$param"; } ( ref $val eq 'ARRAY' ? @$val : $val ));
51674a63 1319 } @keys);
1320 }
1321
1322 my $res = bless(\"${base}${args}${query}", $class);
d3e7a648 1323 $res;
fbcc39ad 1324}
1325
833b385e 1326=head2 $c->uri_for_action( $path, \@captures?, @args?, \%query_values? )
1327
1328=head2 $c->uri_for_action( $action, \@captures?, @args?, \%query_values? )
1329
1330=over
1331
1332=item $path
1333
1334A private path to the Catalyst action you want to create a URI for.
1335
1336This is a shortcut for calling C<< $c->dispatcher->get_action_by_path($path)
1337>> and passing the resulting C<$action> and the remaining arguments to C<<
1338$c->uri_for >>.
1339
1340You can also pass in a Catalyst::Action object, in which case it is passed to
1341C<< $c->uri_for >>.
1342
1343=back
1344
1345=cut
1346
1347sub uri_for_action {
1348 my ( $c, $path, @args ) = @_;
62a6df80 1349 my $action = blessed($path)
1350 ? $path
833b385e 1351 : $c->dispatcher->get_action_by_path($path);
4ac0b9cb 1352 unless (defined $action) {
1353 croak "Can't find action for path '$path'";
1354 }
833b385e 1355 return $c->uri_for( $action, @args );
1356}
1357
b5ecfcf0 1358=head2 $c->welcome_message
ab2374d3 1359
1360Returns the Catalyst welcome HTML page.
1361
1362=cut
1363
1364sub welcome_message {
bf1f2c60 1365 my $c = shift;
1366 my $name = $c->config->{name};
1367 my $logo = $c->uri_for('/static/images/catalyst_logo.png');
1368 my $prefix = Catalyst::Utils::appprefix( ref $c );
80cdbbff 1369 $c->response->content_type('text/html; charset=utf-8');
ab2374d3 1370 return <<"EOF";
80cdbbff 1371<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1372 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1373<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
ab2374d3 1374 <head>
85d9fce6 1375 <meta http-equiv="Content-Language" content="en" />
1376 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
ab2374d3 1377 <title>$name on Catalyst $VERSION</title>
1378 <style type="text/css">
1379 body {
ab2374d3 1380 color: #000;
1381 background-color: #eee;
1382 }
1383 div#content {
1384 width: 640px;
80cdbbff 1385 margin-left: auto;
1386 margin-right: auto;
ab2374d3 1387 margin-top: 10px;
1388 margin-bottom: 10px;
1389 text-align: left;
1390 background-color: #ccc;
1391 border: 1px solid #aaa;
ab2374d3 1392 }
d84c4dab 1393 p, h1, h2 {
ab2374d3 1394 margin-left: 20px;
1395 margin-right: 20px;
16215972 1396 font-family: verdana, tahoma, sans-serif;
ab2374d3 1397 }
d84c4dab 1398 a {
1399 font-family: verdana, tahoma, sans-serif;
1400 }
d114e033 1401 :link, :visited {
1402 text-decoration: none;
1403 color: #b00;
1404 border-bottom: 1px dotted #bbb;
1405 }
1406 :link:hover, :visited:hover {
d114e033 1407 color: #555;
1408 }
ab2374d3 1409 div#topbar {
1410 margin: 0px;
1411 }
3e82a295 1412 pre {
3e82a295 1413 margin: 10px;
1414 padding: 8px;
1415 }
ab2374d3 1416 div#answers {
1417 padding: 8px;
1418 margin: 10px;
d114e033 1419 background-color: #fff;
ab2374d3 1420 border: 1px solid #aaa;
ab2374d3 1421 }
1422 h1 {
33108eaf 1423 font-size: 0.9em;
1424 font-weight: normal;
ab2374d3 1425 text-align: center;
1426 }
1427 h2 {
1428 font-size: 1.0em;
1429 }
1430 p {
1431 font-size: 0.9em;
1432 }
ae7c5252 1433 p img {
1434 float: right;
1435 margin-left: 10px;
1436 }
9619f23c 1437 span#appname {
1438 font-weight: bold;
33108eaf 1439 font-size: 1.6em;
ab2374d3 1440 }
1441 </style>
1442 </head>
1443 <body>
1444 <div id="content">
1445 <div id="topbar">
9619f23c 1446 <h1><span id="appname">$name</span> on <a href="http://catalyst.perl.org">Catalyst</a>
d84c4dab 1447 $VERSION</h1>
ab2374d3 1448 </div>
1449 <div id="answers">
ae7c5252 1450 <p>
80cdbbff 1451 <img src="$logo" alt="Catalyst Logo" />
ae7c5252 1452 </p>
596aaffe 1453 <p>Welcome to the world of Catalyst.
f92fd545 1454 This <a href="http://en.wikipedia.org/wiki/MVC">MVC</a>
1455 framework will make web development something you had
60dd6e1d 1456 never expected it to be: Fun, rewarding, and quick.</p>
ab2374d3 1457 <h2>What to do now?</h2>
4b8cb778 1458 <p>That really depends on what <b>you</b> want to do.
ab2374d3 1459 We do, however, provide you with a few starting points.</p>
1460 <p>If you want to jump right into web development with Catalyst
2f381252 1461 you might want to start with a tutorial.</p>
b607f8a0 1462<pre>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Tutorial.pod">Catalyst::Manual::Tutorial</a></code>
596aaffe 1463</pre>
1464<p>Afterwards you can go on to check out a more complete look at our features.</p>
1465<pre>
b607f8a0 1466<code>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Intro.pod">Catalyst::Manual::Intro</a>
1467<!-- Something else should go here, but the Catalyst::Manual link seems unhelpful -->
1468</code></pre>
ab2374d3 1469 <h2>What to do next?</h2>
f5681c92 1470 <p>Next it's time to write an actual application. Use the
80cdbbff 1471 helper scripts to generate <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AController%3A%3A&amp;mode=all">controllers</a>,
60dd6e1d 1472 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AModel%3A%3A&amp;mode=all">models</a>, and
1473 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AView%3A%3A&amp;mode=all">views</a>;
bf1f2c60 1474 they can save you a lot of work.</p>
1475 <pre><code>script/${prefix}_create.pl -help</code></pre>
1476 <p>Also, be sure to check out the vast and growing
802bf2cb 1477 collection of <a href="http://search.cpan.org/search?query=Catalyst">plugins for Catalyst on CPAN</a>;
bf1f2c60 1478 you are likely to find what you need there.
f5681c92 1479 </p>
1480
82245cc4 1481 <h2>Need help?</h2>
f5681c92 1482 <p>Catalyst has a very active community. Here are the main places to
1483 get in touch with us.</p>
16215972 1484 <ul>
1485 <li>
2b9a7d76 1486 <a href="http://dev.catalyst.perl.org">Wiki</a>
16215972 1487 </li>
1488 <li>
6d4c3368 1489 <a href="http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst">Mailing-List</a>
16215972 1490 </li>
1491 <li>
4eaf7c88 1492 <a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
16215972 1493 </li>
1494 </ul>
ab2374d3 1495 <h2>In conclusion</h2>
62a6df80 1496 <p>The Catalyst team hopes you will enjoy using Catalyst as much
f5681c92 1497 as we enjoyed making it. Please contact us if you have ideas
1498 for improvement or other feedback.</p>
ab2374d3 1499 </div>
1500 </div>
1501 </body>
1502</html>
1503EOF
1504}
1505
fbcc39ad 1506=head1 INTERNAL METHODS
1507
ae1e6b59 1508These methods are not meant to be used by end users.
1509
b5ecfcf0 1510=head2 $c->components
fbcc39ad 1511
e7f1cf73 1512Returns a hash of components.
fbcc39ad 1513
b5ecfcf0 1514=head2 $c->context_class
1f9cb7c1 1515
e7f1cf73 1516Returns or sets the context class.
1f9cb7c1 1517
b5ecfcf0 1518=head2 $c->counter
fbcc39ad 1519
ae1e6b59 1520Returns a hashref containing coderefs and execution counts (needed for
1521deep recursion detection).
fbcc39ad 1522
b5ecfcf0 1523=head2 $c->depth
fbcc39ad 1524
e7f1cf73 1525Returns the number of actions on the current internal execution stack.
fbcc39ad 1526
b5ecfcf0 1527=head2 $c->dispatch
fbcc39ad 1528
e7f1cf73 1529Dispatches a request to actions.
fbcc39ad 1530
1531=cut
1532
1533sub dispatch { my $c = shift; $c->dispatcher->dispatch( $c, @_ ) }
1534
b5ecfcf0 1535=head2 $c->dispatcher_class
1f9cb7c1 1536
e7f1cf73 1537Returns or sets the dispatcher class.
1f9cb7c1 1538
b5ecfcf0 1539=head2 $c->dump_these
7f92deef 1540
ae1e6b59 1541Returns a list of 2-element array references (name, structure) pairs
1542that will be dumped on the error page in debug mode.
7f92deef 1543
1544=cut
1545
1546sub dump_these {
1547 my $c = shift;
62a6df80 1548 [ Request => $c->req ],
1549 [ Response => $c->res ],
052a2d89 1550 [ Stash => $c->stash ],
1551 [ Config => $c->config ];
7f92deef 1552}
1553
b5ecfcf0 1554=head2 $c->engine_class
1f9cb7c1 1555
e7f1cf73 1556Returns or sets the engine class.
1f9cb7c1 1557
b5ecfcf0 1558=head2 $c->execute( $class, $coderef )
fbcc39ad 1559
0ef52a96 1560Execute a coderef in given class and catch exceptions. Errors are available
1561via $c->error.
fbcc39ad 1562
1563=cut
1564
1565sub execute {
1566 my ( $c, $class, $code ) = @_;
858828dd 1567 $class = $c->component($class) || $class;
fbcc39ad 1568 $c->state(0);
a0eca838 1569
197bd788 1570 if ( $c->depth >= $RECURSION ) {
f3414019 1571 my $action = $code->reverse();
91d08727 1572 $action = "/$action" unless $action =~ /->/;
f3414019 1573 my $error = qq/Deep recursion detected calling "${action}"/;
1627551a 1574 $c->log->error($error);
1575 $c->error($error);
1576 $c->state(0);
1577 return $c->state;
1578 }
1579
dc5f035e 1580 my $stats_info = $c->_stats_start_execute( $code ) if $c->use_stats;
22247e54 1581
8767c5a3 1582 push( @{ $c->stack }, $code );
62a6df80 1583
6f3df815 1584 no warnings 'recursion';
f3414019 1585 eval { $c->state( $code->execute( $class, $c, @{ $c->req->args } ) || 0 ) };
22247e54 1586
dc5f035e 1587 $c->_stats_finish_execute( $stats_info ) if $c->use_stats and $stats_info;
62a6df80 1588
a6724a82 1589 my $last = pop( @{ $c->stack } );
fbcc39ad 1590
1591 if ( my $error = $@ ) {
79f5d571 1592 if ( blessed($error) and $error->isa('Catalyst::Exception::Detach') ) {
f87b7c21 1593 $error->rethrow if $c->depth > 1;
2f381252 1594 }
79f5d571 1595 elsif ( blessed($error) and $error->isa('Catalyst::Exception::Go') ) {
f87b7c21 1596 $error->rethrow if $c->depth > 0;
55424863 1597 }
fbcc39ad 1598 else {
1599 unless ( ref $error ) {
91d08727 1600 no warnings 'uninitialized';
fbcc39ad 1601 chomp $error;
f59def82 1602 my $class = $last->class;
1603 my $name = $last->name;
1604 $error = qq/Caught exception in $class->$name "$error"/;
fbcc39ad 1605 }
fbcc39ad 1606 $c->error($error);
1607 $c->state(0);
1608 }
1609 }
1610 return $c->state;
1611}
1612
7a7d7af5 1613sub _stats_start_execute {
1614 my ( $c, $code ) = @_;
df960201 1615 my $appclass = ref($c) || $c;
a6724a82 1616 return if ( ( $code->name =~ /^_.*/ )
df960201 1617 && ( !$appclass->config->{show_internal_actions} ) );
7a7d7af5 1618
f3414019 1619 my $action_name = $code->reverse();
1620 $c->counter->{$action_name}++;
7a7d7af5 1621
f3414019 1622 my $action = $action_name;
a6724a82 1623 $action = "/$action" unless $action =~ /->/;
1624
7a7d7af5 1625 # determine if the call was the result of a forward
1626 # this is done by walking up the call stack and looking for a calling
1627 # sub of Catalyst::forward before the eval
1628 my $callsub = q{};
1629 for my $index ( 2 .. 11 ) {
1630 last
1631 if ( ( caller($index) )[0] eq 'Catalyst'
1632 && ( caller($index) )[3] eq '(eval)' );
1633
1634 if ( ( caller($index) )[3] =~ /forward$/ ) {
1635 $callsub = ( caller($index) )[3];
1636 $action = "-> $action";
1637 last;
1638 }
1639 }
1640
f3414019 1641 my $uid = $action_name . $c->counter->{$action_name};
74efc144 1642
a6724a82 1643 # is this a root-level call or a forwarded call?
1644 if ( $callsub =~ /forward$/ ) {
91740f34 1645 my $parent = $c->stack->[-1];
a6724a82 1646
1647 # forward, locate the caller
91740f34 1648 if ( exists $c->counter->{"$parent"} ) {
69d8f33c 1649 $c->stats->profile(
62a6df80 1650 begin => $action,
69d8f33c 1651 parent => "$parent" . $c->counter->{"$parent"},
1652 uid => $uid,
1653 );
7a7d7af5 1654 }
1655 else {
1656
a6724a82 1657 # forward with no caller may come from a plugin
69d8f33c 1658 $c->stats->profile(
1659 begin => $action,
1660 uid => $uid,
1661 );
7a7d7af5 1662 }
1663 }
a6724a82 1664 else {
62a6df80 1665
a6724a82 1666 # root-level call
69d8f33c 1667 $c->stats->profile(
1668 begin => $action,
1669 uid => $uid,
1670 );
a6724a82 1671 }
dc5f035e 1672 return $action;
7a7d7af5 1673
7a7d7af5 1674}
1675
1676sub _stats_finish_execute {
1677 my ( $c, $info ) = @_;
69d8f33c 1678 $c->stats->profile( end => $info );
7a7d7af5 1679}
1680
b5ecfcf0 1681=head2 $c->finalize
fbcc39ad 1682
e7f1cf73 1683Finalizes the request.
fbcc39ad 1684
1685=cut
1686
1687sub finalize {
1688 my $c = shift;
1689
369c09bc 1690 for my $error ( @{ $c->error } ) {
1691 $c->log->error($error);
1692 }
1693
5050d7a7 1694 # Allow engine to handle finalize flow (for POE)
e63bdf38 1695 my $engine = $c->engine;
1696 if ( my $code = $engine->can('finalize') ) {
1697 $engine->$code($c);
fbcc39ad 1698 }
5050d7a7 1699 else {
fbcc39ad 1700
5050d7a7 1701 $c->finalize_uploads;
fbcc39ad 1702
5050d7a7 1703 # Error
1704 if ( $#{ $c->error } >= 0 ) {
1705 $c->finalize_error;
1706 }
1707
1708 $c->finalize_headers;
fbcc39ad 1709
5050d7a7 1710 # HEAD request
1711 if ( $c->request->method eq 'HEAD' ) {
1712 $c->response->body('');
1713 }
1714
1715 $c->finalize_body;
1716 }
62a6df80 1717
1718 if ($c->use_stats) {
596677b6 1719 my $elapsed = sprintf '%f', $c->stats->elapsed;
12bf12c0 1720 my $av = $elapsed == 0 ? '??' : sprintf '%.3f', 1 / $elapsed;
908e3d9e 1721 $c->log->info(
62a6df80 1722 "Request took ${elapsed}s ($av/s)\n" . $c->stats->report . "\n" );
908e3d9e 1723 }
fbcc39ad 1724
1725 return $c->response->status;
1726}
1727
b5ecfcf0 1728=head2 $c->finalize_body
fbcc39ad 1729
e7f1cf73 1730Finalizes body.
fbcc39ad 1731
1732=cut
1733
1734sub finalize_body { my $c = shift; $c->engine->finalize_body( $c, @_ ) }
1735
b5ecfcf0 1736=head2 $c->finalize_cookies
fbcc39ad 1737
e7f1cf73 1738Finalizes cookies.
fbcc39ad 1739
1740=cut
1741
147821ea 1742sub finalize_cookies { my $c = shift; $c->engine->finalize_cookies( $c, @_ ) }
fbcc39ad 1743
b5ecfcf0 1744=head2 $c->finalize_error
fbcc39ad 1745
e7f1cf73 1746Finalizes error.
fbcc39ad 1747
1748=cut
1749
1750sub finalize_error { my $c = shift; $c->engine->finalize_error( $c, @_ ) }
1751
b5ecfcf0 1752=head2 $c->finalize_headers
fbcc39ad 1753
e7f1cf73 1754Finalizes headers.
fbcc39ad 1755
1756=cut
1757
1758sub finalize_headers {
1759 my $c = shift;
1760
e63bdf38 1761 my $response = $c->response; #accessor calls can add up?
1762
fbcc39ad 1763 # Check if we already finalized headers
6680c772 1764 return if $response->finalized_headers;
fbcc39ad 1765
1766 # Handle redirects
e63bdf38 1767 if ( my $location = $response->redirect ) {
fbcc39ad 1768 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
e63bdf38 1769 $response->header( Location => $location );
a7caa492 1770
02570318 1771 if ( !$response->has_body ) {
39655cdc 1772 # Add a default body if none is already present
e63bdf38 1773 $response->body(
e422816e 1774 qq{<html><body><p>This item has moved <a href="$location">here</a>.</p></body></html>}
39655cdc 1775 );
1776 }
fbcc39ad 1777 }
1778
1779 # Content-Length
e63bdf38 1780 if ( $response->body && !$response->content_length ) {
775878ac 1781
8f62c91a 1782 # get the length from a filehandle
e63bdf38 1783 if ( blessed( $response->body ) && $response->body->can('read') )
197bd788 1784 {
e63bdf38 1785 my $stat = stat $response->body;
3b6a1db1 1786 if ( $stat && $stat->size > 0 ) {
e63bdf38 1787 $response->content_length( $stat->size );
8f62c91a 1788 }
1789 else {
775878ac 1790 $c->log->warn('Serving filehandle without a content-length');
8f62c91a 1791 }
1792 }
1793 else {
b5d7a61f 1794 # everything should be bytes at this point, but just in case
5ab21903 1795 $response->content_length( length( $response->body ) );
8f62c91a 1796 }
fbcc39ad 1797 }
1798
1799 # Errors
e63bdf38 1800 if ( $response->status =~ /^(1\d\d|[23]04)$/ ) {
1801 $response->headers->remove_header("Content-Length");
1802 $response->body('');
fbcc39ad 1803 }
1804
1805 $c->finalize_cookies;
1806
1807 $c->engine->finalize_headers( $c, @_ );
1808
1809 # Done
6680c772 1810 $response->finalized_headers(1);
fbcc39ad 1811}
1812
b5ecfcf0 1813=head2 $c->finalize_output
fbcc39ad 1814
1815An alias for finalize_body.
1816
b5ecfcf0 1817=head2 $c->finalize_read
fbcc39ad 1818
e7f1cf73 1819Finalizes the input after reading is complete.
fbcc39ad 1820
1821=cut
1822
1823sub finalize_read { my $c = shift; $c->engine->finalize_read( $c, @_ ) }
1824
b5ecfcf0 1825=head2 $c->finalize_uploads
fbcc39ad 1826
ae1e6b59 1827Finalizes uploads. Cleans up any temporary files.
fbcc39ad 1828
1829=cut
1830
1831sub finalize_uploads { my $c = shift; $c->engine->finalize_uploads( $c, @_ ) }
1832
b5ecfcf0 1833=head2 $c->get_action( $action, $namespace )
fbcc39ad 1834
e7f1cf73 1835Gets an action in a given namespace.
fbcc39ad 1836
1837=cut
1838
684d10ed 1839sub get_action { my $c = shift; $c->dispatcher->get_action(@_) }
fbcc39ad 1840
b5ecfcf0 1841=head2 $c->get_actions( $action, $namespace )
a9dc674c 1842
ae1e6b59 1843Gets all actions of a given name in a namespace and all parent
1844namespaces.
a9dc674c 1845
1846=cut
1847
1848sub get_actions { my $c = shift; $c->dispatcher->get_actions( $c, @_ ) }
1849
f7b672ef 1850=head2 $c->handle_request( $class, @arguments )
fbcc39ad 1851
e7f1cf73 1852Called to handle each HTTP request.
fbcc39ad 1853
1854=cut
1855
1856sub handle_request {
1857 my ( $class, @arguments ) = @_;
1858
1859 # Always expect worst case!
1860 my $status = -1;
1861 eval {
dea1884f 1862 if ($class->debug) {
908e3d9e 1863 my $secs = time - $START || 1;
1864 my $av = sprintf '%.3f', $COUNT / $secs;
1865 my $time = localtime time;
1866 $class->log->info("*** Request $COUNT ($av/s) [$$] [$time] ***");
dea1884f 1867 }
908e3d9e 1868
1869 my $c = $class->prepare(@arguments);
1870 $c->dispatch;
62a6df80 1871 $status = $c->finalize;
fbcc39ad 1872 };
1873
1874 if ( my $error = $@ ) {
1875 chomp $error;
1876 $class->log->error(qq/Caught exception in engine "$error"/);
1877 }
1878
1879 $COUNT++;
62a6df80 1880
6680c772 1881 if(my $coderef = $class->log->can('_flush')){
1882 $class->log->$coderef();
1883 }
fbcc39ad 1884 return $status;
1885}
1886
b5ecfcf0 1887=head2 $c->prepare( @arguments )
fbcc39ad 1888
ae1e6b59 1889Creates a Catalyst context from an engine-specific request (Apache, CGI,
1890etc.).
fbcc39ad 1891
1892=cut
1893
1894sub prepare {
1895 my ( $class, @arguments ) = @_;
1896
6680c772 1897 # XXX
1898 # After the app/ctxt split, this should become an attribute based on something passed
1899 # into the application.
3cec521a 1900 $class->context_class( ref $class || $class ) unless $class->context_class;
62a6df80 1901
6680c772 1902 my $c = $class->context_class->new({});
1903
1904 # For on-demand data
1905 $c->request->_context($c);
1906 $c->response->_context($c);
fbcc39ad 1907
b6d4ee6e 1908 #surely this is not the most efficient way to do things...
dc5f035e 1909 $c->stats($class->stats_class->new)->enable($c->use_stats);
908e3d9e 1910 if ( $c->debug ) {
62a6df80 1911 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
908e3d9e 1912 }
1913
e63bdf38 1914 #XXX reuse coderef from can
5050d7a7 1915 # Allow engine to direct the prepare flow (for POE)
1916 if ( $c->engine->can('prepare') ) {
1917 $c->engine->prepare( $c, @arguments );
1918 }
1919 else {
1920 $c->prepare_request(@arguments);
1921 $c->prepare_connection;
1922 $c->prepare_query_parameters;
1923 $c->prepare_headers;
1924 $c->prepare_cookies;
1925 $c->prepare_path;
1926
878b821c 1927 # Prepare the body for reading, either by prepare_body
1928 # or the user, if they are using $c->read
1929 $c->prepare_read;
62a6df80 1930
878b821c 1931 # Parse the body unless the user wants it on-demand
df960201 1932 unless ( ref($c)->config->{parse_on_demand} ) {
878b821c 1933 $c->prepare_body;
1934 }
5050d7a7 1935 }
fbcc39ad 1936
fbcc39ad 1937 my $method = $c->req->method || '';
2f381252 1938 my $path = $c->req->path;
1939 $path = '/' unless length $path;
fbcc39ad 1940 my $address = $c->req->address || '';
1941
e3a13771 1942 $c->log->debug(qq/"$method" request for "$path" from "$address"/)
fbcc39ad 1943 if $c->debug;
1944
e3a13771 1945 $c->prepare_action;
1946
fbcc39ad 1947 return $c;
1948}
1949
b5ecfcf0 1950=head2 $c->prepare_action
fbcc39ad 1951
b4b01a8a 1952Prepares action. See L<Catalyst::Dispatcher>.
fbcc39ad 1953
1954=cut
1955
1956sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
1957
b5ecfcf0 1958=head2 $c->prepare_body
fbcc39ad 1959
e7f1cf73 1960Prepares message body.
fbcc39ad 1961
1962=cut
1963
1964sub prepare_body {
1965 my $c = shift;
1966
0f56bbcf 1967 return if $c->request->_has_body;
fbcc39ad 1968
1969 # Initialize on-demand data
1970 $c->engine->prepare_body( $c, @_ );
1971 $c->prepare_parameters;
1972 $c->prepare_uploads;
1973
0584323b 1974 if ( $c->debug && keys %{ $c->req->body_parameters } ) {
1975 my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ 36, 'Value' ] );
1976 for my $key ( sort keys %{ $c->req->body_parameters } ) {
1977 my $param = $c->req->body_parameters->{$key};
1978 my $value = defined($param) ? $param : '';
1979 $t->row( $key,
1980 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1981 }
1982 $c->log->debug( "Body Parameters are:\n" . $t->draw );
fbcc39ad 1983 }
1984}
1985
b5ecfcf0 1986=head2 $c->prepare_body_chunk( $chunk )
4bd82c41 1987
e7f1cf73 1988Prepares a chunk of data before sending it to L<HTTP::Body>.
4bd82c41 1989
b4b01a8a 1990See L<Catalyst::Engine>.
1991
4bd82c41 1992=cut
1993
4f5ebacd 1994sub prepare_body_chunk {
1995 my $c = shift;
4bd82c41 1996 $c->engine->prepare_body_chunk( $c, @_ );
1997}
1998
b5ecfcf0 1999=head2 $c->prepare_body_parameters
fbcc39ad 2000
e7f1cf73 2001Prepares body parameters.
fbcc39ad 2002
2003=cut
2004
2005sub prepare_body_parameters {
2006 my $c = shift;
2007 $c->engine->prepare_body_parameters( $c, @_ );
2008}
2009
b5ecfcf0 2010=head2 $c->prepare_connection
fbcc39ad 2011
e7f1cf73 2012Prepares connection.
fbcc39ad 2013
2014=cut
2015
2016sub prepare_connection {
2017 my $c = shift;
2018 $c->engine->prepare_connection( $c, @_ );
2019}
2020
b5ecfcf0 2021=head2 $c->prepare_cookies
fbcc39ad 2022
e7f1cf73 2023Prepares cookies.
fbcc39ad 2024
2025=cut
2026
2027sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
2028
b5ecfcf0 2029=head2 $c->prepare_headers
fbcc39ad 2030
e7f1cf73 2031Prepares headers.
fbcc39ad 2032
2033=cut
2034
2035sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
2036
b5ecfcf0 2037=head2 $c->prepare_parameters
fbcc39ad 2038
e7f1cf73 2039Prepares parameters.
fbcc39ad 2040
2041=cut
2042
2043sub prepare_parameters {
2044 my $c = shift;
2045 $c->prepare_body_parameters;
2046 $c->engine->prepare_parameters( $c, @_ );
2047}
2048
b5ecfcf0 2049=head2 $c->prepare_path
fbcc39ad 2050
e7f1cf73 2051Prepares path and base.
fbcc39ad 2052
2053=cut
2054
2055sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
2056
b5ecfcf0 2057=head2 $c->prepare_query_parameters
fbcc39ad 2058
e7f1cf73 2059Prepares query parameters.
fbcc39ad 2060
2061=cut
2062
2063sub prepare_query_parameters {
2064 my $c = shift;
2065
2066 $c->engine->prepare_query_parameters( $c, @_ );
2067
0584323b 2068 if ( $c->debug && keys %{ $c->request->query_parameters } ) {
2069 my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ 36, 'Value' ] );
2070 for my $key ( sort keys %{ $c->req->query_parameters } ) {
2071 my $param = $c->req->query_parameters->{$key};
fbcc39ad 2072 my $value = defined($param) ? $param : '';
8c113188 2073 $t->row( $key,
fbcc39ad 2074 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
2075 }
0584323b 2076 $c->log->debug( "Query Parameters are:\n" . $t->draw );
fbcc39ad 2077 }
2078}
2079
b5ecfcf0 2080=head2 $c->prepare_read
fbcc39ad 2081
e7f1cf73 2082Prepares the input for reading.
fbcc39ad 2083
2084=cut
2085
2086sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
2087
b5ecfcf0 2088=head2 $c->prepare_request
fbcc39ad 2089
e7f1cf73 2090Prepares the engine request.
fbcc39ad 2091
2092=cut
2093
2094sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
2095
b5ecfcf0 2096=head2 $c->prepare_uploads
fbcc39ad 2097
e7f1cf73 2098Prepares uploads.
fbcc39ad 2099
2100=cut
2101
2102sub prepare_uploads {
2103 my $c = shift;
2104
2105 $c->engine->prepare_uploads( $c, @_ );
2106
2107 if ( $c->debug && keys %{ $c->request->uploads } ) {
8c113188 2108 my $t = Text::SimpleTable->new(
34d28dfd 2109 [ 12, 'Parameter' ],
2110 [ 26, 'Filename' ],
8c113188 2111 [ 18, 'Type' ],
2112 [ 9, 'Size' ]
2113 );
fbcc39ad 2114 for my $key ( sort keys %{ $c->request->uploads } ) {
2115 my $upload = $c->request->uploads->{$key};
2116 for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
8c113188 2117 $t->row( $key, $u->filename, $u->type, $u->size );
fbcc39ad 2118 }
2119 }
2120 $c->log->debug( "File Uploads are:\n" . $t->draw );
2121 }
2122}
2123
b5ecfcf0 2124=head2 $c->prepare_write
fbcc39ad 2125
e7f1cf73 2126Prepares the output for writing.
fbcc39ad 2127
2128=cut
2129
2130sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
2131
b5ecfcf0 2132=head2 $c->request_class
1f9cb7c1 2133
e7f1cf73 2134Returns or sets the request class.
1f9cb7c1 2135
b5ecfcf0 2136=head2 $c->response_class
1f9cb7c1 2137
e7f1cf73 2138Returns or sets the response class.
1f9cb7c1 2139
b5ecfcf0 2140=head2 $c->read( [$maxlength] )
fbcc39ad 2141
ae1e6b59 2142Reads a chunk of data from the request body. This method is designed to
2143be used in a while loop, reading C<$maxlength> bytes on every call.
2144C<$maxlength> defaults to the size of the request if not specified.
fbcc39ad 2145
4600a5a1 2146You have to set C<< MyApp->config(parse_on_demand => 1) >> to use this
ae1e6b59 2147directly.
fbcc39ad 2148
878b821c 2149Warning: If you use read(), Catalyst will not process the body,
2150so you will not be able to access POST parameters or file uploads via
2151$c->request. You must handle all body parsing yourself.
2152
fbcc39ad 2153=cut
2154
2155sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
2156
b5ecfcf0 2157=head2 $c->run
fbcc39ad 2158
2159Starts the engine.
2160
2161=cut
2162
2163sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
2164
b5ecfcf0 2165=head2 $c->set_action( $action, $code, $namespace, $attrs )
fbcc39ad 2166
e7f1cf73 2167Sets an action in a given namespace.
fbcc39ad 2168
2169=cut
2170
2171sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
2172
b5ecfcf0 2173=head2 $c->setup_actions($component)
fbcc39ad 2174
e7f1cf73 2175Sets up actions for a component.
fbcc39ad 2176
2177=cut
2178
2179sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
2180
b5ecfcf0 2181=head2 $c->setup_components
fbcc39ad 2182
d261d153 2183This method is called internally to set up the application's components.
fbcc39ad 2184
d261d153 2185It finds modules by calling the L<locate_components> method, expands them to
2186package names with the L<expand_component_module> method, and then installs
2187each component into the application.
2188
2189The C<setup_components> config option is passed to both of the above methods.
fbcc39ad 2190
d261d153 2191Installation of each component is performed by the L<setup_component> method,
2192below.
2f381252 2193
fbcc39ad 2194=cut
2195
2196sub setup_components {
2197 my $class = shift;
2198
18de900e 2199 my $config = $class->config->{ setup_components };
62a6df80 2200
d261d153 2201 my @comps = sort { length $a <=> length $b }
2202 $class->locate_components($config);
b94b200c 2203 my %comps = map { $_ => 1 } @comps;
73e1183e 2204
8f6cebb2 2205 my $deprecatedcatalyst_component_names = grep { /::[CMV]::/ } @comps;
73e1183e 2206 $class->log->warn(qq{Your application is using the deprecated ::[MVC]:: type naming scheme.\n}.
2207 qq{Please switch your class names to ::Model::, ::View:: and ::Controller: as appropriate.\n}
8f6cebb2 2208 ) if $deprecatedcatalyst_component_names;
73e1183e 2209
b94b200c 2210 for my $component ( @comps ) {
dd91afb5 2211
2212 # We pass ignore_loaded here so that overlay files for (e.g.)
2213 # Model::DBI::Schema sub-classes are loaded - if it's in @comps
2214 # we know M::P::O found a file on disk so this is safe
2215
f5a4863c 2216 Catalyst::Utils::ensure_class_loaded( $component, { ignore_loaded => 1 } );
62a6df80 2217
196f06d1 2218 # Needs to be done as soon as the component is loaded, as loading a sub-component
2219 # (next time round the loop) can cause us to get the wrong metaclass..
2220 $class->_controller_init_base_classes($component);
2221 }
2222
e7e4c469 2223 for my $component (@comps) {
196f06d1 2224 $class->components->{ $component } = $class->setup_component($component);
e7e4c469 2225 for my $component ($class->expand_component_module( $component, $config )) {
05887b58 2226 next if $comps{$component};
e7e4c469 2227 $class->_controller_init_base_classes($component); # Also cover inner packages
2228 $class->components->{ $component } = $class->setup_component($component);
fbcc39ad 2229 }
364d7324 2230 }
2231}
fbcc39ad 2232
d261d153 2233=head2 $c->locate_components( $setup_component_config )
2234
2235This method is meant to provide a list of component modules that should be
2236setup for the application. By default, it will use L<Module::Pluggable>.
2237
2238Specify a C<setup_components> config option to pass additional options directly
2239to L<Module::Pluggable>. To add additional search paths, specify a key named
2240C<search_extra> as an array reference. Items in the array beginning with C<::>
2241will have the application class name prepended to them.
2242
2243=cut
2244
2245sub locate_components {
2246 my $class = shift;
2247 my $config = shift;
2248
2249 my @paths = qw( ::Controller ::C ::Model ::M ::View ::V );
2250 my $extra = delete $config->{ search_extra } || [];
2251
2252 push @paths, @$extra;
2253
2254 my $locator = Module::Pluggable::Object->new(
2255 search_path => [ map { s/^(?=::)/$class/; $_; } @paths ],
2256 %$config
2257 );
2258
2259 my @comps = $locator->plugins;
2260
2261 return @comps;
2262}
2263
2264=head2 $c->expand_component_module( $component, $setup_component_config )
2265
2266Components found by C<locate_components> will be passed to this method, which
2267is expected to return a list of component (package) names to be set up.
2268
d261d153 2269=cut
2270
2271sub expand_component_module {
2272 my ($class, $module) = @_;
05887b58 2273 return Devel::InnerPackage::list_packages( $module );
d261d153 2274}
2275
364d7324 2276=head2 $c->setup_component
fbcc39ad 2277
364d7324 2278=cut
fbcc39ad 2279
196f06d1 2280# FIXME - Ugly, ugly hack to ensure the we force initialize non-moose base classes
2281# nearest to Catalyst::Controller first, no matter what order stuff happens
2282# to be loaded. There are TODO tests in Moose for this, see
2283# f2391d17574eff81d911b97be15ea51080500003
2f5cb070 2284sub _controller_init_base_classes {
84848664 2285 my ($app_class, $component) = @_;
196f06d1 2286 return unless $component->isa('Catalyst::Controller');
2f5cb070 2287 foreach my $class ( reverse @{ mro::get_linear_isa($component) } ) {
c98492ae 2288 Moose::Meta::Class->initialize( $class )
2f5cb070 2289 unless find_meta($class);
2290 }
2291}
2292
364d7324 2293sub setup_component {
2294 my( $class, $component ) = @_;
fbcc39ad 2295
364d7324 2296 unless ( $component->can( 'COMPONENT' ) ) {
2297 return $component;
2298 }
fbcc39ad 2299
364d7324 2300 my $suffix = Catalyst::Utils::class2classsuffix( $component );
2301 my $config = $class->config->{ $suffix } || {};
8f6cebb2 2302 # Stash catalyst_component_name in the config here, so that custom COMPONENT
d2598ac8 2303 # methods also pass it. local to avoid pointlessly shitting in config
2304 # for the debug screen, as $component is already the key name.
8f6cebb2 2305 local $config->{catalyst_component_name} = $component;
fbcc39ad 2306
364d7324 2307 my $instance = eval { $component->COMPONENT( $class, $config ); };
fbcc39ad 2308
2309 if ( my $error = $@ ) {
fbcc39ad 2310 chomp $error;
fbcc39ad 2311 Catalyst::Exception->throw(
364d7324 2312 message => qq/Couldn't instantiate component "$component", "$error"/
2313 );
fbcc39ad 2314 }
2315
7490de2a 2316 unless (blessed $instance) {
2317 my $metaclass = Moose::Util::find_meta($component);
2318 my $method_meta = $metaclass->find_method_by_name('COMPONENT');
2319 my $component_method_from = $method_meta->associated_metaclass->name;
637fa644 2320 my $value = defined($instance) ? $instance : 'undef';
7490de2a 2321 Catalyst::Exception->throw(
2322 message =>
637fa644 2323 qq/Couldn't instantiate component "$component", COMPONENT() method (from $component_method_from) didn't return an object-like value (value was $value)./
7490de2a 2324 );
2325 }
364d7324 2326 return $instance;
fbcc39ad 2327}
2328
b5ecfcf0 2329=head2 $c->setup_dispatcher
fbcc39ad 2330
ae1e6b59 2331Sets up dispatcher.
2332
fbcc39ad 2333=cut
2334
2335sub setup_dispatcher {
2336 my ( $class, $dispatcher ) = @_;
2337
2338 if ($dispatcher) {
2339 $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
2340 }
2341
cb69249e 2342 if ( my $env = Catalyst::Utils::env_value( $class, 'DISPATCHER' ) ) {
2343 $dispatcher = 'Catalyst::Dispatcher::' . $env;
fbcc39ad 2344 }
2345
2346 unless ($dispatcher) {
cb0354c6 2347 $dispatcher = $class->dispatcher_class;
fbcc39ad 2348 }
2349
e63bdf38 2350 Class::MOP::load_class($dispatcher);
fbcc39ad 2351
2352 # dispatcher instance
2353 $class->dispatcher( $dispatcher->new );
2354}
2355
b5ecfcf0 2356=head2 $c->setup_engine
fbcc39ad 2357
ae1e6b59 2358Sets up engine.
2359
fbcc39ad 2360=cut
2361
2362sub setup_engine {
2363 my ( $class, $engine ) = @_;
2364
2365 if ($engine) {
2366 $engine = 'Catalyst::Engine::' . $engine;
2367 }
2368
cb69249e 2369 if ( my $env = Catalyst::Utils::env_value( $class, 'ENGINE' ) ) {
2370 $engine = 'Catalyst::Engine::' . $env;
fbcc39ad 2371 }
2372
9b0a3e0f 2373 if ( $ENV{MOD_PERL} ) {
e106a59f 2374 my $meta = Class::MOP::get_metaclass_by_name($class);
62a6df80 2375
fbcc39ad 2376 # create the apache method
74c89dea 2377 $meta->add_method('apache' => sub { shift->engine->apache });
fbcc39ad 2378
2379 my ( $software, $version ) =
2380 $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
2381
2382 $version =~ s/_//g;
2383 $version =~ s/(\.[^.]+)\./$1/g;
2384
2385 if ( $software eq 'mod_perl' ) {
2386
9b0a3e0f 2387 if ( !$engine ) {
22247e54 2388
9b0a3e0f 2389 if ( $version >= 1.99922 ) {
2390 $engine = 'Catalyst::Engine::Apache2::MP20';
2391 }
22247e54 2392
9b0a3e0f 2393 elsif ( $version >= 1.9901 ) {
2394 $engine = 'Catalyst::Engine::Apache2::MP19';
2395 }
22247e54 2396
9b0a3e0f 2397 elsif ( $version >= 1.24 ) {
2398 $engine = 'Catalyst::Engine::Apache::MP13';
2399 }
22247e54 2400
9b0a3e0f 2401 else {
2402 Catalyst::Exception->throw( message =>
2403 qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
2404 }
fbcc39ad 2405
fbcc39ad 2406 }
2407
2408 # install the correct mod_perl handler
2409 if ( $version >= 1.9901 ) {
2410 *handler = sub : method {
2411 shift->handle_request(@_);
2412 };
2413 }
2414 else {
2415 *handler = sub ($$) { shift->handle_request(@_) };
2416 }
2417
2418 }
2419
2420 elsif ( $software eq 'Zeus-Perl' ) {
2421 $engine = 'Catalyst::Engine::Zeus';
2422 }
2423
2424 else {
2425 Catalyst::Exception->throw(
2426 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
2427 }
2428 }
2429
2430 unless ($engine) {
cb0354c6 2431 $engine = $class->engine_class;
fbcc39ad 2432 }
2433
e63bdf38 2434 Class::MOP::load_class($engine);
0e7f5826 2435
d54484bf 2436 # check for old engines that are no longer compatible
2437 my $old_engine;
0e7f5826 2438 if ( $engine->isa('Catalyst::Engine::Apache')
2439 && !Catalyst::Engine::Apache->VERSION )
d54484bf 2440 {
2441 $old_engine = 1;
2442 }
0e7f5826 2443
d54484bf 2444 elsif ( $engine->isa('Catalyst::Engine::Server::Base')
0e7f5826 2445 && Catalyst::Engine::Server->VERSION le '0.02' )
d54484bf 2446 {
2447 $old_engine = 1;
2448 }
0e7f5826 2449
2450 elsif ($engine->isa('Catalyst::Engine::HTTP::POE')
2451 && $engine->VERSION eq '0.01' )
d54484bf 2452 {
2453 $old_engine = 1;
2454 }
0e7f5826 2455
2456 elsif ($engine->isa('Catalyst::Engine::Zeus')
2457 && $engine->VERSION eq '0.01' )
d54484bf 2458 {
2459 $old_engine = 1;
2460 }
fbcc39ad 2461
d54484bf 2462 if ($old_engine) {
2463 Catalyst::Exception->throw( message =>
0e7f5826 2464 qq/Engine "$engine" is not supported by this version of Catalyst/
d54484bf 2465 );
2466 }
0e7f5826 2467
fbcc39ad 2468 # engine instance
2469 $class->engine( $engine->new );
2470}
2471
b5ecfcf0 2472=head2 $c->setup_home
fbcc39ad 2473
ae1e6b59 2474Sets up the home directory.
2475
fbcc39ad 2476=cut
2477
2478sub setup_home {
2479 my ( $class, $home ) = @_;
2480
cb69249e 2481 if ( my $env = Catalyst::Utils::env_value( $class, 'HOME' ) ) {
2482 $home = $env;
fbcc39ad 2483 }
2484
b6d4ee6e 2485 $home ||= Catalyst::Utils::home($class);
fbcc39ad 2486
2487 if ($home) {
e63bdf38 2488 #I remember recently being scolded for assigning config values like this
fbcc39ad 2489 $class->config->{home} ||= $home;
a738ab68 2490 $class->config->{root} ||= Path::Class::Dir->new($home)->subdir('root');
fbcc39ad 2491 }
2492}
2493
b5ecfcf0 2494=head2 $c->setup_log
fbcc39ad 2495
0fa676a7 2496Sets up log by instantiating a L<Catalyst::Log|Catalyst::Log> object and
2497passing it to C<log()>. Pass in a comma-delimited list of levels to set the
2498log to.
62a6df80 2499
0fa676a7 2500This method also installs a C<debug> method that returns a true value into the
2501catalyst subclass if the "debug" level is passed in the comma-delimited list,
2502or if the C<$CATALYST_DEBUG> environment variable is set to a true value.
2503
2504Note that if the log has already been setup, by either a previous call to
2505C<setup_log> or by a call such as C<< __PACKAGE__->log( MyLogger->new ) >>,
5baa3bbc 2506that this method won't actually set up the log object.
ae1e6b59 2507
fbcc39ad 2508=cut
2509
2510sub setup_log {
0fa676a7 2511 my ( $class, $levels ) = @_;
fbcc39ad 2512
5baa3bbc 2513 $levels ||= '';
2514 $levels =~ s/^\s+//;
2515 $levels =~ s/\s+$//;
abf65c2a 2516 my %levels = map { $_ => 1 } split /\s*,\s*/, $levels;
2517
2518 my $env_debug = Catalyst::Utils::env_value( $class, 'DEBUG' );
2519 if ( defined $env_debug ) {
2520 $levels{debug} = 1 if $env_debug; # Ugly!
2521 delete($levels{debug}) unless $env_debug;
2522 }
2523
fbcc39ad 2524 unless ( $class->log ) {
0fa676a7 2525 $class->log( Catalyst::Log->new(keys %levels) );
fbcc39ad 2526 }
af3ff00e 2527
abf65c2a 2528 if ( $levels{debug} ) {
e106a59f 2529 Class::MOP::get_metaclass_by_name($class)->add_method('debug' => sub { 1 });
fbcc39ad 2530 $class->log->debug('Debug messages enabled');
2531 }
2532}
2533
b5ecfcf0 2534=head2 $c->setup_plugins
fbcc39ad 2535
ae1e6b59 2536Sets up plugins.
2537
fbcc39ad 2538=cut
2539
dc5f035e 2540=head2 $c->setup_stats
2541
2542Sets up timing statistics class.
2543
2544=cut
2545
2546sub setup_stats {
2547 my ( $class, $stats ) = @_;
2548
2549 Catalyst::Utils::ensure_class_loaded($class->stats_class);
2550
2551 my $env = Catalyst::Utils::env_value( $class, 'STATS' );
2552 if ( defined($env) ? $env : ($stats || $class->debug ) ) {
e106a59f 2553 Class::MOP::get_metaclass_by_name($class)->add_method('use_stats' => sub { 1 });
b01f0c69 2554 $class->log->debug('Statistics enabled');
dc5f035e 2555 }
2556}
2557
2558
62a6df80 2559=head2 $c->registered_plugins
836e1134 2560
2561Returns a sorted list of the plugins which have either been stated in the
2562import list or which have been added via C<< MyApp->plugin(@args); >>.
2563
2564If passed a given plugin name, it will report a boolean value indicating
2565whether or not that plugin is loaded. A fully qualified name is required if
2566the plugin name does not begin with C<Catalyst::Plugin::>.
2567
2568 if ($c->registered_plugins('Some::Plugin')) {
2569 ...
2570 }
2571
2572=cut
fbcc39ad 2573
836e1134 2574{
97b58e17 2575
2576 sub registered_plugins {
836e1134 2577 my $proto = shift;
197bd788 2578 return sort keys %{ $proto->_plugins } unless @_;
836e1134 2579 my $plugin = shift;
d0d4d785 2580 return 1 if exists $proto->_plugins->{$plugin};
2581 return exists $proto->_plugins->{"Catalyst::Plugin::$plugin"};
836e1134 2582 }
fbcc39ad 2583
836e1134 2584 sub _register_plugin {
2585 my ( $proto, $plugin, $instant ) = @_;
2586 my $class = ref $proto || $proto;
fbcc39ad 2587
b6d4ee6e 2588 Class::MOP::load_class( $plugin );
c4efaa54 2589 $class->log->warn( "$plugin inherits from 'Catalyst::Component' - this is decated and will not work in 5.81" )
2590 if $plugin->isa( 'Catalyst::Component' );
197bd788 2591 $proto->_plugins->{$plugin} = 1;
836e1134 2592 unless ($instant) {
fbcc39ad 2593 no strict 'refs';
e106a59f 2594 if ( my $meta = Class::MOP::get_metaclass_by_name($class) ) {
74c89dea 2595 my @superclasses = ($plugin, $meta->superclasses );
2596 $meta->superclasses(@superclasses);
5fb67d52 2597 } else {
2598 unshift @{"$class\::ISA"}, $plugin;
2599 }
fbcc39ad 2600 }
836e1134 2601 return $class;
2602 }
2603
2604 sub setup_plugins {
2605 my ( $class, $plugins ) = @_;
2606
d0d4d785 2607 $class->_plugins( {} ) unless $class->_plugins;
836e1134 2608 $plugins ||= [];
836e1134 2609
5d8129e9 2610 my @plugins = Catalyst::Utils::resolve_namespace($class . '::Plugin', 'Catalyst::Plugin', @$plugins);
b0ad47c1 2611
e5210a95 2612 for my $plugin ( reverse @plugins ) {
2938f7a0 2613 Class::MOP::load_class($plugin);
e5210a95 2614 my $meta = find_meta($plugin);
2615 next if $meta && $meta->isa('Moose::Meta::Role');
836e1134 2616
2617 $class->_register_plugin($plugin);
2618 }
e5210a95 2619
2620 my @roles =
2621 map { $_->name }
2622 grep { $_ && blessed($_) && $_->isa('Moose::Meta::Role') }
2623 map { find_meta($_) }
2624 @plugins;
b0ad47c1 2625
e5210a95 2626 Moose::Util::apply_all_roles(
2627 $class => @roles
2628 ) if @roles;
fbcc39ad 2629 }
2630}
2631
b5ecfcf0 2632=head2 $c->stack
8767c5a3 2633
86418559 2634Returns an arrayref of the internal execution stack (actions that are
2635currently executing).
8767c5a3 2636
dc5f035e 2637=head2 $c->stats_class
2638
2639Returns or sets the stats (timing statistics) class.
2640
2641=head2 $c->use_stats
2642
2643Returns 1 when stats collection is enabled. Stats collection is enabled
2644when the -Stats options is set, debug is on or when the <MYAPP>_STATS
2645environment variable is set.
2646
8eae92ad 2647Note that this is a static method, not an accessor and should be overridden
2648by declaring C<sub use_stats { 1 }> in your MyApp.pm, not by calling C<< $c->use_stats(1) >>.
dc5f035e 2649
2650=cut
2651
2652sub use_stats { 0 }
2653
2654
b5ecfcf0 2655=head2 $c->write( $data )
fbcc39ad 2656
ae1e6b59 2657Writes $data to the output stream. When using this method directly, you
2658will need to manually set the C<Content-Length> header to the length of
2659your output data, if known.
fbcc39ad 2660
2661=cut
2662
4f5ebacd 2663sub write {
2664 my $c = shift;
2665
2666 # Finalize headers if someone manually writes output
2667 $c->finalize_headers;
2668
2669 return $c->engine->write( $c, @_ );
2670}
fbcc39ad 2671
b5ecfcf0 2672=head2 version
bf88a181 2673
ae1e6b59 2674Returns the Catalyst version number. Mostly useful for "powered by"
2675messages in template systems.
bf88a181 2676
2677=cut
2678
2679sub version { return $Catalyst::VERSION }
2680
432390bc 2681=head1 CONFIGURATION
2682
220f4575 2683There are a number of 'base' config variables which can be set:
2684
2685=over
2686
2687=item *
2688
30079544 2689C<default_model> - The default model picked if you say C<< $c->model >>. See L<< /$c->model($name) >>.
220f4575 2690
2691=item *
2692
37c2f09c 2693C<default_view> - The default view to be rendered or returned when C<< $c->view >> is called. See L<< /$c->view($name) >>.
220f4575 2694
2695=item *
2696
2697C<disable_component_resolution_regex_fallback> - Turns
2698off the deprecated component resolution functionality so
2699that if any of the component methods (e.g. C<< $c->controller('Foo') >>)
2700are called then regex search will not be attempted on string values and
2701instead C<undef> will be returned.
2702
2703=item *
2704
2705C<home> - The application home directory. In an uninstalled application,
2706this is the top level application directory. In an installed application,
2707this will be the directory containing C<< MyApp.pm >>.
2708
2709=item *
2710
2711C<ignore_frontend_proxy> - See L</PROXY SUPPORT>
2712
2713=item *
2714
2715C<name> - The name of the application in debug messages and the debug and
2716welcome screens
2717
2718=item *
2719
2720C<parse_on_demand> - The request body (for example file uploads) will not be parsed
2721until it is accessed. This allows you to (for example) check authentication (and reject
2722the upload) before actually recieving all the data. See L</ON-DEMAND PARSER>
2723
2724=item *
2725
2726C<root> - The root directory for templates. Usually this is just a
2727subdirectory of the home directory, but you can set it to change the
2728templates to a different directory.
2729
2730=item *
2731
2732C<search_extra> - Array reference passed to Module::Pluggable to for additional
2733namespaces from which components will be loaded (and constructed and stored in
2734C<< $c->components >>).
2735
2736=item *
2737
2738C<show_internal_actions> - If true, causes internal actions such as C<< _DISPATCH >>
2739to be shown in hit debug tables in the test server.
2740
2741=item *
2742
2743C<using_frontend_proxy> - See L</PROXY SUPPORT>.
2744
2745=back
432390bc 2746
b0bb11ec 2747=head1 INTERNAL ACTIONS
2748
ae1e6b59 2749Catalyst uses internal actions like C<_DISPATCH>, C<_BEGIN>, C<_AUTO>,
2750C<_ACTION>, and C<_END>. These are by default not shown in the private
3e705254 2751action table, but you can make them visible with a config parameter.
b0bb11ec 2752
4600a5a1 2753 MyApp->config(show_internal_actions => 1);
b0bb11ec 2754
fbcc39ad 2755=head1 ON-DEMAND PARSER
2756
2757The request body is usually parsed at the beginning of a request,
878b821c 2758but if you want to handle input yourself, you can enable on-demand
2759parsing with a config parameter.
fbcc39ad 2760
4600a5a1 2761 MyApp->config(parse_on_demand => 1);
62a6df80 2762
fbcc39ad 2763=head1 PROXY SUPPORT
2764
ae1e6b59 2765Many production servers operate using the common double-server approach,
2766with a lightweight frontend web server passing requests to a larger
2767backend server. An application running on the backend server must deal
2768with two problems: the remote user always appears to be C<127.0.0.1> and
2769the server's hostname will appear to be C<localhost> regardless of the
2770virtual host that the user connected through.
fbcc39ad 2771
ae1e6b59 2772Catalyst will automatically detect this situation when you are running
2773the frontend and backend servers on the same machine. The following
2774changes are made to the request.
fbcc39ad 2775
62a6df80 2776 $c->req->address is set to the user's real IP address, as read from
ae1e6b59 2777 the HTTP X-Forwarded-For header.
62a6df80 2778
ae1e6b59 2779 The host value for $c->req->base and $c->req->uri is set to the real
2780 host, as read from the HTTP X-Forwarded-Host header.