Changelog
[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
d5c5d96f 81our $VERSION = '5.80021';
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
2bf54936 1746 $c->log_response;
10f204e1 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->log_request
2088
2089Writes information about the request to the debug logs. This includes:
2090
2091=over 4
2092
854e5dcd 2093=item * Request method, path, and remote IP address
10f204e1 2094
e7cbe1bf 2095=item * Request headers (see L</log_headers>)
2096
10f204e1 2097=item * Query keywords (see L<Catalyst::Request/query_keywords>)
2098
e7cbe1bf 2099=item * Request parameters
10f204e1 2100
2101=item * File uploads
2102
2103=back
fbcc39ad 2104
2105=cut
2106
10f204e1 2107sub log_request {
2108 my $c = shift;
fbcc39ad 2109
10f204e1 2110 return unless $c->debug;
fbcc39ad 2111
2bf54936 2112 my($dump) = grep {$_->[0] eq 'Request' } $c->dump_these;
2113 my $request = $dump->[1];
e7cbe1bf 2114
2115 my ( $method, $path, $address ) = ( $request->method, $request->path, $request->address );
10f204e1 2116 $method ||= '';
2117 $path = '/' unless length $path;
2118 $address ||= '';
2119 $c->log->debug(qq/"$method" request for "$path" from "$address"/);
2120
e7cbe1bf 2121 $c->log_headers('request', $request->headers);
2122
2123 if ( my $keywords = $request->query_keywords ) {
10f204e1 2124 $c->log->debug("Query keywords are: $keywords");
2125 }
2126
e7cbe1bf 2127 $c->log_request_parameters( query => $request->query_parameters, body => $request->body_parameters );
10f204e1 2128
e7cbe1bf 2129 $c->log_request_uploads($request);
10f204e1 2130}
2131
2132=head2 $c->log_response
2133
2134Writes information about the response to the debug logs. This includes:
2135
2136=over 4
2137
2138=item * Response status code
2139
2140=item * Response headers (see L</log_headers>)
2141
2142=back
2143
fbcc39ad 2144=cut
2145
10f204e1 2146sub log_response {
fbcc39ad 2147 my $c = shift;
2148
e7cbe1bf 2149 return unless $c->debug;
2150
2bf54936 2151 my($dump) = grep {$_->[0] eq 'Response' } $c->dump_these;
2152 my $response = $dump->[1];
10f204e1 2153
47c65f37 2154 $c->log->debug(
2155 sprintf(
2156 'Response Code: %s; Content-Type: %s; Content-Length: %s',
2157 $response->status || 'unknown',
2158 $response->headers->header('Content-Type') || 'unknown',
2159 $response->headers->header('Content-Length') || 'unknown'
2160 )
2161 );
10f204e1 2162}
2163
2164=head2 $c->log_request_parameters( query => {}, body => {} )
2165
2166Logs request parameters to debug logs
2167
10f204e1 2168=cut
2169
2170sub log_request_parameters {
2171 my $c = shift;
2172 my %all_params = @_;
2173
2bf54936 2174 return unless $c->debug;
e7cbe1bf 2175
10f204e1 2176 my $column_width = Catalyst::Utils::term_width() - 44;
2177 foreach my $type (qw(query body)) {
2bf54936 2178 my $params = $all_params{$type};
2179 next if ! keys %$params;
10f204e1 2180 my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ $column_width, 'Value' ] );
e7cbe1bf 2181 for my $key ( sort keys %$params ) {
2182 my $param = $params->{$key};
10f204e1 2183 my $value = defined($param) ? $param : '';
2184 $t->row( $key, ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
2185 }
2186 $c->log->debug( ucfirst($type) . " Parameters are:\n" . $t->draw );
2187 }
2188}
2189
2190=head2 $c->log_request_uploads
2191
2192Logs file uploads included in the request to the debug logs.
854e5dcd 2193The parameter name, filename, file type, and file size are all included in
10f204e1 2194the debug logs.
2195
2196=cut
2197
2198sub log_request_uploads {
2199 my $c = shift;
2bf54936 2200 my $request = shift;
e7cbe1bf 2201 return unless $c->debug;
2202 my $uploads = $request->uploads;
10f204e1 2203 if ( keys %$uploads ) {
8c113188 2204 my $t = Text::SimpleTable->new(
34d28dfd 2205 [ 12, 'Parameter' ],
2206 [ 26, 'Filename' ],
8c113188 2207 [ 18, 'Type' ],
2208 [ 9, 'Size' ]
2209 );
10f204e1 2210 for my $key ( sort keys %$uploads ) {
2211 my $upload = $uploads->{$key};
fbcc39ad 2212 for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
8c113188 2213 $t->row( $key, $u->filename, $u->type, $u->size );
fbcc39ad 2214 }
2215 }
2216 $c->log->debug( "File Uploads are:\n" . $t->draw );
2217 }
2218}
2219
10f204e1 2220=head2 $c->log_headers($type => $headers)
2221
e7cbe1bf 2222Logs L<HTTP::Headers> (either request or response) to the debug logs.
10f204e1 2223
2224=cut
2225
2226sub log_headers {
2227 my $c = shift;
2228 my $type = shift;
2229 my $headers = shift; # an HTTP::Headers instance
2230
e7cbe1bf 2231 return unless $c->debug;
10f204e1 2232
2233 my $t = Text::SimpleTable->new( [ 35, 'Header Name' ], [ 40, 'Value' ] );
e7cbe1bf 2234 $headers->scan(
10f204e1 2235 sub {
2236 my ( $name, $value ) = @_;
2237 $t->row( $name, $value );
2238 }
2239 );
2240 $c->log->debug( ucfirst($type) . " Headers:\n" . $t->draw );
2241}
2242
10f204e1 2243
2244=head2 $c->prepare_read
2245
2246Prepares the input for reading.
2247
2248=cut
2249
2250sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
2251
2252=head2 $c->prepare_request
2253
2254Prepares the engine request.
2255
2256=cut
2257
2258sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
2259
2260=head2 $c->prepare_uploads
2261
2262Prepares uploads.
2263
2264=cut
2265
2266sub prepare_uploads {
2267 my $c = shift;
2268
2269 $c->engine->prepare_uploads( $c, @_ );
2270}
2271
b5ecfcf0 2272=head2 $c->prepare_write
fbcc39ad 2273
e7f1cf73 2274Prepares the output for writing.
fbcc39ad 2275
2276=cut
2277
2278sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
2279
b5ecfcf0 2280=head2 $c->request_class
1f9cb7c1 2281
e7f1cf73 2282Returns or sets the request class.
1f9cb7c1 2283
b5ecfcf0 2284=head2 $c->response_class
1f9cb7c1 2285
e7f1cf73 2286Returns or sets the response class.
1f9cb7c1 2287
b5ecfcf0 2288=head2 $c->read( [$maxlength] )
fbcc39ad 2289
ae1e6b59 2290Reads a chunk of data from the request body. This method is designed to
2291be used in a while loop, reading C<$maxlength> bytes on every call.
2292C<$maxlength> defaults to the size of the request if not specified.
fbcc39ad 2293
4600a5a1 2294You have to set C<< MyApp->config(parse_on_demand => 1) >> to use this
ae1e6b59 2295directly.
fbcc39ad 2296
878b821c 2297Warning: If you use read(), Catalyst will not process the body,
2298so you will not be able to access POST parameters or file uploads via
2299$c->request. You must handle all body parsing yourself.
2300
fbcc39ad 2301=cut
2302
2303sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
2304
b5ecfcf0 2305=head2 $c->run
fbcc39ad 2306
2307Starts the engine.
2308
2309=cut
2310
2311sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
2312
b5ecfcf0 2313=head2 $c->set_action( $action, $code, $namespace, $attrs )
fbcc39ad 2314
e7f1cf73 2315Sets an action in a given namespace.
fbcc39ad 2316
2317=cut
2318
2319sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
2320
b5ecfcf0 2321=head2 $c->setup_actions($component)
fbcc39ad 2322
e7f1cf73 2323Sets up actions for a component.
fbcc39ad 2324
2325=cut
2326
2327sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
2328
b5ecfcf0 2329=head2 $c->setup_components
fbcc39ad 2330
d261d153 2331This method is called internally to set up the application's components.
fbcc39ad 2332
d261d153 2333It finds modules by calling the L<locate_components> method, expands them to
2334package names with the L<expand_component_module> method, and then installs
2335each component into the application.
fbcc39ad 2336
d261d153 2337The C<setup_components> config option is passed to both of the above methods.
fbcc39ad 2338
d261d153 2339Installation of each component is performed by the L<setup_component> method,
2340below.
2f381252 2341
fbcc39ad 2342=cut
2343
2344sub setup_components {
2345 my $class = shift;
2346
18de900e 2347 my $config = $class->config->{ setup_components };
b94b200c 2348
d261d153 2349 my @comps = sort { length $a <=> length $b }
2350 $class->locate_components($config);
b94b200c 2351 my %comps = map { $_ => 1 } @comps;
73e1183e 2352
8f6cebb2 2353 my $deprecatedcatalyst_component_names = grep { /::[CMV]::/ } @comps;
73e1183e 2354 $class->log->warn(qq{Your application is using the deprecated ::[MVC]:: type naming scheme.\n}.
2355 qq{Please switch your class names to ::Model::, ::View:: and ::Controller: as appropriate.\n}
8f6cebb2 2356 ) if $deprecatedcatalyst_component_names;
73e1183e 2357
b94b200c 2358 for my $component ( @comps ) {
dd91afb5 2359
2360 # We pass ignore_loaded here so that overlay files for (e.g.)
2361 # Model::DBI::Schema sub-classes are loaded - if it's in @comps
2362 # we know M::P::O found a file on disk so this is safe
2363
f5a4863c 2364 Catalyst::Utils::ensure_class_loaded( $component, { ignore_loaded => 1 } );
62a6df80 2365
196f06d1 2366 # Needs to be done as soon as the component is loaded, as loading a sub-component
2367 # (next time round the loop) can cause us to get the wrong metaclass..
2368 $class->_controller_init_base_classes($component);
2369 }
2370
e7e4c469 2371 for my $component (@comps) {
5d02e790 2372 my $instance = $class->components->{ $component } = $class->setup_component($component);
2373 my @expanded_components = $instance->can('expand_modules')
2374 ? $instance->expand_modules( $component, $config )
2375 : $class->expand_component_module( $component, $config );
2376 for my $component (@expanded_components) {
05887b58 2377 next if $comps{$component};
e7e4c469 2378 $class->_controller_init_base_classes($component); # Also cover inner packages
2379 $class->components->{ $component } = $class->setup_component($component);
fbcc39ad 2380 }
364d7324 2381 }
2382}
fbcc39ad 2383
d261d153 2384=head2 $c->locate_components( $setup_component_config )
2385
2386This method is meant to provide a list of component modules that should be
2387setup for the application. By default, it will use L<Module::Pluggable>.
2388
2389Specify a C<setup_components> config option to pass additional options directly
2390to L<Module::Pluggable>. To add additional search paths, specify a key named
2391C<search_extra> as an array reference. Items in the array beginning with C<::>
2392will have the application class name prepended to them.
2393
2394=cut
2395
2396sub locate_components {
2397 my $class = shift;
2398 my $config = shift;
2399
2400 my @paths = qw( ::Controller ::C ::Model ::M ::View ::V );
2401 my $extra = delete $config->{ search_extra } || [];
2402
2403 push @paths, @$extra;
2404
2405 my $locator = Module::Pluggable::Object->new(
2406 search_path => [ map { s/^(?=::)/$class/; $_; } @paths ],
2407 %$config
2408 );
2409
2410 my @comps = $locator->plugins;
2411
2412 return @comps;
2413}
2414
2415=head2 $c->expand_component_module( $component, $setup_component_config )
2416
2417Components found by C<locate_components> will be passed to this method, which
2418is expected to return a list of component (package) names to be set up.
2419
d261d153 2420=cut
2421
2422sub expand_component_module {
2423 my ($class, $module) = @_;
05887b58 2424 return Devel::InnerPackage::list_packages( $module );
d261d153 2425}
2426
364d7324 2427=head2 $c->setup_component
fbcc39ad 2428
364d7324 2429=cut
fbcc39ad 2430
196f06d1 2431# FIXME - Ugly, ugly hack to ensure the we force initialize non-moose base classes
2432# nearest to Catalyst::Controller first, no matter what order stuff happens
2433# to be loaded. There are TODO tests in Moose for this, see
2434# f2391d17574eff81d911b97be15ea51080500003
2f5cb070 2435sub _controller_init_base_classes {
84848664 2436 my ($app_class, $component) = @_;
196f06d1 2437 return unless $component->isa('Catalyst::Controller');
2f5cb070 2438 foreach my $class ( reverse @{ mro::get_linear_isa($component) } ) {
c98492ae 2439 Moose::Meta::Class->initialize( $class )
2f5cb070 2440 unless find_meta($class);
2441 }
2442}
2443
364d7324 2444sub setup_component {
2445 my( $class, $component ) = @_;
fbcc39ad 2446
364d7324 2447 unless ( $component->can( 'COMPONENT' ) ) {
2448 return $component;
2449 }
fbcc39ad 2450
364d7324 2451 my $suffix = Catalyst::Utils::class2classsuffix( $component );
2452 my $config = $class->config->{ $suffix } || {};
8f6cebb2 2453 # Stash catalyst_component_name in the config here, so that custom COMPONENT
d2598ac8 2454 # methods also pass it. local to avoid pointlessly shitting in config
2455 # for the debug screen, as $component is already the key name.
8f6cebb2 2456 local $config->{catalyst_component_name} = $component;
fbcc39ad 2457
364d7324 2458 my $instance = eval { $component->COMPONENT( $class, $config ); };
fbcc39ad 2459
2460 if ( my $error = $@ ) {
fbcc39ad 2461 chomp $error;
fbcc39ad 2462 Catalyst::Exception->throw(
364d7324 2463 message => qq/Couldn't instantiate component "$component", "$error"/
2464 );
fbcc39ad 2465 }
2466
7490de2a 2467 unless (blessed $instance) {
2468 my $metaclass = Moose::Util::find_meta($component);
2469 my $method_meta = $metaclass->find_method_by_name('COMPONENT');
2470 my $component_method_from = $method_meta->associated_metaclass->name;
637fa644 2471 my $value = defined($instance) ? $instance : 'undef';
7490de2a 2472 Catalyst::Exception->throw(
2473 message =>
637fa644 2474 qq/Couldn't instantiate component "$component", COMPONENT() method (from $component_method_from) didn't return an object-like value (value was $value)./
7490de2a 2475 );
2476 }
364d7324 2477 return $instance;
fbcc39ad 2478}
2479
b5ecfcf0 2480=head2 $c->setup_dispatcher
fbcc39ad 2481
ae1e6b59 2482Sets up dispatcher.
2483
fbcc39ad 2484=cut
2485
2486sub setup_dispatcher {
2487 my ( $class, $dispatcher ) = @_;
2488
2489 if ($dispatcher) {
2490 $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
2491 }
2492
cb69249e 2493 if ( my $env = Catalyst::Utils::env_value( $class, 'DISPATCHER' ) ) {
2494 $dispatcher = 'Catalyst::Dispatcher::' . $env;
fbcc39ad 2495 }
2496
2497 unless ($dispatcher) {
cb0354c6 2498 $dispatcher = $class->dispatcher_class;
fbcc39ad 2499 }
2500
e63bdf38 2501 Class::MOP::load_class($dispatcher);
fbcc39ad 2502
2503 # dispatcher instance
2504 $class->dispatcher( $dispatcher->new );
2505}
2506
b5ecfcf0 2507=head2 $c->setup_engine
fbcc39ad 2508
ae1e6b59 2509Sets up engine.
2510
fbcc39ad 2511=cut
2512
2513sub setup_engine {
2514 my ( $class, $engine ) = @_;
2515
2516 if ($engine) {
2517 $engine = 'Catalyst::Engine::' . $engine;
2518 }
2519
cb69249e 2520 if ( my $env = Catalyst::Utils::env_value( $class, 'ENGINE' ) ) {
2521 $engine = 'Catalyst::Engine::' . $env;
fbcc39ad 2522 }
2523
9b0a3e0f 2524 if ( $ENV{MOD_PERL} ) {
e106a59f 2525 my $meta = Class::MOP::get_metaclass_by_name($class);
62a6df80 2526
fbcc39ad 2527 # create the apache method
74c89dea 2528 $meta->add_method('apache' => sub { shift->engine->apache });
fbcc39ad 2529
2530 my ( $software, $version ) =
2531 $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
2532
2533 $version =~ s/_//g;
2534 $version =~ s/(\.[^.]+)\./$1/g;
2535
2536 if ( $software eq 'mod_perl' ) {
2537
9b0a3e0f 2538 if ( !$engine ) {
22247e54 2539
9b0a3e0f 2540 if ( $version >= 1.99922 ) {
2541 $engine = 'Catalyst::Engine::Apache2::MP20';
2542 }
22247e54 2543
9b0a3e0f 2544 elsif ( $version >= 1.9901 ) {
2545 $engine = 'Catalyst::Engine::Apache2::MP19';
2546 }
22247e54 2547
9b0a3e0f 2548 elsif ( $version >= 1.24 ) {
2549 $engine = 'Catalyst::Engine::Apache::MP13';
2550 }
22247e54 2551
9b0a3e0f 2552 else {
2553 Catalyst::Exception->throw( message =>
2554 qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
2555 }
fbcc39ad 2556
fbcc39ad 2557 }
2558
2559 # install the correct mod_perl handler
2560 if ( $version >= 1.9901 ) {
2561 *handler = sub : method {
2562 shift->handle_request(@_);
2563 };
2564 }
2565 else {
2566 *handler = sub ($$) { shift->handle_request(@_) };
2567 }
2568
2569 }
2570
2571 elsif ( $software eq 'Zeus-Perl' ) {
2572 $engine = 'Catalyst::Engine::Zeus';
2573 }
2574
2575 else {
2576 Catalyst::Exception->throw(
2577 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
2578 }
2579 }
2580
2581 unless ($engine) {
cb0354c6 2582 $engine = $class->engine_class;
fbcc39ad 2583 }
2584
e63bdf38 2585 Class::MOP::load_class($engine);
0e7f5826 2586
d54484bf 2587 # check for old engines that are no longer compatible
2588 my $old_engine;
0e7f5826 2589 if ( $engine->isa('Catalyst::Engine::Apache')
2590 && !Catalyst::Engine::Apache->VERSION )
d54484bf 2591 {
2592 $old_engine = 1;
2593 }
0e7f5826 2594
d54484bf 2595 elsif ( $engine->isa('Catalyst::Engine::Server::Base')
0e7f5826 2596 && Catalyst::Engine::Server->VERSION le '0.02' )
d54484bf 2597 {
2598 $old_engine = 1;
2599 }
0e7f5826 2600
2601 elsif ($engine->isa('Catalyst::Engine::HTTP::POE')
2602 && $engine->VERSION eq '0.01' )
d54484bf 2603 {
2604 $old_engine = 1;
2605 }
0e7f5826 2606
2607 elsif ($engine->isa('Catalyst::Engine::Zeus')
2608 && $engine->VERSION eq '0.01' )
d54484bf 2609 {
2610 $old_engine = 1;
2611 }
fbcc39ad 2612
d54484bf 2613 if ($old_engine) {
2614 Catalyst::Exception->throw( message =>
0e7f5826 2615 qq/Engine "$engine" is not supported by this version of Catalyst/
d54484bf 2616 );
2617 }
0e7f5826 2618
fbcc39ad 2619 # engine instance
2620 $class->engine( $engine->new );
2621}
2622
b5ecfcf0 2623=head2 $c->setup_home
fbcc39ad 2624
ae1e6b59 2625Sets up the home directory.
2626
fbcc39ad 2627=cut
2628
2629sub setup_home {
2630 my ( $class, $home ) = @_;
2631
cb69249e 2632 if ( my $env = Catalyst::Utils::env_value( $class, 'HOME' ) ) {
2633 $home = $env;
fbcc39ad 2634 }
2635
b6d4ee6e 2636 $home ||= Catalyst::Utils::home($class);
fbcc39ad 2637
2638 if ($home) {
e63bdf38 2639 #I remember recently being scolded for assigning config values like this
fbcc39ad 2640 $class->config->{home} ||= $home;
a738ab68 2641 $class->config->{root} ||= Path::Class::Dir->new($home)->subdir('root');
fbcc39ad 2642 }
2643}
2644
b5ecfcf0 2645=head2 $c->setup_log
fbcc39ad 2646
0fa676a7 2647Sets up log by instantiating a L<Catalyst::Log|Catalyst::Log> object and
2648passing it to C<log()>. Pass in a comma-delimited list of levels to set the
2649log to.
62a6df80 2650
0fa676a7 2651This method also installs a C<debug> method that returns a true value into the
2652catalyst subclass if the "debug" level is passed in the comma-delimited list,
2653or if the C<$CATALYST_DEBUG> environment variable is set to a true value.
2654
2655Note that if the log has already been setup, by either a previous call to
2656C<setup_log> or by a call such as C<< __PACKAGE__->log( MyLogger->new ) >>,
5baa3bbc 2657that this method won't actually set up the log object.
ae1e6b59 2658
fbcc39ad 2659=cut
2660
2661sub setup_log {
0fa676a7 2662 my ( $class, $levels ) = @_;
fbcc39ad 2663
5baa3bbc 2664 $levels ||= '';
2665 $levels =~ s/^\s+//;
2666 $levels =~ s/\s+$//;
abf65c2a 2667 my %levels = map { $_ => 1 } split /\s*,\s*/, $levels;
2668
2669 my $env_debug = Catalyst::Utils::env_value( $class, 'DEBUG' );
2670 if ( defined $env_debug ) {
2671 $levels{debug} = 1 if $env_debug; # Ugly!
2672 delete($levels{debug}) unless $env_debug;
2673 }
2674
fbcc39ad 2675 unless ( $class->log ) {
0fa676a7 2676 $class->log( Catalyst::Log->new(keys %levels) );
fbcc39ad 2677 }
af3ff00e 2678
abf65c2a 2679 if ( $levels{debug} ) {
e106a59f 2680 Class::MOP::get_metaclass_by_name($class)->add_method('debug' => sub { 1 });
fbcc39ad 2681 $class->log->debug('Debug messages enabled');
2682 }
2683}
2684
b5ecfcf0 2685=head2 $c->setup_plugins
fbcc39ad 2686
ae1e6b59 2687Sets up plugins.
2688
fbcc39ad 2689=cut
2690
dc5f035e 2691=head2 $c->setup_stats
2692
2693Sets up timing statistics class.
2694
2695=cut
2696
2697sub setup_stats {
2698 my ( $class, $stats ) = @_;
2699
2700 Catalyst::Utils::ensure_class_loaded($class->stats_class);
2701
2702 my $env = Catalyst::Utils::env_value( $class, 'STATS' );
2703 if ( defined($env) ? $env : ($stats || $class->debug ) ) {
e106a59f 2704 Class::MOP::get_metaclass_by_name($class)->add_method('use_stats' => sub { 1 });
b01f0c69 2705 $class->log->debug('Statistics enabled');
dc5f035e 2706 }
2707}
2708
2709
62a6df80 2710=head2 $c->registered_plugins
836e1134 2711
2712Returns a sorted list of the plugins which have either been stated in the
2713import list or which have been added via C<< MyApp->plugin(@args); >>.
2714
2715If passed a given plugin name, it will report a boolean value indicating
2716whether or not that plugin is loaded. A fully qualified name is required if
2717the plugin name does not begin with C<Catalyst::Plugin::>.
2718
2719 if ($c->registered_plugins('Some::Plugin')) {
2720 ...
2721 }
2722
2723=cut
fbcc39ad 2724
836e1134 2725{
97b58e17 2726
2727 sub registered_plugins {
836e1134 2728 my $proto = shift;
197bd788 2729 return sort keys %{ $proto->_plugins } unless @_;
836e1134 2730 my $plugin = shift;
d0d4d785 2731 return 1 if exists $proto->_plugins->{$plugin};
2732 return exists $proto->_plugins->{"Catalyst::Plugin::$plugin"};
836e1134 2733 }
fbcc39ad 2734
836e1134 2735 sub _register_plugin {
2736 my ( $proto, $plugin, $instant ) = @_;
2737 my $class = ref $proto || $proto;
fbcc39ad 2738
b6d4ee6e 2739 Class::MOP::load_class( $plugin );
c4efaa54 2740 $class->log->warn( "$plugin inherits from 'Catalyst::Component' - this is decated and will not work in 5.81" )
2741 if $plugin->isa( 'Catalyst::Component' );
197bd788 2742 $proto->_plugins->{$plugin} = 1;
836e1134 2743 unless ($instant) {
fbcc39ad 2744 no strict 'refs';
e106a59f 2745 if ( my $meta = Class::MOP::get_metaclass_by_name($class) ) {
74c89dea 2746 my @superclasses = ($plugin, $meta->superclasses );
2747 $meta->superclasses(@superclasses);
5fb67d52 2748 } else {
2749 unshift @{"$class\::ISA"}, $plugin;
2750 }
fbcc39ad 2751 }
836e1134 2752 return $class;
2753 }
2754
2755 sub setup_plugins {
2756 my ( $class, $plugins ) = @_;
2757
d0d4d785 2758 $class->_plugins( {} ) unless $class->_plugins;
836e1134 2759 $plugins ||= [];
196932de 2760
5d8129e9 2761 my @plugins = Catalyst::Utils::resolve_namespace($class . '::Plugin', 'Catalyst::Plugin', @$plugins);
b0ad47c1 2762
e5210a95 2763 for my $plugin ( reverse @plugins ) {
2938f7a0 2764 Class::MOP::load_class($plugin);
e5210a95 2765 my $meta = find_meta($plugin);
2766 next if $meta && $meta->isa('Moose::Meta::Role');
836e1134 2767
2768 $class->_register_plugin($plugin);
2769 }
e5210a95 2770
2771 my @roles =
2772 map { $_->name }