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