a couple more details
[catagits/Catalyst-Runtime.git] / lib / Catalyst.pm
CommitLineData
fc7ec1d9 1package Catalyst;
2
a7caa492 3use Moose;
4extends 'Catalyst::Component';
fbcc39ad 5use bytes;
a2f2cde9 6use Catalyst::Exception;
fc7ec1d9 7use Catalyst::Log;
fbcc39ad 8use Catalyst::Request;
9use Catalyst::Request::Upload;
10use Catalyst::Response;
812a28c9 11use Catalyst::Utils;
31375184 12use Catalyst::Controller;
364d7324 13use Devel::InnerPackage ();
8f62c91a 14use File::stat;
c50f595c 15use Module::Pluggable::Object ();
5d9a6d47 16use NEXT;
c50f595c 17use Text::SimpleTable ();
18use Path::Class::Dir ();
19use Path::Class::File ();
fbcc39ad 20use Time::HiRes qw/gettimeofday tv_interval/;
c50f595c 21use URI ();
933ba403 22use URI::http;
23use URI::https;
6a4a7002 24use Scalar::Util qw/weaken blessed/;
5513038d 25use Tree::Simple qw/use_weak_refs/;
26use Tree::Simple::Visitor::FindByUID;
261c571e 27use attributes;
5789a3d8 28use utf8;
c45c5d37 29use Carp qw/croak carp/;
fc7ec1d9 30
f63c03e4 31BEGIN { require 5.008001; }
32
e8b9f2a9 33__PACKAGE__->mk_accessors(
a7caa492 34 qw/counter request response state action stack namespace stats stash/
e8b9f2a9 35);
10dd6896 36
684d10ed 37attributes->import( __PACKAGE__, \&namespace, 'lvalue' );
261c571e 38
8767c5a3 39sub depth { scalar @{ shift->stack || [] }; }
28591cd7 40
fbcc39ad 41# Laziness++
42*comp = \&component;
43*req = \&request;
44*res = \&response;
45
46# For backwards compatibility
47*finalize_output = \&finalize_body;
48
49# For statistics
50our $COUNT = 1;
51our $START = time;
52our $RECURSION = 1000;
53our $DETACH = "catalyst_detach\n";
54
fbcc39ad 55__PACKAGE__->mk_classdata($_)
3cec521a 56 for qw/components arguments dispatcher engine log dispatcher_class
a7caa492 57 engine_class context_class request_class response_class stats_class
dc5f035e 58 setup_finished/;
cb0354c6 59
3cec521a 60__PACKAGE__->dispatcher_class('Catalyst::Dispatcher');
61__PACKAGE__->engine_class('Catalyst::Engine::CGI');
62__PACKAGE__->request_class('Catalyst::Request');
63__PACKAGE__->response_class('Catalyst::Response');
dc5f035e 64__PACKAGE__->stats_class('Catalyst::Stats');
fbcc39ad 65
6415bb4d 66# Remember to update this in Catalyst::Runtime as well!
67
25f55123 68our $VERSION = '5.7013';
189e2a51 69
fbcc39ad 70sub import {
71 my ( $class, @arguments ) = @_;
72
73 # We have to limit $class to Catalyst to avoid pushing Catalyst upon every
74 # callers @ISA.
75 return unless $class eq 'Catalyst';
76
77 my $caller = caller(0);
78
79 unless ( $caller->isa('Catalyst') ) {
80 no strict 'refs';
5fb67d52 81 if( $caller->can('meta') ){
82 my @superclasses = ($caller->meta->superclasses, $class, 'Catalyst::Controller');
83 $caller->meta->superclasses(@superclasses);
84 } else {
85 push @{"$caller\::ISA"}, $class, 'Catalyst::Controller';
86 }
fbcc39ad 87 }
88
89 $caller->arguments( [@arguments] );
90 $caller->setup_home;
91}
fc7ec1d9 92
93=head1 NAME
94
95Catalyst - The Elegant MVC Web Application Framework
96
97=head1 SYNOPSIS
98
e7ad3b81 99See the L<Catalyst::Manual> distribution for comprehensive
100documentation and tutorials.
101
86418559 102 # Install Catalyst::Devel for helpers and other development tools
b4b01a8a 103 # use the helper to create a new application
91864987 104 catalyst.pl MyApp
fc7ec1d9 105
106 # add models, views, controllers
cc95842f 107 script/myapp_create.pl model MyDatabase DBIC::Schema create=dynamic dbi:SQLite:/path/to/db
108 script/myapp_create.pl view MyTemplate TT
0ef52a96 109 script/myapp_create.pl controller Search
fc7ec1d9 110
e7f1cf73 111 # built in testserver -- use -r to restart automatically on changes
cc95842f 112 # --help to see all available options
ae4e40a7 113 script/myapp_server.pl
fc7ec1d9 114
0ef52a96 115 # command line testing interface
ae4e40a7 116 script/myapp_test.pl /yada
fc7ec1d9 117
b4b01a8a 118 ### in lib/MyApp.pm
0ef52a96 119 use Catalyst qw/-Debug/; # include plugins here as well
a7caa492 120
85d9fce6 121 ### In lib/MyApp/Controller/Root.pm (autocreated)
0ef52a96 122 sub foo : Global { # called for /foo, /foo/1, /foo/1/2, etc.
ae1e6b59 123 my ( $self, $c, @args ) = @_; # args are qw/1 2/ for /foo/1/2
124 $c->stash->{template} = 'foo.tt'; # set the template
0ef52a96 125 # lookup something from db -- stash vars are passed to TT
a7caa492 126 $c->stash->{data} =
b4b01a8a 127 $c->model('Database::Foo')->search( { country => $args[0] } );
0ef52a96 128 if ( $c->req->params->{bar} ) { # access GET or POST parameters
129 $c->forward( 'bar' ); # process another action
a7caa492 130 # do something else after forward returns
0ef52a96 131 }
132 }
a7caa492 133
ae1e6b59 134 # The foo.tt TT template can use the stash data from the database
0ef52a96 135 [% WHILE (item = data.next) %]
136 [% item.foo %]
137 [% END %]
a7caa492 138
0ef52a96 139 # called for /bar/of/soap, /bar/of/soap/10, etc.
140 sub bar : Path('/bar/of/soap') { ... }
fc7ec1d9 141
ae1e6b59 142 # called for all actions, from the top-most controller downwards
a7caa492 143 sub auto : Private {
0ef52a96 144 my ( $self, $c ) = @_;
b4b01a8a 145 if ( !$c->user_exists ) { # Catalyst::Plugin::Authentication
0ef52a96 146 $c->res->redirect( '/login' ); # require login
147 return 0; # abort request and go immediately to end()
148 }
ae1e6b59 149 return 1; # success; carry on to next action
0ef52a96 150 }
a7caa492 151
ae1e6b59 152 # called after all actions are finished
a7caa492 153 sub end : Private {
5a8ed4fe 154 my ( $self, $c ) = @_;
0ef52a96 155 if ( scalar @{ $c->error } ) { ... } # handle errors
156 return if $c->res->body; # already have a response
157 $c->forward( 'MyApp::View::TT' ); # render template
5a8ed4fe 158 }
159
0ef52a96 160 ### in MyApp/Controller/Foo.pm
161 # called for /foo/bar
162 sub bar : Local { ... }
a7caa492 163
5400c668 164 # called for /blargle
165 sub blargle : Global { ... }
a7caa492 166
5400c668 167 # an index action matches /foo, but not /foo/1, etc.
168 sub index : Private { ... }
a7caa492 169
0ef52a96 170 ### in MyApp/Controller/Foo/Bar.pm
171 # called for /foo/bar/baz
172 sub baz : Local { ... }
a7caa492 173
b4b01a8a 174 # first Root auto is called, then Foo auto, then this
0ef52a96 175 sub auto : Private { ... }
a7caa492 176
0ef52a96 177 # powerful regular expression paths are also possible
178 sub details : Regex('^product/(\w+)/details$') {
5a8ed4fe 179 my ( $self, $c ) = @_;
0ef52a96 180 # extract the (\w+) from the URI
2982e768 181 my $product = $c->req->captures->[0];
5a8ed4fe 182 }
fc7ec1d9 183
0ef52a96 184See L<Catalyst::Manual::Intro> for additional information.
3803e98f 185
fc7ec1d9 186=head1 DESCRIPTION
187
86418559 188Catalyst is a modern framework for making web applications without the
189pain usually associated with this process. This document is a reference
190to the main Catalyst application. If you are a new user, we suggest you
191start with L<Catalyst::Manual::Tutorial> or L<Catalyst::Manual::Intro>.
fc7ec1d9 192
193See L<Catalyst::Manual> for more documentation.
194
ae1e6b59 195Catalyst plugins can be loaded by naming them as arguments to the "use
196Catalyst" statement. Omit the C<Catalyst::Plugin::> prefix from the
197plugin name, i.e., C<Catalyst::Plugin::My::Module> becomes
198C<My::Module>.
fc7ec1d9 199
0ef52a96 200 use Catalyst qw/My::Module/;
fc7ec1d9 201
836e1134 202If your plugin starts with a name other than C<Catalyst::Plugin::>, you can
203fully qualify the name by using a unary plus:
204
205 use Catalyst qw/
206 My::Module
207 +Fully::Qualified::Plugin::Name
208 /;
209
ae1e6b59 210Special flags like C<-Debug> and C<-Engine> can also be specified as
211arguments when Catalyst is loaded:
fc7ec1d9 212
213 use Catalyst qw/-Debug My::Module/;
214
ae1e6b59 215The position of plugins and flags in the chain is important, because
86418559 216they are loaded in the order in which they appear.
fc7ec1d9 217
23f9d934 218The following flags are supported:
219
b5ecfcf0 220=head2 -Debug
23f9d934 221
f8ad6ea5 222Enables debug output. You can also force this setting from the system
86418559 223environment with CATALYST_DEBUG or <MYAPP>_DEBUG. The environment
224settings override the application, with <MYAPP>_DEBUG having the highest
225priority.
fc7ec1d9 226
b5ecfcf0 227=head2 -Engine
fc7ec1d9 228
ae1e6b59 229Forces Catalyst to use a specific engine. Omit the
230C<Catalyst::Engine::> prefix of the engine name, i.e.:
fc7ec1d9 231
0ef52a96 232 use Catalyst qw/-Engine=CGI/;
fc7ec1d9 233
b5ecfcf0 234=head2 -Home
fbcc39ad 235
ae1e6b59 236Forces Catalyst to use a specific home directory, e.g.:
237
86418559 238 use Catalyst qw[-Home=/usr/mst];
fbcc39ad 239
cc95842f 240This can also be done in the shell environment by setting either the
241C<CATALYST_HOME> environment variable or C<MYAPP_HOME>; where C<MYAPP>
242is replaced with the uppercased name of your application, any "::" in
243the name will be replaced with underscores, e.g. MyApp::Web should use
244MYAPP_WEB_HOME. If both variables are set, the MYAPP_HOME one will be used.
245
b5ecfcf0 246=head2 -Log
fbcc39ad 247
0ef52a96 248Specifies log level.
fbcc39ad 249
dc5f035e 250=head2 -Stats
251
252Enables statistics collection and reporting. You can also force this setting
253from the system environment with CATALYST_STATS or <MYAPP>_STATS. The
254environment settings override the application, with <MYAPP>_STATS having the
255highest priority.
256
a7caa492 257e.g.
dc5f035e 258
259 use Catalyst qw/-Stats=1/
260
23f9d934 261=head1 METHODS
262
f7b672ef 263=head2 INFORMATION ABOUT THE CURRENT REQUEST
0ef52a96 264
b5ecfcf0 265=head2 $c->action
66e28e3f 266
ae1e6b59 267Returns a L<Catalyst::Action> object for the current action, which
268stringifies to the action name. See L<Catalyst::Action>.
0ef52a96 269
b5ecfcf0 270=head2 $c->namespace
0ef52a96 271
86418559 272Returns the namespace of the current action, i.e., the URI prefix
ae1e6b59 273corresponding to the controller of the current action. For example:
274
275 # in Controller::Foo::Bar
276 $c->namespace; # returns 'foo/bar';
0ef52a96 277
b5ecfcf0 278=head2 $c->request
0ef52a96 279
b5ecfcf0 280=head2 $c->req
0ef52a96 281
86418559 282Returns the current L<Catalyst::Request> object, giving access to
283information about the current client request (including parameters,
284cookies, HTTP headers, etc.). See L<Catalyst::Request>.
0ef52a96 285
b4b01a8a 286=head2 REQUEST FLOW HANDLING
0ef52a96 287
b5ecfcf0 288=head2 $c->forward( $action [, \@arguments ] )
0ef52a96 289
b5ecfcf0 290=head2 $c->forward( $class, $method, [, \@arguments ] )
0ef52a96 291
86418559 292Forwards processing to another action, by its private name. If you give a
b4b01a8a 293class name but no method, C<process()> is called. You may also optionally
294pass arguments in an arrayref. The action will receive the arguments in
cc95842f 295C<@_> and C<< $c->req->args >>. Upon returning from the function,
296C<< $c->req->args >> will be restored to the previous values.
0ef52a96 297
3b984c64 298Any data C<return>ed from the action forwarded to, will be returned by the
d759db1e 299call to forward.
3b984c64 300
301 my $foodata = $c->forward('/foo');
0ef52a96 302 $c->forward('index');
e112461a 303 $c->forward(qw/MyApp::Model::DBIC::Foo do_stuff/);
0ef52a96 304 $c->forward('MyApp::View::TT');
305
86418559 306Note that forward implies an C<<eval { }>> around the call (actually
307C<execute> does), thus de-fatalizing all 'dies' within the called
308action. If you want C<die> to propagate you need to do something like:
f3e6a8c0 309
310 $c->forward('foo');
311 die $c->error if $c->error;
312
86418559 313Or make sure to always return true values from your actions and write
314your code like this:
f3e6a8c0 315
316 $c->forward('foo') || return;
317
0ef52a96 318=cut
319
320sub forward { my $c = shift; $c->dispatcher->forward( $c, @_ ) }
321
b5ecfcf0 322=head2 $c->detach( $action [, \@arguments ] )
0ef52a96 323
b5ecfcf0 324=head2 $c->detach( $class, $method, [, \@arguments ] )
0ef52a96 325
264bac8c 326=head2 $c->detach()
327
a7caa492 328The same as C<forward>, but doesn't return to the previous action when
329processing is finished.
0ef52a96 330
264bac8c 331When called with no arguments it escapes the processing chain entirely.
332
0ef52a96 333=cut
334
335sub detach { my $c = shift; $c->dispatcher->detach( $c, @_ ) }
336
b4b01a8a 337=head2 $c->response
338
339=head2 $c->res
340
cc95842f 341Returns the current L<Catalyst::Response> object, see there for details.
b4b01a8a 342
343=head2 $c->stash
344
345Returns a hashref to the stash, which may be used to store data and pass
346it between components during a request. You can also set hash keys by
347passing arguments. The stash is automatically sent to the view. The
348stash is cleared at the end of a request; it cannot be used for
86418559 349persistent storage (for this you must use a session; see
350L<Catalyst::Plugin::Session> for a complete system integrated with
351Catalyst).
b4b01a8a 352
353 $c->stash->{foo} = $bar;
354 $c->stash( { moose => 'majestic', qux => 0 } );
355 $c->stash( bar => 1, gorch => 2 ); # equivalent to passing a hashref
a7caa492 356
b4b01a8a 357 # stash is automatically passed to the view for use in a template
cc95842f 358 $c->forward( 'MyApp::View::TT' );
b4b01a8a 359
360=cut
361
a7caa492 362around stash => sub {
363 my $orig = shift;
b4b01a8a 364 my $c = shift;
365 if (@_) {
366 my $stash = @_ > 1 ? {@_} : $_[0];
85d9fce6 367 croak('stash takes a hash or hashref') unless ref $stash;
c82ed742 368 foreach my $key ( keys %$stash ) {
a7caa492 369 $c->$orig()->{$key} = $stash->{$key};
b4b01a8a 370 }
371 }
a7caa492 372 return $c->$orig();
373};
b4b01a8a 374
b5ecfcf0 375=head2 $c->error
0ef52a96 376
b5ecfcf0 377=head2 $c->error($error, ...)
0ef52a96 378
b5ecfcf0 379=head2 $c->error($arrayref)
0ef52a96 380
83a8fcac 381Returns an arrayref containing error messages. If Catalyst encounters an
382error while processing a request, it stores the error in $c->error. This
e7ad3b81 383method should only be used to store fatal error messages.
0ef52a96 384
385 my @error = @{ $c->error };
386
387Add a new error.
388
389 $c->error('Something bad happened');
390
0ef52a96 391=cut
392
393sub error {
394 my $c = shift;
395 if ( $_[0] ) {
396 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
9ce44430 397 croak @$error unless ref $c;
0ef52a96 398 push @{ $c->{error} }, @$error;
399 }
400 elsif ( defined $_[0] ) { $c->{error} = undef }
401 return $c->{error} || [];
402}
403
b4b01a8a 404
405=head2 $c->state
406
407Contains the return value of the last executed action.
408
ca81eb67 409=head2 $c->clear_errors
410
411Clear errors. You probably don't want to clear the errors unless you are
412implementing a custom error screen.
413
414This is equivalent to running
415
416 $c->error(0);
417
418=cut
419
420sub clear_errors {
421 my $c = shift;
422 $c->error(0);
423}
424
0ef52a96 425
0756fe3b 426# search via regex
427sub _comp_search {
197bd788 428 my ( $c, @names ) = @_;
0756fe3b 429
430 foreach my $name (@names) {
431 foreach my $component ( keys %{ $c->components } ) {
197bd788 432 return $c->components->{$component} if $component =~ /$name/i;
0756fe3b 433 }
434 }
435
436 return undef;
437}
438
439# try explicit component names
440sub _comp_explicit {
197bd788 441 my ( $c, @names ) = @_;
0756fe3b 442
443 foreach my $try (@names) {
197bd788 444 return $c->components->{$try} if ( exists $c->components->{$try} );
0756fe3b 445 }
446
447 return undef;
448}
449
450# like component, but try just these prefixes before regex searching,
451# and do not try to return "sort keys %{ $c->components }"
452sub _comp_prefixes {
197bd788 453 my ( $c, $name, @prefixes ) = @_;
0756fe3b 454
455 my $appclass = ref $c || $c;
456
457 my @names = map { "${appclass}::${_}::${name}" } @prefixes;
458
459 my $comp = $c->_comp_explicit(@names);
460 return $comp if defined($comp);
461 $comp = $c->_comp_search($name);
462 return $comp;
463}
464
a7caa492 465# Find possible names for a prefix
3b88a455 466
467sub _comp_names {
468 my ( $c, @prefixes ) = @_;
469
470 my $appclass = ref $c || $c;
471
472 my @pre = map { "${appclass}::${_}::" } @prefixes;
473
474 my @names;
475
476 COMPONENT: foreach my $comp ($c->component) {
477 foreach my $p (@pre) {
478 if ($comp =~ s/^$p//) {
479 push(@names, $comp);
480 next COMPONENT;
481 }
482 }
483 }
484
485 return @names;
486}
487
649fd1fa 488# Return a component if only one matches.
489sub _comp_singular {
197bd788 490 my ( $c, @prefixes ) = @_;
649fd1fa 491
492 my $appclass = ref $c || $c;
493
197bd788 494 my ( $comp, $rest ) =
495 map { $c->_comp_search("^${appclass}::${_}::") } @prefixes;
649fd1fa 496 return $comp unless $rest;
497}
498
197bd788 499# Filter a component before returning by calling ACCEPT_CONTEXT if available
500sub _filter_component {
501 my ( $c, $comp, @args ) = @_;
502 if ( eval { $comp->can('ACCEPT_CONTEXT'); } ) {
503 return $comp->ACCEPT_CONTEXT( $c, @args );
504 }
505 else { return $comp }
506}
507
f7b672ef 508=head2 COMPONENT ACCESSORS
0ef52a96 509
b5ecfcf0 510=head2 $c->controller($name)
af3ff00e 511
0ef52a96 512Gets a L<Catalyst::Controller> instance by name.
af3ff00e 513
514 $c->controller('Foo')->do_stuff;
515
86418559 516If the name is omitted, will return the controller for the dispatched
517action.
649fd1fa 518
af3ff00e 519=cut
520
521sub controller {
197bd788 522 my ( $c, $name, @args ) = @_;
523 return $c->_filter_component( $c->_comp_prefixes( $name, qw/Controller C/ ),
524 @args )
525 if ($name);
526 return $c->component( $c->action->class );
af3ff00e 527}
528
b5ecfcf0 529=head2 $c->model($name)
fc7ec1d9 530
0ef52a96 531Gets a L<Catalyst::Model> instance by name.
532
533 $c->model('Foo')->do_stuff;
fc7ec1d9 534
72f87c4b 535Any extra arguments are directly passed to ACCEPT_CONTEXT.
536
a7caa492 537If the name is omitted, it will look for
a3b71f0f 538 - a model object in $c->stash{current_model_instance}, then
539 - a model name in $c->stash->{current_model}, then
540 - a config setting 'default_model', or
541 - check if there is only one model, and return it if that's the case.
649fd1fa 542
fc7ec1d9 543=cut
544
0ef52a96 545sub model {
197bd788 546 my ( $c, $name, @args ) = @_;
547 return $c->_filter_component( $c->_comp_prefixes( $name, qw/Model M/ ),
548 @args )
549 if $name;
a3b71f0f 550 if (ref $c) {
a7caa492 551 return $c->stash->{current_model_instance}
a3b71f0f 552 if $c->stash->{current_model_instance};
553 return $c->model( $c->stash->{current_model} )
554 if $c->stash->{current_model};
a3b71f0f 555 }
72f87c4b 556 return $c->model( $c->config->{default_model} )
557 if $c->config->{default_model};
558 return $c->_filter_component( $c->_comp_singular(qw/Model M/) );
649fd1fa 559
0ef52a96 560}
fc7ec1d9 561
b4b01a8a 562=head2 $c->controllers
3b88a455 563
b4b01a8a 564Returns the available names which can be passed to $c->controller
3b88a455 565
566=cut
567
b4b01a8a 568sub controllers {
3b88a455 569 my ( $c ) = @_;
b4b01a8a 570 return $c->_comp_names(qw/Controller C/);
3b88a455 571}
572
b4b01a8a 573
b5ecfcf0 574=head2 $c->view($name)
0ef52a96 575
576Gets a L<Catalyst::View> instance by name.
fc7ec1d9 577
0ef52a96 578 $c->view('Foo')->do_stuff;
fc7ec1d9 579
72f87c4b 580Any extra arguments are directly passed to ACCEPT_CONTEXT.
581
a7caa492 582If the name is omitted, it will look for
a3b71f0f 583 - a view object in $c->stash{current_view_instance}, then
584 - a view name in $c->stash->{current_view}, then
585 - a config setting 'default_view', or
586 - check if there is only one view, and return it if that's the case.
649fd1fa 587
fc7ec1d9 588=cut
589
0ef52a96 590sub view {
197bd788 591 my ( $c, $name, @args ) = @_;
592 return $c->_filter_component( $c->_comp_prefixes( $name, qw/View V/ ),
593 @args )
594 if $name;
a3b71f0f 595 if (ref $c) {
a7caa492 596 return $c->stash->{current_view_instance}
a3b71f0f 597 if $c->stash->{current_view_instance};
598 return $c->view( $c->stash->{current_view} )
599 if $c->stash->{current_view};
a3b71f0f 600 }
72f87c4b 601 return $c->view( $c->config->{default_view} )
602 if $c->config->{default_view};
197bd788 603 return $c->_filter_component( $c->_comp_singular(qw/View V/) );
0ef52a96 604}
fbcc39ad 605
b4b01a8a 606=head2 $c->models
607
608Returns the available names which can be passed to $c->model
609
610=cut
611
612sub models {
613 my ( $c ) = @_;
614 return $c->_comp_names(qw/Model M/);
615}
616
617
3b88a455 618=head2 $c->views
619
620Returns the available names which can be passed to $c->view
621
622=cut
623
624sub views {
625 my ( $c ) = @_;
626 return $c->_comp_names(qw/View V/);
627}
628
b4b01a8a 629=head2 $c->comp($name)
630
631=head2 $c->component($name)
632
cc95842f 633Gets a component object by name. This method is not recommended,
b4b01a8a 634unless you want to get a specific component by full
cc95842f 635class. C<< $c->controller >>, C<< $c->model >>, and C<< $c->view >>
b4b01a8a 636should be used instead.
637
638=cut
639
640sub component {
641 my $c = shift;
642
643 if (@_) {
644
645 my $name = shift;
646
647 my $appclass = ref $c || $c;
648
649 my @names = (
650 $name, "${appclass}::${name}",
651 map { "${appclass}::${_}::${name}" }
652 qw/Model M Controller C View V/
653 );
654
655 my $comp = $c->_comp_explicit(@names);
656 return $c->_filter_component( $comp, @_ ) if defined($comp);
657
658 $comp = $c->_comp_search($name);
659 return $c->_filter_component( $comp, @_ ) if defined($comp);
660 }
661
662 return sort keys %{ $c->components };
663}
664
665
666
667=head2 CLASS DATA AND HELPER CLASSES
fbcc39ad 668
b5ecfcf0 669=head2 $c->config
fbcc39ad 670
0ef52a96 671Returns or takes a hashref containing the application's configuration.
672
61b1d329 673 __PACKAGE__->config( { db => 'dsn:SQLite:foo.db' } );
81557adf 674
cc95842f 675You can also use a C<YAML>, C<XML> or C<Config::General> config file
676like myapp.yml in your applications home directory. See
677L<Catalyst::Plugin::ConfigLoader>.
a6ad13b6 678
679 ---
680 db: dsn:SQLite:foo.db
681
b4b01a8a 682
3643e890 683=cut
684
5fb67d52 685around config => sub {
686 my $orig = shift;
3643e890 687 my $c = shift;
688
689 $c->log->warn("Setting config after setup has been run is not a good idea.")
690 if ( @_ and $c->setup_finished );
691
5fb67d52 692 $c->$orig(@_);
693};
3643e890 694
b5ecfcf0 695=head2 $c->log
0ef52a96 696
86418559 697Returns the logging object instance. Unless it is already set, Catalyst
698sets this up with a L<Catalyst::Log> object. To use your own log class,
699set the logger with the C<< __PACKAGE__->log >> method prior to calling
9e7673af 700C<< __PACKAGE__->setup >>.
701
702 __PACKAGE__->log( MyLogger->new );
703 __PACKAGE__->setup;
704
705And later:
0ef52a96 706
ae1e6b59 707 $c->log->info( 'Now logging with my own logger!' );
0ef52a96 708
86418559 709Your log class should implement the methods described in
710L<Catalyst::Log>.
af3ff00e 711
b4b01a8a 712
713=head2 $c->debug
714
715Overload to enable debug messages (same as -Debug option).
716
e80e8542 717Note that this is a static method, not an accessor and should be overloaded
718by declaring "sub debug { 1 }" in your MyApp.pm, not by calling $c->debug(1).
719
af3ff00e 720=cut
721
b4b01a8a 722sub debug { 0 }
723
724=head2 $c->dispatcher
725
726Returns the dispatcher instance. Stringifies to class name. See
727L<Catalyst::Dispatcher>.
728
729=head2 $c->engine
730
731Returns the engine instance. Stringifies to the class name. See
732L<Catalyst::Engine>.
733
734
f7b672ef 735=head2 UTILITY METHODS
66e28e3f 736
b5ecfcf0 737=head2 $c->path_to(@path)
01033d73 738
cc95842f 739Merges C<@path> with C<< $c->config->{home} >> and returns a
740L<Path::Class::Dir> object.
01033d73 741
742For example:
743
744 $c->path_to( 'db', 'sqlite.db' );
745
746=cut
747
748sub path_to {
749 my ( $c, @path ) = @_;
a738ab68 750 my $path = Path::Class::Dir->new( $c->config->{home}, @path );
01033d73 751 if ( -d $path ) { return $path }
a738ab68 752 else { return Path::Class::File->new( $c->config->{home}, @path ) }
01033d73 753}
754
b5ecfcf0 755=head2 $c->plugin( $name, $class, @args )
0ef52a96 756
ae1e6b59 757Helper method for plugins. It creates a classdata accessor/mutator and
758loads and instantiates the given class.
0ef52a96 759
760 MyApp->plugin( 'prototype', 'HTML::Prototype' );
761
762 $c->prototype->define_javascript_functions;
763
764=cut
765
766sub plugin {
767 my ( $class, $name, $plugin, @args ) = @_;
97b58e17 768 $class->_register_plugin( $plugin, 1 );
0ef52a96 769
770 eval { $plugin->import };
771 $class->mk_classdata($name);
772 my $obj;
773 eval { $obj = $plugin->new(@args) };
774
775 if ($@) {
776 Catalyst::Exception->throw( message =>
777 qq/Couldn't instantiate instant plugin "$plugin", "$@"/ );
778 }
779
780 $class->$name($obj);
781 $class->log->debug(qq/Initialized instant plugin "$plugin" as "$name"/)
782 if $class->debug;
783}
784
b5ecfcf0 785=head2 MyApp->setup
fbcc39ad 786
e7f1cf73 787Initializes the dispatcher and engine, loads any plugins, and loads the
ae1e6b59 788model, view, and controller components. You may also specify an array
789of plugins to load here, if you choose to not load them in the C<use
790Catalyst> line.
fbcc39ad 791
0ef52a96 792 MyApp->setup;
793 MyApp->setup( qw/-Debug/ );
fbcc39ad 794
795=cut
796
797sub setup {
0319a12c 798 my ( $class, @arguments ) = @_;
599b5295 799
5168a5fc 800 $class->log->warn("Running setup twice is not a good idea.")
801 if ( $class->setup_finished );
802
fbcc39ad 803 unless ( $class->isa('Catalyst') ) {
953b0e15 804
fbcc39ad 805 Catalyst::Exception->throw(
806 message => qq/'$class' does not inherit from Catalyst/ );
1c99e125 807 }
0319a12c 808
fbcc39ad 809 if ( $class->arguments ) {
810 @arguments = ( @arguments, @{ $class->arguments } );
811 }
812
813 # Process options
814 my $flags = {};
815
816 foreach (@arguments) {
817
818 if (/^-Debug$/) {
819 $flags->{log} =
820 ( $flags->{log} ) ? 'debug,' . $flags->{log} : 'debug';
821 }
822 elsif (/^-(\w+)=?(.*)$/) {
823 $flags->{ lc $1 } = $2;
824 }
825 else {
826 push @{ $flags->{plugins} }, $_;
827 }
828 }
829
99f187d6 830 $class->setup_home( delete $flags->{home} );
831
fbcc39ad 832 $class->setup_log( delete $flags->{log} );
833 $class->setup_plugins( delete $flags->{plugins} );
834 $class->setup_dispatcher( delete $flags->{dispatcher} );
835 $class->setup_engine( delete $flags->{engine} );
dc5f035e 836 $class->setup_stats( delete $flags->{stats} );
fbcc39ad 837
838 for my $flag ( sort keys %{$flags} ) {
839
840 if ( my $code = $class->can( 'setup_' . $flag ) ) {
841 &$code( $class, delete $flags->{$flag} );
842 }
843 else {
844 $class->log->warn(qq/Unknown flag "$flag"/);
845 }
846 }
847
0eb4af72 848 eval { require Catalyst::Devel; };
849 if( !$@ && $ENV{CATALYST_SCRIPT_GEN} && ( $ENV{CATALYST_SCRIPT_GEN} < $Catalyst::Devel::CATALYST_SCRIPT_GEN ) ) {
850 $class->log->warn(<<"EOF");
4ff0d824 851You are running an old script!
852
34a83d89 853 Please update by running (this will overwrite existing files):
854 catalyst.pl -force -scripts $class
855
856 or (this will not overwrite existing files):
857 catalyst.pl -scripts $class
1cf0345b 858
4ff0d824 859EOF
0eb4af72 860 }
a7caa492 861
fbcc39ad 862 if ( $class->debug ) {
6601f2ad 863 my @plugins = map { "$_ " . ( $_->VERSION || '' ) } $class->registered_plugins;
fbcc39ad 864
865 if (@plugins) {
34d28dfd 866 my $t = Text::SimpleTable->new(74);
8c113188 867 $t->row($_) for @plugins;
1cf0345b 868 $class->log->debug( "Loaded plugins:\n" . $t->draw . "\n" );
fbcc39ad 869 }
870
871 my $dispatcher = $class->dispatcher;
872 my $engine = $class->engine;
873 my $home = $class->config->{home};
874
875 $class->log->debug(qq/Loaded dispatcher "$dispatcher"/);
876 $class->log->debug(qq/Loaded engine "$engine"/);
877
878 $home
879 ? ( -d $home )
880 ? $class->log->debug(qq/Found home "$home"/)
881 : $class->log->debug(qq/Home "$home" doesn't exist/)
882 : $class->log->debug(q/Couldn't find home/);
883 }
884
885 # Call plugins setup
886 {
887 no warnings qw/redefine/;
888 local *setup = sub { };
889 $class->setup;
890 }
891
892 # Initialize our data structure
893 $class->components( {} );
894
895 $class->setup_components;
896
897 if ( $class->debug ) {
34d28dfd 898 my $t = Text::SimpleTable->new( [ 63, 'Class' ], [ 8, 'Type' ] );
684d10ed 899 for my $comp ( sort keys %{ $class->components } ) {
900 my $type = ref $class->components->{$comp} ? 'instance' : 'class';
901 $t->row( $comp, $type );
902 }
1cf0345b 903 $class->log->debug( "Loaded components:\n" . $t->draw . "\n" )
8c113188 904 if ( keys %{ $class->components } );
fbcc39ad 905 }
906
907 # Add our self to components, since we are also a component
908 $class->components->{$class} = $class;
909
910 $class->setup_actions;
911
912 if ( $class->debug ) {
913 my $name = $class->config->{name} || 'Application';
914 $class->log->info("$name powered by Catalyst $Catalyst::VERSION");
915 }
916 $class->log->_flush() if $class->log->can('_flush');
3643e890 917
918 $class->setup_finished(1);
fbcc39ad 919}
920
73664287 921=head2 $c->uri_for( $path, @args?, \%query_values? )
fbcc39ad 922
c50f595c 923Merges path with C<< $c->request->base >> for absolute URIs and with
924C<< $c->namespace >> for relative URIs, then returns a normalized L<URI>
86418559 925object. If any args are passed, they are added at the end of the path.
926If the last argument to C<uri_for> is a hash reference, it is assumed to
927contain GET parameter key/value pairs, which will be appended to the URI
928in standard fashion.
fbcc39ad 929
8dc69021 930Note that uri_for is destructive to the passed hashref. Subsequent calls
931with the same hashref may have unintended results.
932
86418559 933Instead of C<$path>, you can also optionally pass a C<$action> object
934which will be resolved to a path using
147869cd 935C<< $c->dispatcher->uri_for_action >>; if the first element of
86418559 936C<@args> is an arrayref it is treated as a list of captures to be passed
937to C<uri_for_action>.
ea0e58d9 938
fbcc39ad 939=cut
940
941sub uri_for {
00e6a2b7 942 my ( $c, $path, @args ) = @_;
00e6a2b7 943
ea0e58d9 944 if ( Scalar::Util::blessed($path) ) { # action object
945 my $captures = ( scalar @args && ref $args[0] eq 'ARRAY'
946 ? shift(@args)
947 : [] );
948 $path = $c->dispatcher->uri_for_action($path, $captures);
949 return undef unless defined($path);
81e75875 950 $path = '/' if $path eq '';
ea0e58d9 951 }
952
51674a63 953 undef($path) if (defined $path && $path eq '');
00e6a2b7 954
97b58e17 955 my $params =
956 ( scalar @args && ref $args[$#args] eq 'HASH' ? pop @args : {} );
8327e2e2 957
cbb93105 958 carp "uri_for called with undef argument" if grep { ! defined $_ } @args;
51674a63 959 s/([^$URI::uric])/$URI::Escape::escapes{$1}/go for @args;
960
961 unshift(@args, $path);
962
963 unless (defined $path && $path =~ s!^/!!) { # in-place strip
964 my $namespace = $c->namespace;
965 if (defined $path) { # cheesy hack to handle path '../foo'
966 $namespace =~ s{(?:^|/)[^/]+$}{} while $args[0] =~ s{^\.\./}{};
6601f2ad 967 }
51674a63 968 unshift(@args, $namespace || '');
969 }
a7caa492 970
189e2a51 971 # join args with '/', or a blank string
51674a63 972 my $args = join('/', grep { defined($_) } @args);
973 $args =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
974 $args =~ s!^/!!;
975 my $base = $c->req->base;
976 my $class = ref($base);
977 $base =~ s{(?<!/)$}{/};
978
979 my $query = '';
980
981 if (my @keys = keys %$params) {
982 # somewhat lifted from URI::_query's query_form
983 $query = '?'.join('&', map {
984 s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/go;
985 s/ /+/g;
986 my $key = $_;
987 my $val = $params->{$_};
988 $val = '' unless defined $val;
989 (map {
990 $_ = "$_";
0ce485e9 991 utf8::encode( $_ ) if utf8::is_utf8($_);
51674a63 992 # using the URI::Escape pattern here so utf8 chars survive
993 s/([^A-Za-z0-9\-_.!~*'() ])/$URI::Escape::escapes{$1}/go;
994 s/ /+/g;
995 "${key}=$_"; } ( ref $val eq 'ARRAY' ? @$val : $val ));
996 } @keys);
997 }
998
999 my $res = bless(\"${base}${args}${query}", $class);
d3e7a648 1000 $res;
fbcc39ad 1001}
1002
b5ecfcf0 1003=head2 $c->welcome_message
ab2374d3 1004
1005Returns the Catalyst welcome HTML page.
1006
1007=cut
1008
1009sub welcome_message {
bf1f2c60 1010 my $c = shift;
1011 my $name = $c->config->{name};
1012 my $logo = $c->uri_for('/static/images/catalyst_logo.png');
1013 my $prefix = Catalyst::Utils::appprefix( ref $c );
80cdbbff 1014 $c->response->content_type('text/html; charset=utf-8');
ab2374d3 1015 return <<"EOF";
80cdbbff 1016<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1017 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1018<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
ab2374d3 1019 <head>
85d9fce6 1020 <meta http-equiv="Content-Language" content="en" />
1021 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
ab2374d3 1022 <title>$name on Catalyst $VERSION</title>
1023 <style type="text/css">
1024 body {
ab2374d3 1025 color: #000;
1026 background-color: #eee;
1027 }
1028 div#content {
1029 width: 640px;
80cdbbff 1030 margin-left: auto;
1031 margin-right: auto;
ab2374d3 1032 margin-top: 10px;
1033 margin-bottom: 10px;
1034 text-align: left;
1035 background-color: #ccc;
1036 border: 1px solid #aaa;
ab2374d3 1037 }
d84c4dab 1038 p, h1, h2 {
ab2374d3 1039 margin-left: 20px;
1040 margin-right: 20px;
16215972 1041 font-family: verdana, tahoma, sans-serif;
ab2374d3 1042 }
d84c4dab 1043 a {
1044 font-family: verdana, tahoma, sans-serif;
1045 }
d114e033 1046 :link, :visited {
1047 text-decoration: none;
1048 color: #b00;
1049 border-bottom: 1px dotted #bbb;
1050 }
1051 :link:hover, :visited:hover {
d114e033 1052 color: #555;
1053 }
ab2374d3 1054 div#topbar {
1055 margin: 0px;
1056 }
3e82a295 1057 pre {
3e82a295 1058 margin: 10px;
1059 padding: 8px;
1060 }
ab2374d3 1061 div#answers {
1062 padding: 8px;
1063 margin: 10px;
d114e033 1064 background-color: #fff;
ab2374d3 1065 border: 1px solid #aaa;
ab2374d3 1066 }
1067 h1 {
33108eaf 1068 font-size: 0.9em;
1069 font-weight: normal;
ab2374d3 1070 text-align: center;
1071 }
1072 h2 {
1073 font-size: 1.0em;
1074 }
1075 p {
1076 font-size: 0.9em;
1077 }
ae7c5252 1078 p img {
1079 float: right;
1080 margin-left: 10px;
1081 }
9619f23c 1082 span#appname {
1083 font-weight: bold;
33108eaf 1084 font-size: 1.6em;
ab2374d3 1085 }
1086 </style>
1087 </head>
1088 <body>
1089 <div id="content">
1090 <div id="topbar">
9619f23c 1091 <h1><span id="appname">$name</span> on <a href="http://catalyst.perl.org">Catalyst</a>
d84c4dab 1092 $VERSION</h1>
ab2374d3 1093 </div>
1094 <div id="answers">
ae7c5252 1095 <p>
80cdbbff 1096 <img src="$logo" alt="Catalyst Logo" />
ae7c5252 1097 </p>
596aaffe 1098 <p>Welcome to the world of Catalyst.
f92fd545 1099 This <a href="http://en.wikipedia.org/wiki/MVC">MVC</a>
1100 framework will make web development something you had
60dd6e1d 1101 never expected it to be: Fun, rewarding, and quick.</p>
ab2374d3 1102 <h2>What to do now?</h2>
4b8cb778 1103 <p>That really depends on what <b>you</b> want to do.
ab2374d3 1104 We do, however, provide you with a few starting points.</p>
1105 <p>If you want to jump right into web development with Catalyst
596aaffe 1106 you might want want to start with a tutorial.</p>
b607f8a0 1107<pre>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Tutorial.pod">Catalyst::Manual::Tutorial</a></code>
596aaffe 1108</pre>
1109<p>Afterwards you can go on to check out a more complete look at our features.</p>
1110<pre>
b607f8a0 1111<code>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Intro.pod">Catalyst::Manual::Intro</a>
1112<!-- Something else should go here, but the Catalyst::Manual link seems unhelpful -->
1113</code></pre>
ab2374d3 1114 <h2>What to do next?</h2>
f5681c92 1115 <p>Next it's time to write an actual application. Use the
80cdbbff 1116 helper scripts to generate <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AController%3A%3A&amp;mode=all">controllers</a>,
60dd6e1d 1117 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AModel%3A%3A&amp;mode=all">models</a>, and
1118 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AView%3A%3A&amp;mode=all">views</a>;
bf1f2c60 1119 they can save you a lot of work.</p>
1120 <pre><code>script/${prefix}_create.pl -help</code></pre>
1121 <p>Also, be sure to check out the vast and growing
60dd6e1d 1122 collection of <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3APlugin%3A%3A&amp;mode=all">plugins for Catalyst on CPAN</a>;
bf1f2c60 1123 you are likely to find what you need there.
f5681c92 1124 </p>
1125
82245cc4 1126 <h2>Need help?</h2>
f5681c92 1127 <p>Catalyst has a very active community. Here are the main places to
1128 get in touch with us.</p>
16215972 1129 <ul>
1130 <li>
2b9a7d76 1131 <a href="http://dev.catalyst.perl.org">Wiki</a>
16215972 1132 </li>
1133 <li>
1134 <a href="http://lists.rawmode.org/mailman/listinfo/catalyst">Mailing-List</a>
1135 </li>
1136 <li>
4eaf7c88 1137 <a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
16215972 1138 </li>
1139 </ul>
ab2374d3 1140 <h2>In conclusion</h2>
a7caa492 1141 <p>The Catalyst team hopes you will enjoy using Catalyst as much
f5681c92 1142 as we enjoyed making it. Please contact us if you have ideas
1143 for improvement or other feedback.</p>
ab2374d3 1144 </div>
1145 </div>
1146 </body>
1147</html>
1148EOF
1149}
1150
fbcc39ad 1151=head1 INTERNAL METHODS
1152
ae1e6b59 1153These methods are not meant to be used by end users.
1154
b5ecfcf0 1155=head2 $c->components
fbcc39ad 1156
e7f1cf73 1157Returns a hash of components.
fbcc39ad 1158
b5ecfcf0 1159=head2 $c->context_class
1f9cb7c1 1160
e7f1cf73 1161Returns or sets the context class.
1f9cb7c1 1162
b5ecfcf0 1163=head2 $c->counter
fbcc39ad 1164
ae1e6b59 1165Returns a hashref containing coderefs and execution counts (needed for
1166deep recursion detection).
fbcc39ad 1167
b5ecfcf0 1168=head2 $c->depth
fbcc39ad 1169
e7f1cf73 1170Returns the number of actions on the current internal execution stack.
fbcc39ad 1171
b5ecfcf0 1172=head2 $c->dispatch
fbcc39ad 1173
e7f1cf73 1174Dispatches a request to actions.
fbcc39ad 1175
1176=cut
1177
1178sub dispatch { my $c = shift; $c->dispatcher->dispatch( $c, @_ ) }
1179
b5ecfcf0 1180=head2 $c->dispatcher_class
1f9cb7c1 1181
e7f1cf73 1182Returns or sets the dispatcher class.
1f9cb7c1 1183
b5ecfcf0 1184=head2 $c->dump_these
7f92deef 1185
ae1e6b59 1186Returns a list of 2-element array references (name, structure) pairs
1187that will be dumped on the error page in debug mode.
7f92deef 1188
1189=cut
1190
1191sub dump_these {
1192 my $c = shift;
a7caa492 1193 [ Request => $c->req ],
1194 [ Response => $c->res ],
052a2d89 1195 [ Stash => $c->stash ],
1196 [ Config => $c->config ];
7f92deef 1197}
1198
b5ecfcf0 1199=head2 $c->engine_class
1f9cb7c1 1200
e7f1cf73 1201Returns or sets the engine class.
1f9cb7c1 1202
b5ecfcf0 1203=head2 $c->execute( $class, $coderef )
fbcc39ad 1204
0ef52a96 1205Execute a coderef in given class and catch exceptions. Errors are available
1206via $c->error.
fbcc39ad 1207
1208=cut
1209
1210sub execute {
1211 my ( $c, $class, $code ) = @_;
858828dd 1212 $class = $c->component($class) || $class;
fbcc39ad 1213 $c->state(0);
a0eca838 1214
197bd788 1215 if ( $c->depth >= $RECURSION ) {
1627551a 1216 my $action = "$code";
91d08727 1217 $action = "/$action" unless $action =~ /->/;
1627551a 1218 my $error = qq/Deep recursion detected calling "$action"/;
1219 $c->log->error($error);
1220 $c->error($error);
1221 $c->state(0);
1222 return $c->state;
1223 }
1224
dc5f035e 1225 my $stats_info = $c->_stats_start_execute( $code ) if $c->use_stats;
22247e54 1226
8767c5a3 1227 push( @{ $c->stack }, $code );
a7caa492 1228
245ae014 1229 eval { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) };
22247e54 1230
dc5f035e 1231 $c->_stats_finish_execute( $stats_info ) if $c->use_stats and $stats_info;
a7caa492 1232
a6724a82 1233 my $last = pop( @{ $c->stack } );
fbcc39ad 1234
1235 if ( my $error = $@ ) {
88879e92 1236 if ( !ref($error) and $error eq $DETACH ) { die $DETACH if $c->depth > 1 }
fbcc39ad 1237 else {
1238 unless ( ref $error ) {
91d08727 1239 no warnings 'uninitialized';
fbcc39ad 1240 chomp $error;
f59def82 1241 my $class = $last->class;
1242 my $name = $last->name;
1243 $error = qq/Caught exception in $class->$name "$error"/;
fbcc39ad 1244 }
fbcc39ad 1245 $c->error($error);
1246 $c->state(0);
1247 }
1248 }
1249 return $c->state;
1250}
1251
7a7d7af5 1252sub _stats_start_execute {
1253 my ( $c, $code ) = @_;
1254
a6724a82 1255 return if ( ( $code->name =~ /^_.*/ )
1256 && ( !$c->config->{show_internal_actions} ) );
7a7d7af5 1257
7a7d7af5 1258 $c->counter->{"$code"}++;
1259
a6724a82 1260 my $action = "$code";
1261 $action = "/$action" unless $action =~ /->/;
1262
7a7d7af5 1263 # determine if the call was the result of a forward
1264 # this is done by walking up the call stack and looking for a calling
1265 # sub of Catalyst::forward before the eval
1266 my $callsub = q{};
1267 for my $index ( 2 .. 11 ) {
1268 last
1269 if ( ( caller($index) )[0] eq 'Catalyst'
1270 && ( caller($index) )[3] eq '(eval)' );
1271
1272 if ( ( caller($index) )[3] =~ /forward$/ ) {
1273 $callsub = ( caller($index) )[3];
1274 $action = "-> $action";
1275 last;
1276 }
1277 }
1278
74efc144 1279 my $uid = "$code" . $c->counter->{"$code"};
1280
a6724a82 1281 # is this a root-level call or a forwarded call?
1282 if ( $callsub =~ /forward$/ ) {
1283
1284 # forward, locate the caller
1285 if ( my $parent = $c->stack->[-1] ) {
69d8f33c 1286 $c->stats->profile(
a7caa492 1287 begin => $action,
69d8f33c 1288 parent => "$parent" . $c->counter->{"$parent"},
1289 uid => $uid,
1290 );
7a7d7af5 1291 }
1292 else {
1293
a6724a82 1294 # forward with no caller may come from a plugin
69d8f33c 1295 $c->stats->profile(
1296 begin => $action,
1297 uid => $uid,
1298 );
7a7d7af5 1299 }
1300 }
a6724a82 1301 else {
a7caa492 1302
a6724a82 1303 # root-level call
69d8f33c 1304 $c->stats->profile(
1305 begin => $action,
1306 uid => $uid,
1307 );
a6724a82 1308 }
dc5f035e 1309 return $action;
7a7d7af5 1310
7a7d7af5 1311}
1312
1313sub _stats_finish_execute {
1314 my ( $c, $info ) = @_;
69d8f33c 1315 $c->stats->profile( end => $info );
7a7d7af5 1316}
1317
3d0d6d21 1318=head2 $c->_localize_fields( sub { }, \%keys );
1319
1320=cut
1321
1322sub _localize_fields {
1323 my ( $c, $localized, $code ) = ( @_ );
1324
1325 my $request = delete $localized->{request} || {};
1326 my $response = delete $localized->{response} || {};
a7caa492 1327
3d0d6d21 1328 local @{ $c }{ keys %$localized } = values %$localized;
1329 local @{ $c->request }{ keys %$request } = values %$request;
1330 local @{ $c->response }{ keys %$response } = values %$response;
1331
1332 $code->();
1333}
1334
b5ecfcf0 1335=head2 $c->finalize
fbcc39ad 1336
e7f1cf73 1337Finalizes the request.
fbcc39ad 1338
1339=cut
1340
1341sub finalize {
1342 my $c = shift;
1343
369c09bc 1344 for my $error ( @{ $c->error } ) {
1345 $c->log->error($error);
1346 }
1347
5050d7a7 1348 # Allow engine to handle finalize flow (for POE)
1349 if ( $c->engine->can('finalize') ) {
34d28dfd 1350 $c->engine->finalize($c);
fbcc39ad 1351 }
5050d7a7 1352 else {
fbcc39ad 1353
5050d7a7 1354 $c->finalize_uploads;
fbcc39ad 1355
5050d7a7 1356 # Error
1357 if ( $#{ $c->error } >= 0 ) {
1358 $c->finalize_error;
1359 }
1360
1361 $c->finalize_headers;
fbcc39ad 1362
5050d7a7 1363 # HEAD request
1364 if ( $c->request->method eq 'HEAD' ) {
1365 $c->response->body('');
1366 }
1367
1368 $c->finalize_body;
1369 }
a7caa492 1370
1371 if ($c->use_stats) {
596677b6 1372 my $elapsed = sprintf '%f', $c->stats->elapsed;
12bf12c0 1373 my $av = $elapsed == 0 ? '??' : sprintf '%.3f', 1 / $elapsed;
908e3d9e 1374 $c->log->info(
a7caa492 1375 "Request took ${elapsed}s ($av/s)\n" . $c->stats->report . "\n" );
908e3d9e 1376 }
fbcc39ad 1377
1378 return $c->response->status;
1379}
1380
b5ecfcf0 1381=head2 $c->finalize_body
fbcc39ad 1382
e7f1cf73 1383Finalizes body.
fbcc39ad 1384
1385=cut
1386
1387sub finalize_body { my $c = shift; $c->engine->finalize_body( $c, @_ ) }
1388
b5ecfcf0 1389=head2 $c->finalize_cookies
fbcc39ad 1390
e7f1cf73 1391Finalizes cookies.
fbcc39ad 1392
1393=cut
1394
147821ea 1395sub finalize_cookies { my $c = shift; $c->engine->finalize_cookies( $c, @_ ) }
fbcc39ad 1396
b5ecfcf0 1397=head2 $c->finalize_error
fbcc39ad 1398
e7f1cf73 1399Finalizes error.
fbcc39ad 1400
1401=cut
1402
1403sub finalize_error { my $c = shift; $c->engine->finalize_error( $c, @_ ) }
1404
b5ecfcf0 1405=head2 $c->finalize_headers
fbcc39ad 1406
e7f1cf73 1407Finalizes headers.
fbcc39ad 1408
1409=cut
1410
1411sub finalize_headers {
1412 my $c = shift;
1413
1414 # Check if we already finalized headers
1415 return if $c->response->{_finalized_headers};
1416
1417 # Handle redirects
1418 if ( my $location = $c->response->redirect ) {
1419 $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
1420 $c->response->header( Location => $location );
a7caa492 1421
39655cdc 1422 if ( !$c->response->body ) {
1423 # Add a default body if none is already present
1424 $c->response->body(
e422816e 1425 qq{<html><body><p>This item has moved <a href="$location">here</a>.</p></body></html>}
39655cdc 1426 );
1427 }
fbcc39ad 1428 }
1429
1430 # Content-Length
1431 if ( $c->response->body && !$c->response->content_length ) {
775878ac 1432
8f62c91a 1433 # get the length from a filehandle
197bd788 1434 if ( blessed( $c->response->body ) && $c->response->body->can('read') )
1435 {
3b6a1db1 1436 my $stat = stat $c->response->body;
1437 if ( $stat && $stat->size > 0 ) {
8f62c91a 1438 $c->response->content_length( $stat->size );
1439 }
1440 else {
775878ac 1441 $c->log->warn('Serving filehandle without a content-length');
8f62c91a 1442 }
1443 }
1444 else {
b5d7a61f 1445 # everything should be bytes at this point, but just in case
775878ac 1446 $c->response->content_length( bytes::length( $c->response->body ) );
8f62c91a 1447 }
fbcc39ad 1448 }
1449
1450 # Errors
1451 if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
1452 $c->response->headers->remove_header("Content-Length");
1453 $c->response->body('');
1454 }
1455
1456 $c->finalize_cookies;
1457
1458 $c->engine->finalize_headers( $c, @_ );
1459
1460 # Done
1461 $c->response->{_finalized_headers} = 1;
1462}
1463
b5ecfcf0 1464=head2 $c->finalize_output
fbcc39ad 1465
1466An alias for finalize_body.
1467
b5ecfcf0 1468=head2 $c->finalize_read
fbcc39ad 1469
e7f1cf73 1470Finalizes the input after reading is complete.
fbcc39ad 1471
1472=cut
1473
1474sub finalize_read { my $c = shift; $c->engine->finalize_read( $c, @_ ) }
1475
b5ecfcf0 1476=head2 $c->finalize_uploads
fbcc39ad 1477
ae1e6b59 1478Finalizes uploads. Cleans up any temporary files.
fbcc39ad 1479
1480=cut
1481
1482sub finalize_uploads { my $c = shift; $c->engine->finalize_uploads( $c, @_ ) }
1483
b5ecfcf0 1484=head2 $c->get_action( $action, $namespace )
fbcc39ad 1485
e7f1cf73 1486Gets an action in a given namespace.
fbcc39ad 1487
1488=cut
1489
684d10ed 1490sub get_action { my $c = shift; $c->dispatcher->get_action(@_) }
fbcc39ad 1491
b5ecfcf0 1492=head2 $c->get_actions( $action, $namespace )
a9dc674c 1493
ae1e6b59 1494Gets all actions of a given name in a namespace and all parent
1495namespaces.
a9dc674c 1496
1497=cut
1498
1499sub get_actions { my $c = shift; $c->dispatcher->get_actions( $c, @_ ) }
1500
f7b672ef 1501=head2 $c->handle_request( $class, @arguments )
fbcc39ad 1502
e7f1cf73 1503Called to handle each HTTP request.
fbcc39ad 1504
1505=cut
1506
1507sub handle_request {
1508 my ( $class, @arguments ) = @_;
1509
1510 # Always expect worst case!
1511 my $status = -1;
1512 eval {
dea1884f 1513 if ($class->debug) {
908e3d9e 1514 my $secs = time - $START || 1;
1515 my $av = sprintf '%.3f', $COUNT / $secs;
1516 my $time = localtime time;
1517 $class->log->info("*** Request $COUNT ($av/s) [$$] [$time] ***");
dea1884f 1518 }
908e3d9e 1519
1520 my $c = $class->prepare(@arguments);
1521 $c->dispatch;
a7caa492 1522 $status = $c->finalize;
fbcc39ad 1523 };
1524
1525 if ( my $error = $@ ) {
1526 chomp $error;
1527 $class->log->error(qq/Caught exception in engine "$error"/);
1528 }
1529
1530 $COUNT++;
1531 $class->log->_flush() if $class->log->can('_flush');
1532 return $status;
1533}
1534
b5ecfcf0 1535=head2 $c->prepare( @arguments )
fbcc39ad 1536
ae1e6b59 1537Creates a Catalyst context from an engine-specific request (Apache, CGI,
1538etc.).
fbcc39ad 1539
1540=cut
1541
1542sub prepare {
1543 my ( $class, @arguments ) = @_;
1544
3cec521a 1545 $class->context_class( ref $class || $class ) unless $class->context_class;
1546 my $c = $class->context_class->new(
1547 {
1548 counter => {},
28591cd7 1549 stack => [],
3cec521a 1550 request => $class->request_class->new(
1551 {
1552 arguments => [],
1553 body_parameters => {},
1554 cookies => {},
1555 headers => HTTP::Headers->new,
1556 parameters => {},
1557 query_parameters => {},
1558 secure => 0,
2982e768 1559 captures => [],
3cec521a 1560 uploads => {}
1561 }
1562 ),
1563 response => $class->response_class->new(
1564 {
1565 body => '',
1566 cookies => {},
1567 headers => HTTP::Headers->new(),
1568 status => 200
1569 }
1570 ),
1571 stash => {},
1572 state => 0
1573 }
1574 );
fbcc39ad 1575
dc5f035e 1576 $c->stats($class->stats_class->new)->enable($c->use_stats);
908e3d9e 1577 if ( $c->debug ) {
a7caa492 1578 $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
908e3d9e 1579 }
1580
fbcc39ad 1581 # For on-demand data
059c085b 1582 $c->request->_context($c);
1583 $c->response->_context($c);
fbcc39ad 1584
5050d7a7 1585 # Allow engine to direct the prepare flow (for POE)
1586 if ( $c->engine->can('prepare') ) {
1587 $c->engine->prepare( $c, @arguments );
1588 }
1589 else {
1590 $c->prepare_request(@arguments);
1591 $c->prepare_connection;
1592 $c->prepare_query_parameters;
1593 $c->prepare_headers;
1594 $c->prepare_cookies;
1595 $c->prepare_path;
1596
878b821c 1597 # Prepare the body for reading, either by prepare_body
1598 # or the user, if they are using $c->read
1599 $c->prepare_read;
a7caa492 1600
878b821c 1601 # Parse the body unless the user wants it on-demand
1602 unless ( $c->config->{parse_on_demand} ) {
1603 $c->prepare_body;
1604 }
5050d7a7 1605 }
fbcc39ad 1606
fbcc39ad 1607 my $method = $c->req->method || '';
34d28dfd 1608 my $path = $c->req->path || '/';
fbcc39ad 1609 my $address = $c->req->address || '';
1610
e3a13771 1611 $c->log->debug(qq/"$method" request for "$path" from "$address"/)
fbcc39ad 1612 if $c->debug;
1613
e3a13771 1614 $c->prepare_action;
1615
fbcc39ad 1616 return $c;
1617}
1618
b5ecfcf0 1619=head2 $c->prepare_action
fbcc39ad 1620
b4b01a8a 1621Prepares action. See L<Catalyst::Dispatcher>.
fbcc39ad 1622
1623=cut
1624
1625sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
1626
b5ecfcf0 1627=head2 $c->prepare_body
fbcc39ad 1628
e7f1cf73 1629Prepares message body.
fbcc39ad 1630
1631=cut
1632
1633sub prepare_body {
1634 my $c = shift;
1635
1636 # Do we run for the first time?
1637 return if defined $c->request->{_body};
1638
1639 # Initialize on-demand data
1640 $c->engine->prepare_body( $c, @_ );
1641 $c->prepare_parameters;
1642 $c->prepare_uploads;
1643
1644 if ( $c->debug && keys %{ $c->req->body_parameters } ) {
34d28dfd 1645 my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ 36, 'Value' ] );
fbcc39ad 1646 for my $key ( sort keys %{ $c->req->body_parameters } ) {
1647 my $param = $c->req->body_parameters->{$key};
1648 my $value = defined($param) ? $param : '';
8c113188 1649 $t->row( $key,
fbcc39ad 1650 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1651 }
1652 $c->log->debug( "Body Parameters are:\n" . $t->draw );
1653 }
1654}
1655
b5ecfcf0 1656=head2 $c->prepare_body_chunk( $chunk )
4bd82c41 1657
e7f1cf73 1658Prepares a chunk of data before sending it to L<HTTP::Body>.
4bd82c41 1659
b4b01a8a 1660See L<Catalyst::Engine>.
1661
4bd82c41 1662=cut
1663
4f5ebacd 1664sub prepare_body_chunk {
1665 my $c = shift;
4bd82c41 1666 $c->engine->prepare_body_chunk( $c, @_ );
1667}
1668
b5ecfcf0 1669=head2 $c->prepare_body_parameters
fbcc39ad 1670
e7f1cf73 1671Prepares body parameters.
fbcc39ad 1672
1673=cut
1674
1675sub prepare_body_parameters {
1676 my $c = shift;
1677 $c->engine->prepare_body_parameters( $c, @_ );
1678}
1679
b5ecfcf0 1680=head2 $c->prepare_connection
fbcc39ad 1681
e7f1cf73 1682Prepares connection.
fbcc39ad 1683
1684=cut
1685
1686sub prepare_connection {
1687 my $c = shift;
1688 $c->engine->prepare_connection( $c, @_ );
1689}
1690
b5ecfcf0 1691=head2 $c->prepare_cookies
fbcc39ad 1692
e7f1cf73 1693Prepares cookies.
fbcc39ad 1694
1695=cut
1696
1697sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
1698
b5ecfcf0 1699=head2 $c->prepare_headers
fbcc39ad 1700
e7f1cf73 1701Prepares headers.
fbcc39ad 1702
1703=cut
1704
1705sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
1706
b5ecfcf0 1707=head2 $c->prepare_parameters
fbcc39ad 1708
e7f1cf73 1709Prepares parameters.
fbcc39ad 1710
1711=cut
1712
1713sub prepare_parameters {
1714 my $c = shift;
1715 $c->prepare_body_parameters;
1716 $c->engine->prepare_parameters( $c, @_ );
1717}
1718
b5ecfcf0 1719=head2 $c->prepare_path
fbcc39ad 1720
e7f1cf73 1721Prepares path and base.
fbcc39ad 1722
1723=cut
1724
1725sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
1726
b5ecfcf0 1727=head2 $c->prepare_query_parameters
fbcc39ad 1728
e7f1cf73 1729Prepares query parameters.
fbcc39ad 1730
1731=cut
1732
1733sub prepare_query_parameters {
1734 my $c = shift;
1735
1736 $c->engine->prepare_query_parameters( $c, @_ );
1737
1738 if ( $c->debug && keys %{ $c->request->query_parameters } ) {
34d28dfd 1739 my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ 36, 'Value' ] );
fbcc39ad 1740 for my $key ( sort keys %{ $c->req->query_parameters } ) {
1741 my $param = $c->req->query_parameters->{$key};
1742 my $value = defined($param) ? $param : '';
8c113188 1743 $t->row( $key,
fbcc39ad 1744 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1745 }
1746 $c->log->debug( "Query Parameters are:\n" . $t->draw );
1747 }
1748}
1749
b5ecfcf0 1750=head2 $c->prepare_read
fbcc39ad 1751
e7f1cf73 1752Prepares the input for reading.
fbcc39ad 1753
1754=cut
1755
1756sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
1757
b5ecfcf0 1758=head2 $c->prepare_request
fbcc39ad 1759
e7f1cf73 1760Prepares the engine request.
fbcc39ad 1761
1762=cut
1763
1764sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
1765
b5ecfcf0 1766=head2 $c->prepare_uploads
fbcc39ad 1767
e7f1cf73 1768Prepares uploads.
fbcc39ad 1769
1770=cut
1771
1772sub prepare_uploads {
1773 my $c = shift;
1774
1775 $c->engine->prepare_uploads( $c, @_ );
1776
1777 if ( $c->debug && keys %{ $c->request->uploads } ) {
8c113188 1778 my $t = Text::SimpleTable->new(
34d28dfd 1779 [ 12, 'Parameter' ],
1780 [ 26, 'Filename' ],
8c113188 1781 [ 18, 'Type' ],
1782 [ 9, 'Size' ]
1783 );
fbcc39ad 1784 for my $key ( sort keys %{ $c->request->uploads } ) {
1785 my $upload = $c->request->uploads->{$key};
1786 for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
8c113188 1787 $t->row( $key, $u->filename, $u->type, $u->size );
fbcc39ad 1788 }
1789 }
1790 $c->log->debug( "File Uploads are:\n" . $t->draw );
1791 }
1792}
1793
b5ecfcf0 1794=head2 $c->prepare_write
fbcc39ad 1795
e7f1cf73 1796Prepares the output for writing.
fbcc39ad 1797
1798=cut
1799
1800sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
1801
b5ecfcf0 1802=head2 $c->request_class
1f9cb7c1 1803
e7f1cf73 1804Returns or sets the request class.
1f9cb7c1 1805
b5ecfcf0 1806=head2 $c->response_class
1f9cb7c1 1807
e7f1cf73 1808Returns or sets the response class.
1f9cb7c1 1809
b5ecfcf0 1810=head2 $c->read( [$maxlength] )
fbcc39ad 1811
ae1e6b59 1812Reads a chunk of data from the request body. This method is designed to
1813be used in a while loop, reading C<$maxlength> bytes on every call.
1814C<$maxlength> defaults to the size of the request if not specified.
fbcc39ad 1815
cc95842f 1816You have to set C<< MyApp->config->{parse_on_demand} >> to use this
ae1e6b59 1817directly.
fbcc39ad 1818
878b821c 1819Warning: If you use read(), Catalyst will not process the body,
1820so you will not be able to access POST parameters or file uploads via
1821$c->request. You must handle all body parsing yourself.
1822
fbcc39ad 1823=cut
1824
1825sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
1826
b5ecfcf0 1827=head2 $c->run
fbcc39ad 1828
1829Starts the engine.
1830
1831=cut
1832
1833sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
1834
b5ecfcf0 1835=head2 $c->set_action( $action, $code, $namespace, $attrs )
fbcc39ad 1836
e7f1cf73 1837Sets an action in a given namespace.
fbcc39ad 1838
1839=cut
1840
1841sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
1842
b5ecfcf0 1843=head2 $c->setup_actions($component)
fbcc39ad 1844
e7f1cf73 1845Sets up actions for a component.
fbcc39ad 1846
1847=cut
1848
1849sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
1850
b5ecfcf0 1851=head2 $c->setup_components
fbcc39ad 1852
86418559 1853Sets up components. Specify a C<setup_components> config option to pass
1854additional options directly to L<Module::Pluggable>. To add additional
1855search paths, specify a key named C<search_extra> as an array
1856reference. Items in the array beginning with C<::> will have the
18de900e 1857application class name prepended to them.
fbcc39ad 1858
1859=cut
1860
1861sub setup_components {
1862 my $class = shift;
1863
18de900e 1864 my @paths = qw( ::Controller ::C ::Model ::M ::View ::V );
1865 my $config = $class->config->{ setup_components };
1866 my $extra = delete $config->{ search_extra } || [];
a7caa492 1867
18de900e 1868 push @paths, @$extra;
a7caa492 1869
364d7324 1870 my $locator = Module::Pluggable::Object->new(
18de900e 1871 search_path => [ map { s/^(?=::)/$class/; $_; } @paths ],
1872 %$config
364d7324 1873 );
b94b200c 1874
1875 my @comps = sort { length $a <=> length $b } $locator->plugins;
1876 my %comps = map { $_ => 1 } @comps;
a7caa492 1877
b94b200c 1878 for my $component ( @comps ) {
dd91afb5 1879
1880 # We pass ignore_loaded here so that overlay files for (e.g.)
1881 # Model::DBI::Schema sub-classes are loaded - if it's in @comps
1882 # we know M::P::O found a file on disk so this is safe
1883
5fb67d52 1884 #Catalyst::Utils::ensure_class_loaded( $component, { ignore_loaded => 1 } );
1885 Class::MOP::load_class($component);
364d7324 1886
1887 my $module = $class->setup_component( $component );
1888 my %modules = (
1889 $component => $module,
1890 map {
1891 $_ => $class->setup_component( $_ )
a7caa492 1892 } grep {
b94b200c 1893 not exists $comps{$_}
364d7324 1894 } Devel::InnerPackage::list_packages( $component )
1895 );
a7caa492 1896
364d7324 1897 for my $key ( keys %modules ) {
1898 $class->components->{ $key } = $modules{ $key };
fbcc39ad 1899 }
364d7324 1900 }
1901}
fbcc39ad 1902
364d7324 1903=head2 $c->setup_component
fbcc39ad 1904
364d7324 1905=cut
fbcc39ad 1906
364d7324 1907sub setup_component {
1908 my( $class, $component ) = @_;
fbcc39ad 1909
364d7324 1910 unless ( $component->can( 'COMPONENT' ) ) {
1911 return $component;
1912 }
fbcc39ad 1913
364d7324 1914 my $suffix = Catalyst::Utils::class2classsuffix( $component );
1915 my $config = $class->config->{ $suffix } || {};
fbcc39ad 1916
364d7324 1917 my $instance = eval { $component->COMPONENT( $class, $config ); };
fbcc39ad 1918
1919 if ( my $error = $@ ) {
fbcc39ad 1920 chomp $error;
fbcc39ad 1921 Catalyst::Exception->throw(
364d7324 1922 message => qq/Couldn't instantiate component "$component", "$error"/
1923 );
fbcc39ad 1924 }
1925
364d7324 1926 Catalyst::Exception->throw(
1927 message =>
1928 qq/Couldn't instantiate component "$component", "COMPONENT() didn't return an object-like value"/
1929 ) unless eval { $instance->can( 'can' ) };
1930
1931 return $instance;
fbcc39ad 1932}
1933
b5ecfcf0 1934=head2 $c->setup_dispatcher
fbcc39ad 1935
ae1e6b59 1936Sets up dispatcher.
1937
fbcc39ad 1938=cut
1939
1940sub setup_dispatcher {
1941 my ( $class, $dispatcher ) = @_;
1942
1943 if ($dispatcher) {
1944 $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
1945 }
1946
cb69249e 1947 if ( my $env = Catalyst::Utils::env_value( $class, 'DISPATCHER' ) ) {
1948 $dispatcher = 'Catalyst::Dispatcher::' . $env;
fbcc39ad 1949 }
1950
1951 unless ($dispatcher) {
cb0354c6 1952 $dispatcher = $class->dispatcher_class;
fbcc39ad 1953 }
1954
1e514a51 1955 unless (Class::Inspector->loaded($dispatcher)) {
1956 require Class::Inspector->filename($dispatcher);
fbcc39ad 1957 }
1958
1959 # dispatcher instance
1960 $class->dispatcher( $dispatcher->new );
1961}
1962
b5ecfcf0 1963=head2 $c->setup_engine
fbcc39ad 1964
ae1e6b59 1965Sets up engine.
1966
fbcc39ad 1967=cut
1968
1969sub setup_engine {
1970 my ( $class, $engine ) = @_;
1971
1972 if ($engine) {
1973 $engine = 'Catalyst::Engine::' . $engine;
1974 }
1975
cb69249e 1976 if ( my $env = Catalyst::Utils::env_value( $class, 'ENGINE' ) ) {
1977 $engine = 'Catalyst::Engine::' . $env;
fbcc39ad 1978 }
1979
9b0a3e0f 1980 if ( $ENV{MOD_PERL} ) {
fbcc39ad 1981
1982 # create the apache method
1983 {
1984 no strict 'refs';
1985 *{"$class\::apache"} = sub { shift->engine->apache };
1986 }
1987
1988 my ( $software, $version ) =
1989 $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
1990
1991 $version =~ s/_//g;
1992 $version =~ s/(\.[^.]+)\./$1/g;
1993
1994 if ( $software eq 'mod_perl' ) {
1995
9b0a3e0f 1996 if ( !$engine ) {
22247e54 1997
9b0a3e0f 1998 if ( $version >= 1.99922 ) {
1999 $engine = 'Catalyst::Engine::Apache2::MP20';
2000 }
22247e54 2001
9b0a3e0f 2002 elsif ( $version >= 1.9901 ) {
2003 $engine = 'Catalyst::Engine::Apache2::MP19';
2004 }
22247e54 2005
9b0a3e0f 2006 elsif ( $version >= 1.24 ) {
2007 $engine = 'Catalyst::Engine::Apache::MP13';
2008 }
22247e54 2009
9b0a3e0f 2010 else {
2011 Catalyst::Exception->throw( message =>
2012 qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
2013 }
fbcc39ad 2014
fbcc39ad 2015 }
2016
2017 # install the correct mod_perl handler
2018 if ( $version >= 1.9901 ) {
2019 *handler = sub : method {
2020 shift->handle_request(@_);
2021 };
2022 }
2023 else {
2024 *handler = sub ($$) { shift->handle_request(@_) };
2025 }
2026
2027 }
2028
2029 elsif ( $software eq 'Zeus-Perl' ) {
2030 $engine = 'Catalyst::Engine::Zeus';
2031 }
2032
2033 else {
2034 Catalyst::Exception->throw(
2035 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
2036 }
2037 }
2038
2039 unless ($engine) {
cb0354c6 2040 $engine = $class->engine_class;
fbcc39ad 2041 }
2042
1e514a51 2043 unless (Class::Inspector->loaded($engine)) {
2044 require Class::Inspector->filename($engine);
fbcc39ad 2045 }
0e7f5826 2046
d54484bf 2047 # check for old engines that are no longer compatible
2048 my $old_engine;
0e7f5826 2049 if ( $engine->isa('Catalyst::Engine::Apache')
2050 && !Catalyst::Engine::Apache->VERSION )
d54484bf 2051 {
2052 $old_engine = 1;
2053 }
0e7f5826 2054
d54484bf 2055 elsif ( $engine->isa('Catalyst::Engine::Server::Base')
0e7f5826 2056 && Catalyst::Engine::Server->VERSION le '0.02' )
d54484bf 2057 {
2058 $old_engine = 1;
2059 }
0e7f5826 2060
2061 elsif ($engine->isa('Catalyst::Engine::HTTP::POE')
2062 && $engine->VERSION eq '0.01' )
d54484bf 2063 {
2064 $old_engine = 1;
2065 }
0e7f5826 2066
2067 elsif ($engine->isa('Catalyst::Engine::Zeus')
2068 && $engine->VERSION eq '0.01' )
d54484bf 2069 {
2070 $old_engine = 1;
2071 }
fbcc39ad 2072
d54484bf 2073 if ($old_engine) {
2074 Catalyst::Exception->throw( message =>
0e7f5826 2075 qq/Engine "$engine" is not supported by this version of Catalyst/
d54484bf 2076 );
2077 }
0e7f5826 2078
fbcc39ad 2079 # engine instance
2080 $class->engine( $engine->new );
2081}
2082
b5ecfcf0 2083=head2 $c->setup_home
fbcc39ad 2084
ae1e6b59 2085Sets up the home directory.
2086
fbcc39ad 2087=cut
2088
2089sub setup_home {
2090 my ( $class, $home ) = @_;
2091
cb69249e 2092 if ( my $env = Catalyst::Utils::env_value( $class, 'HOME' ) ) {
2093 $home = $env;
fbcc39ad 2094 }
2095
2096 unless ($home) {
2097 $home = Catalyst::Utils::home($class);
2098 }
2099
2100 if ($home) {
2101 $class->config->{home} ||= $home;
a738ab68 2102 $class->config->{root} ||= Path::Class::Dir->new($home)->subdir('root');
fbcc39ad 2103 }
2104}
2105
b5ecfcf0 2106=head2 $c->setup_log
fbcc39ad 2107
ae1e6b59 2108Sets up log.
2109
fbcc39ad 2110=cut
2111
2112sub setup_log {
2113 my ( $class, $debug ) = @_;
2114
2115 unless ( $class->log ) {
2116 $class->log( Catalyst::Log->new );
2117 }
af3ff00e 2118
cb69249e 2119 my $env_debug = Catalyst::Utils::env_value( $class, 'DEBUG' );
2120 if ( defined($env_debug) ? $env_debug : $debug ) {
fbcc39ad 2121 no strict 'refs';
2122 *{"$class\::debug"} = sub { 1 };
2123 $class->log->debug('Debug messages enabled');
2124 }
2125}
2126
b5ecfcf0 2127=head2 $c->setup_plugins
fbcc39ad 2128
ae1e6b59 2129Sets up plugins.
2130
fbcc39ad 2131=cut
2132
dc5f035e 2133=head2 $c->setup_stats
2134
2135Sets up timing statistics class.
2136
2137=cut
2138
2139sub setup_stats {
2140 my ( $class, $stats ) = @_;
2141
2142 Catalyst::Utils::ensure_class_loaded($class->stats_class);
2143
2144 my $env = Catalyst::Utils::env_value( $class, 'STATS' );
2145 if ( defined($env) ? $env : ($stats || $class->debug ) ) {
b01f0c69 2146 no strict 'refs';
2147 *{"$class\::use_stats"} = sub { 1 };
2148 $class->log->debug('Statistics enabled');
dc5f035e 2149 }
2150}
2151
2152
a7caa492 2153=head2 $c->registered_plugins
836e1134 2154
2155Returns a sorted list of the plugins which have either been stated in the
2156import list or which have been added via C<< MyApp->plugin(@args); >>.
2157
2158If passed a given plugin name, it will report a boolean value indicating
2159whether or not that plugin is loaded. A fully qualified name is required if
2160the plugin name does not begin with C<Catalyst::Plugin::>.
2161
2162 if ($c->registered_plugins('Some::Plugin')) {
2163 ...
2164 }
2165
2166=cut
fbcc39ad 2167
836e1134 2168{
97b58e17 2169
2170 sub registered_plugins {
836e1134 2171 my $proto = shift;
197bd788 2172 return sort keys %{ $proto->_plugins } unless @_;
836e1134 2173 my $plugin = shift;
d0d4d785 2174 return 1 if exists $proto->_plugins->{$plugin};
2175 return exists $proto->_plugins->{"Catalyst::Plugin::$plugin"};
836e1134 2176 }
fbcc39ad 2177
836e1134 2178 sub _register_plugin {
2179 my ( $proto, $plugin, $instant ) = @_;
2180 my $class = ref $proto || $proto;
fbcc39ad 2181
dd91afb5 2182 # no ignore_loaded here, the plugin may already have been
2183 # defined in memory and we don't want to error on "no file" if so
2184
2185 Catalyst::Utils::ensure_class_loaded( $plugin );
fbcc39ad 2186
197bd788 2187 $proto->_plugins->{$plugin} = 1;
836e1134 2188 unless ($instant) {
fbcc39ad 2189 no strict 'refs';
5fb67d52 2190 if( $class->can('meta') ){
2191 my @superclasses = ($plugin, $class->meta->superclasses );
2192 $class->meta->superclasses(@superclasses);
2193 } else {
2194 unshift @{"$class\::ISA"}, $plugin;
2195 }
fbcc39ad 2196 }
836e1134 2197 return $class;
2198 }
2199
2200 sub setup_plugins {
2201 my ( $class, $plugins ) = @_;
2202
d0d4d785 2203 $class->_plugins( {} ) unless $class->_plugins;
836e1134 2204 $plugins ||= [];
2205 for my $plugin ( reverse @$plugins ) {
2206
2207 unless ( $plugin =~ s/\A\+// ) {
2208 $plugin = "Catalyst::Plugin::$plugin";
2209 }
2210
2211 $class->_register_plugin($plugin);
2212 }
fbcc39ad 2213 }
2214}
2215
b5ecfcf0 2216=head2 $c->stack
8767c5a3 2217
86418559 2218Returns an arrayref of the internal execution stack (actions that are
2219currently executing).
8767c5a3 2220
dc5f035e 2221=head2 $c->stats_class
2222
2223Returns or sets the stats (timing statistics) class.
2224
2225=head2 $c->use_stats
2226
2227Returns 1 when stats collection is enabled. Stats collection is enabled
2228when the -Stats options is set, debug is on or when the <MYAPP>_STATS
2229environment variable is set.
2230
2231Note that this is a static method, not an accessor and should be overloaded
2232by declaring "sub use_stats { 1 }" in your MyApp.pm, not by calling $c->use_stats(1).
2233
2234=cut
2235
2236sub use_stats { 0 }
2237
2238
b5ecfcf0 2239=head2 $c->write( $data )
fbcc39ad 2240
ae1e6b59 2241Writes $data to the output stream. When using this method directly, you
2242will need to manually set the C<Content-Length> header to the length of
2243your output data, if known.
fbcc39ad 2244
2245=cut
2246
4f5ebacd 2247sub write {
2248 my $c = shift;
2249
2250 # Finalize headers if someone manually writes output
2251 $c->finalize_headers;
2252
2253 return $c->engine->write( $c, @_ );
2254}
fbcc39ad 2255
b5ecfcf0 2256=head2 version
bf88a181 2257
ae1e6b59 2258Returns the Catalyst version number. Mostly useful for "powered by"
2259messages in template systems.
bf88a181 2260
2261=cut
2262
2263sub version { return $Catalyst::VERSION }
2264
b0bb11ec 2265=head1 INTERNAL ACTIONS
2266
ae1e6b59 2267Catalyst uses internal actions like C<_DISPATCH>, C<_BEGIN>, C<_AUTO>,
2268C<_ACTION>, and C<_END>. These are by default not shown in the private
3e705254 2269action table, but you can make them visible with a config parameter.
b0bb11ec 2270
2271 MyApp->config->{show_internal_actions} = 1;
2272
d2ee9760 2273=head1 CASE SENSITIVITY
2274
3e705254 2275By default Catalyst is not case sensitive, so C<MyApp::C::FOO::Bar> is
ae1e6b59 2276mapped to C</foo/bar>. You can activate case sensitivity with a config
3e705254 2277parameter.
d2ee9760 2278
2279 MyApp->config->{case_sensitive} = 1;
2280
3e705254 2281This causes C<MyApp::C::Foo::Bar> to map to C</Foo/Bar>.
fbcc39ad 2282
2283=head1 ON-DEMAND PARSER
2284
2285The request body is usually parsed at the beginning of a request,
878b821c 2286but if you want to handle input yourself, you can enable on-demand
2287parsing with a config parameter.
fbcc39ad 2288
2289 MyApp->config->{parse_on_demand} = 1;
a7caa492 2290
fbcc39ad 2291=head1 PROXY SUPPORT
2292
ae1e6b59 2293Many production servers operate using the common double-server approach,
2294with a lightweight frontend web server passing requests to a larger
2295backend server. An application running on the backend server must deal
2296with two problems: the remote user always appears to be C<127.0.0.1> and
2297the server's hostname will appear to be C<localhost> regardless of the
2298virtual host that the user connected through.
fbcc39ad 2299
ae1e6b59 2300Catalyst will automatically detect this situation when you are running
2301the frontend and backend servers on the same machine. The following
2302changes are made to the request.
fbcc39ad 2303
a7caa492 2304 $c->req->address is set to the user's real IP address, as read from
ae1e6b59 2305 the HTTP X-Forwarded-For header.
a7caa492 2306
ae1e6b59 2307 The host value for $c->req->base and $c->req->uri is set to the real
2308 host, as read from the HTTP X-Forwarded-Host header.
fbcc39ad 2309
3e705254 2310Obviously, your web server must support these headers for this to work.
fbcc39ad 2311
ae1e6b59 2312In a more complex server farm environment where you may have your
2313frontend proxy server(s) on different machines, you will need to set a
2314configuration option to tell Catalyst to read the proxied data from the
2315headers.
fbcc39ad 2316
2317 MyApp->config->{using_frontend_proxy} = 1;
a7caa492 2318
fbcc39ad 2319If you do not wish to use the proxy support at all, you may set:
d1a31ac6 2320
fbcc39ad 2321 MyApp->config->{ignore_frontend_proxy} = 1;
2322
2323=head1 THREAD SAFETY
2324
86418559 2325Catalyst has been tested under Apache 2's threading C<mpm_worker>,
2326C<mpm_winnt>, and the standalone forking HTTP server on Windows. We
2327believe the Catalyst core to be thread-safe.
fbcc39ad 2328
2329If you plan to operate in a threaded environment, remember that all other
3e705254 2330modules you are using must also be thread-safe. Some modules, most notably
2331L<DBD::SQLite>, are not thread-safe.
d1a31ac6 2332
3cb1db8c 2333=head1 SUPPORT
2334
2335IRC:
2336
4eaf7c88 2337 Join #catalyst on irc.perl.org.
3cb1db8c 2338
3e705254 2339Mailing Lists:
3cb1db8c 2340
2341 http://lists.rawmode.org/mailman/listinfo/catalyst
2342 http://lists.rawmode.org/mailman/listinfo/catalyst-dev
1985c30b 2343
432d507d 2344Web:
2345
2346 http://catalyst.perl.org
2347
0ef52a96 2348Wiki:
2349
2350 http://dev.catalyst.perl.org
2351
fc7ec1d9 2352=head1 SEE ALSO
2353
829a28ca 2354=head2 L<Task::Catalyst> - All you need to start with Catalyst
2355
b5ecfcf0 2356=head2 L<Catalyst::Manual> - The Catalyst Manual
e7f1cf73 2357
b5ecfcf0 2358=head2 L<Catalyst::Component>, L<Catalyst::Base> - Base classes for components
61b1e958 2359
b5ecfcf0 2360=head2 L<Catalyst::Engine> - Core engine
61b1e958 2361
b5ecfcf0 2362=head2 L<Catalyst::Log> - Log class.
61b1e958 2363
b5ecfcf0 2364=head2 L<Catalyst::Request> - Request object
61b1e958 2365
b5ecfcf0 2366=head2 L<Catalyst::Response> - Response object
61b1e958 2367
b5ecfcf0 2368=head2 L<Catalyst::Test> - The test suite.
fc7ec1d9 2369
15f0b5b7 2370=head1 CREDITS
fc7ec1d9 2371
15f0b5b7 2372Andy Grundman
2373
fbcc39ad 2374Andy Wardley
2375
33108eaf 2376Andreas Marienborg
2377
f4a57de4 2378Andrew Bramble
2379
15f0b5b7 2380Andrew Ford
2381
2382Andrew Ruthven
2383
fbcc39ad 2384Arthur Bergman
2385
15f0b5b7 2386Autrijus Tang
2387
0cf56dbc 2388Brian Cassidy
2389
6aaa1c60 2390Carl Franks
2391
15f0b5b7 2392Christian Hansen
2393
2394Christopher Hicks
2395
2396Dan Sully
2397
2398Danijel Milicevic
2399
0ef52a96 2400David Kamholz
2401
15f0b5b7 2402David Naughton
2403
61bef238 2404Drew Taylor
2405
15f0b5b7 2406Gary Ashton Jones
2407
2408Geoff Richards
2409
2410Jesse Sheidlower
2411
fbcc39ad 2412Jesse Vincent
2413
15f0b5b7 2414Jody Belka
2415
2416Johan Lindstrom
2417
2418Juan Camacho
2419
2420Leon Brocard
2421
2422Marcus Ramberg
2423
2424Matt S Trout
2425
71c3bcc3 2426Robert Sedlacek
2427
a727119f 2428Sam Vilain
2429
1cf1c56a 2430Sascha Kiefer
2431
9c71d51d 2432Sebastian Willert
2433
15f0b5b7 2434Tatsuhiko Miyagawa
fc7ec1d9 2435
51f0308d 2436Ulf Edvinsson
2437
bdcb95ef 2438Yuval Kogman
2439
51f0308d 2440=head1 AUTHOR
2441
2442Sebastian Riedel, C<sri@oook.de>
2443
fc7ec1d9 2444=head1 LICENSE
2445
9ce5ab63 2446This library is free software, you can redistribute it and/or modify it under
41ca9ba7 2447the same terms as Perl itself.
fc7ec1d9 2448
2449=cut
2450
24511;