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