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