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