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