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