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