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