add warning in uri_for for undefined args
[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
e68d0062 66our $VERSION = '5.7008';
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
65d92e19 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];
f8ad6ea5 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>
80cdbbff 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) {
1356 my $elapsed = sprintf '%f', 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
1593 # On-demand parsing
1594 $c->prepare_body unless $c->config->{parse_on_demand};
1595 }
fbcc39ad 1596
fbcc39ad 1597 my $method = $c->req->method || '';
34d28dfd 1598 my $path = $c->req->path || '/';
fbcc39ad 1599 my $address = $c->req->address || '';
1600
e3a13771 1601 $c->log->debug(qq/"$method" request for "$path" from "$address"/)
fbcc39ad 1602 if $c->debug;
1603
e3a13771 1604 $c->prepare_action;
1605
fbcc39ad 1606 return $c;
1607}
1608
b5ecfcf0 1609=head2 $c->prepare_action
fbcc39ad 1610
b4b01a8a 1611Prepares action. See L<Catalyst::Dispatcher>.
fbcc39ad 1612
1613=cut
1614
1615sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
1616
b5ecfcf0 1617=head2 $c->prepare_body
fbcc39ad 1618
e7f1cf73 1619Prepares message body.
fbcc39ad 1620
1621=cut
1622
1623sub prepare_body {
1624 my $c = shift;
1625
1626 # Do we run for the first time?
1627 return if defined $c->request->{_body};
1628
1629 # Initialize on-demand data
1630 $c->engine->prepare_body( $c, @_ );
1631 $c->prepare_parameters;
1632 $c->prepare_uploads;
1633
1634 if ( $c->debug && keys %{ $c->req->body_parameters } ) {
34d28dfd 1635 my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ 36, 'Value' ] );
fbcc39ad 1636 for my $key ( sort keys %{ $c->req->body_parameters } ) {
1637 my $param = $c->req->body_parameters->{$key};
1638 my $value = defined($param) ? $param : '';
8c113188 1639 $t->row( $key,
fbcc39ad 1640 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1641 }
1642 $c->log->debug( "Body Parameters are:\n" . $t->draw );
1643 }
1644}
1645
b5ecfcf0 1646=head2 $c->prepare_body_chunk( $chunk )
4bd82c41 1647
e7f1cf73 1648Prepares a chunk of data before sending it to L<HTTP::Body>.
4bd82c41 1649
b4b01a8a 1650See L<Catalyst::Engine>.
1651
4bd82c41 1652=cut
1653
4f5ebacd 1654sub prepare_body_chunk {
1655 my $c = shift;
4bd82c41 1656 $c->engine->prepare_body_chunk( $c, @_ );
1657}
1658
b5ecfcf0 1659=head2 $c->prepare_body_parameters
fbcc39ad 1660
e7f1cf73 1661Prepares body parameters.
fbcc39ad 1662
1663=cut
1664
1665sub prepare_body_parameters {
1666 my $c = shift;
1667 $c->engine->prepare_body_parameters( $c, @_ );
1668}
1669
b5ecfcf0 1670=head2 $c->prepare_connection
fbcc39ad 1671
e7f1cf73 1672Prepares connection.
fbcc39ad 1673
1674=cut
1675
1676sub prepare_connection {
1677 my $c = shift;
1678 $c->engine->prepare_connection( $c, @_ );
1679}
1680
b5ecfcf0 1681=head2 $c->prepare_cookies
fbcc39ad 1682
e7f1cf73 1683Prepares cookies.
fbcc39ad 1684
1685=cut
1686
1687sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
1688
b5ecfcf0 1689=head2 $c->prepare_headers
fbcc39ad 1690
e7f1cf73 1691Prepares headers.
fbcc39ad 1692
1693=cut
1694
1695sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
1696
b5ecfcf0 1697=head2 $c->prepare_parameters
fbcc39ad 1698
e7f1cf73 1699Prepares parameters.
fbcc39ad 1700
1701=cut
1702
1703sub prepare_parameters {
1704 my $c = shift;
1705 $c->prepare_body_parameters;
1706 $c->engine->prepare_parameters( $c, @_ );
1707}
1708
b5ecfcf0 1709=head2 $c->prepare_path
fbcc39ad 1710
e7f1cf73 1711Prepares path and base.
fbcc39ad 1712
1713=cut
1714
1715sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
1716
b5ecfcf0 1717=head2 $c->prepare_query_parameters
fbcc39ad 1718
e7f1cf73 1719Prepares query parameters.
fbcc39ad 1720
1721=cut
1722
1723sub prepare_query_parameters {
1724 my $c = shift;
1725
1726 $c->engine->prepare_query_parameters( $c, @_ );
1727
1728 if ( $c->debug && keys %{ $c->request->query_parameters } ) {
34d28dfd 1729 my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ 36, 'Value' ] );
fbcc39ad 1730 for my $key ( sort keys %{ $c->req->query_parameters } ) {
1731 my $param = $c->req->query_parameters->{$key};
1732 my $value = defined($param) ? $param : '';
8c113188 1733 $t->row( $key,
fbcc39ad 1734 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1735 }
1736 $c->log->debug( "Query Parameters are:\n" . $t->draw );
1737 }
1738}
1739
b5ecfcf0 1740=head2 $c->prepare_read
fbcc39ad 1741
e7f1cf73 1742Prepares the input for reading.
fbcc39ad 1743
1744=cut
1745
1746sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
1747
b5ecfcf0 1748=head2 $c->prepare_request
fbcc39ad 1749
e7f1cf73 1750Prepares the engine request.
fbcc39ad 1751
1752=cut
1753
1754sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
1755
b5ecfcf0 1756=head2 $c->prepare_uploads
fbcc39ad 1757
e7f1cf73 1758Prepares uploads.
fbcc39ad 1759
1760=cut
1761
1762sub prepare_uploads {
1763 my $c = shift;
1764
1765 $c->engine->prepare_uploads( $c, @_ );
1766
1767 if ( $c->debug && keys %{ $c->request->uploads } ) {
8c113188 1768 my $t = Text::SimpleTable->new(
34d28dfd 1769 [ 12, 'Parameter' ],
1770 [ 26, 'Filename' ],
8c113188 1771 [ 18, 'Type' ],
1772 [ 9, 'Size' ]
1773 );
fbcc39ad 1774 for my $key ( sort keys %{ $c->request->uploads } ) {
1775 my $upload = $c->request->uploads->{$key};
1776 for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
8c113188 1777 $t->row( $key, $u->filename, $u->type, $u->size );
fbcc39ad 1778 }
1779 }
1780 $c->log->debug( "File Uploads are:\n" . $t->draw );
1781 }
1782}
1783
b5ecfcf0 1784=head2 $c->prepare_write
fbcc39ad 1785
e7f1cf73 1786Prepares the output for writing.
fbcc39ad 1787
1788=cut
1789
1790sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
1791
b5ecfcf0 1792=head2 $c->request_class
1f9cb7c1 1793
e7f1cf73 1794Returns or sets the request class.
1f9cb7c1 1795
b5ecfcf0 1796=head2 $c->response_class
1f9cb7c1 1797
e7f1cf73 1798Returns or sets the response class.
1f9cb7c1 1799
b5ecfcf0 1800=head2 $c->read( [$maxlength] )
fbcc39ad 1801
ae1e6b59 1802Reads a chunk of data from the request body. This method is designed to
1803be used in a while loop, reading C<$maxlength> bytes on every call.
1804C<$maxlength> defaults to the size of the request if not specified.
fbcc39ad 1805
cc95842f 1806You have to set C<< MyApp->config->{parse_on_demand} >> to use this
ae1e6b59 1807directly.
fbcc39ad 1808
1809=cut
1810
1811sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
1812
b5ecfcf0 1813=head2 $c->run
fbcc39ad 1814
1815Starts the engine.
1816
1817=cut
1818
1819sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
1820
b5ecfcf0 1821=head2 $c->set_action( $action, $code, $namespace, $attrs )
fbcc39ad 1822
e7f1cf73 1823Sets an action in a given namespace.
fbcc39ad 1824
1825=cut
1826
1827sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
1828
b5ecfcf0 1829=head2 $c->setup_actions($component)
fbcc39ad 1830
e7f1cf73 1831Sets up actions for a component.
fbcc39ad 1832
1833=cut
1834
1835sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
1836
b5ecfcf0 1837=head2 $c->setup_components
fbcc39ad 1838
86418559 1839Sets up components. Specify a C<setup_components> config option to pass
1840additional options directly to L<Module::Pluggable>. To add additional
1841search paths, specify a key named C<search_extra> as an array
1842reference. Items in the array beginning with C<::> will have the
18de900e 1843application class name prepended to them.
fbcc39ad 1844
1845=cut
1846
1847sub setup_components {
1848 my $class = shift;
1849
18de900e 1850 my @paths = qw( ::Controller ::C ::Model ::M ::View ::V );
1851 my $config = $class->config->{ setup_components };
1852 my $extra = delete $config->{ search_extra } || [];
1853
1854 push @paths, @$extra;
1855
364d7324 1856 my $locator = Module::Pluggable::Object->new(
18de900e 1857 search_path => [ map { s/^(?=::)/$class/; $_; } @paths ],
1858 %$config
364d7324 1859 );
b94b200c 1860
1861 my @comps = sort { length $a <=> length $b } $locator->plugins;
1862 my %comps = map { $_ => 1 } @comps;
364d7324 1863
b94b200c 1864 for my $component ( @comps ) {
d06051f7 1865 Catalyst::Utils::ensure_class_loaded( $component, { ignore_loaded => 1 } );
364d7324 1866
1867 my $module = $class->setup_component( $component );
1868 my %modules = (
1869 $component => $module,
1870 map {
1871 $_ => $class->setup_component( $_ )
b94b200c 1872 } grep {
1873 not exists $comps{$_}
364d7324 1874 } Devel::InnerPackage::list_packages( $component )
1875 );
1876
1877 for my $key ( keys %modules ) {
1878 $class->components->{ $key } = $modules{ $key };
fbcc39ad 1879 }
364d7324 1880 }
1881}
fbcc39ad 1882
364d7324 1883=head2 $c->setup_component
fbcc39ad 1884
364d7324 1885=cut
fbcc39ad 1886
364d7324 1887sub setup_component {
1888 my( $class, $component ) = @_;
fbcc39ad 1889
364d7324 1890 unless ( $component->can( 'COMPONENT' ) ) {
1891 return $component;
1892 }
fbcc39ad 1893
364d7324 1894 my $suffix = Catalyst::Utils::class2classsuffix( $component );
1895 my $config = $class->config->{ $suffix } || {};
fbcc39ad 1896
364d7324 1897 my $instance = eval { $component->COMPONENT( $class, $config ); };
fbcc39ad 1898
1899 if ( my $error = $@ ) {
fbcc39ad 1900 chomp $error;
fbcc39ad 1901 Catalyst::Exception->throw(
364d7324 1902 message => qq/Couldn't instantiate component "$component", "$error"/
1903 );
fbcc39ad 1904 }
1905
364d7324 1906 Catalyst::Exception->throw(
1907 message =>
1908 qq/Couldn't instantiate component "$component", "COMPONENT() didn't return an object-like value"/
1909 ) unless eval { $instance->can( 'can' ) };
1910
1911 return $instance;
fbcc39ad 1912}
1913
b5ecfcf0 1914=head2 $c->setup_dispatcher
fbcc39ad 1915
ae1e6b59 1916Sets up dispatcher.
1917
fbcc39ad 1918=cut
1919
1920sub setup_dispatcher {
1921 my ( $class, $dispatcher ) = @_;
1922
1923 if ($dispatcher) {
1924 $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
1925 }
1926
1927 if ( $ENV{CATALYST_DISPATCHER} ) {
1928 $dispatcher = 'Catalyst::Dispatcher::' . $ENV{CATALYST_DISPATCHER};
1929 }
1930
1931 if ( $ENV{ uc($class) . '_DISPATCHER' } ) {
1932 $dispatcher =
1933 'Catalyst::Dispatcher::' . $ENV{ uc($class) . '_DISPATCHER' };
1934 }
1935
1936 unless ($dispatcher) {
cb0354c6 1937 $dispatcher = $class->dispatcher_class;
fbcc39ad 1938 }
1939
1e514a51 1940 unless (Class::Inspector->loaded($dispatcher)) {
1941 require Class::Inspector->filename($dispatcher);
fbcc39ad 1942 }
1943
1944 # dispatcher instance
1945 $class->dispatcher( $dispatcher->new );
1946}
1947
b5ecfcf0 1948=head2 $c->setup_engine
fbcc39ad 1949
ae1e6b59 1950Sets up engine.
1951
fbcc39ad 1952=cut
1953
1954sub setup_engine {
1955 my ( $class, $engine ) = @_;
1956
1957 if ($engine) {
1958 $engine = 'Catalyst::Engine::' . $engine;
1959 }
1960
1961 if ( $ENV{CATALYST_ENGINE} ) {
1962 $engine = 'Catalyst::Engine::' . $ENV{CATALYST_ENGINE};
1963 }
1964
1965 if ( $ENV{ uc($class) . '_ENGINE' } ) {
1966 $engine = 'Catalyst::Engine::' . $ENV{ uc($class) . '_ENGINE' };
1967 }
1968
9b0a3e0f 1969 if ( $ENV{MOD_PERL} ) {
fbcc39ad 1970
1971 # create the apache method
1972 {
1973 no strict 'refs';
1974 *{"$class\::apache"} = sub { shift->engine->apache };
1975 }
1976
1977 my ( $software, $version ) =
1978 $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
1979
1980 $version =~ s/_//g;
1981 $version =~ s/(\.[^.]+)\./$1/g;
1982
1983 if ( $software eq 'mod_perl' ) {
1984
9b0a3e0f 1985 if ( !$engine ) {
22247e54 1986
9b0a3e0f 1987 if ( $version >= 1.99922 ) {
1988 $engine = 'Catalyst::Engine::Apache2::MP20';
1989 }
22247e54 1990
9b0a3e0f 1991 elsif ( $version >= 1.9901 ) {
1992 $engine = 'Catalyst::Engine::Apache2::MP19';
1993 }
22247e54 1994
9b0a3e0f 1995 elsif ( $version >= 1.24 ) {
1996 $engine = 'Catalyst::Engine::Apache::MP13';
1997 }
22247e54 1998
9b0a3e0f 1999 else {
2000 Catalyst::Exception->throw( message =>
2001 qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
2002 }
fbcc39ad 2003
fbcc39ad 2004 }
2005
2006 # install the correct mod_perl handler
2007 if ( $version >= 1.9901 ) {
2008 *handler = sub : method {
2009 shift->handle_request(@_);
2010 };
2011 }
2012 else {
2013 *handler = sub ($$) { shift->handle_request(@_) };
2014 }
2015
2016 }
2017
2018 elsif ( $software eq 'Zeus-Perl' ) {
2019 $engine = 'Catalyst::Engine::Zeus';
2020 }
2021
2022 else {
2023 Catalyst::Exception->throw(
2024 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
2025 }
2026 }
2027
2028 unless ($engine) {
cb0354c6 2029 $engine = $class->engine_class;
fbcc39ad 2030 }
2031
1e514a51 2032 unless (Class::Inspector->loaded($engine)) {
2033 require Class::Inspector->filename($engine);
fbcc39ad 2034 }
0e7f5826 2035
d54484bf 2036 # check for old engines that are no longer compatible
2037 my $old_engine;
0e7f5826 2038 if ( $engine->isa('Catalyst::Engine::Apache')
2039 && !Catalyst::Engine::Apache->VERSION )
d54484bf 2040 {
2041 $old_engine = 1;
2042 }
0e7f5826 2043
d54484bf 2044 elsif ( $engine->isa('Catalyst::Engine::Server::Base')
0e7f5826 2045 && Catalyst::Engine::Server->VERSION le '0.02' )
d54484bf 2046 {
2047 $old_engine = 1;
2048 }
0e7f5826 2049
2050 elsif ($engine->isa('Catalyst::Engine::HTTP::POE')
2051 && $engine->VERSION eq '0.01' )
d54484bf 2052 {
2053 $old_engine = 1;
2054 }
0e7f5826 2055
2056 elsif ($engine->isa('Catalyst::Engine::Zeus')
2057 && $engine->VERSION eq '0.01' )
d54484bf 2058 {
2059 $old_engine = 1;
2060 }
fbcc39ad 2061
d54484bf 2062 if ($old_engine) {
2063 Catalyst::Exception->throw( message =>
0e7f5826 2064 qq/Engine "$engine" is not supported by this version of Catalyst/
d54484bf 2065 );
2066 }
0e7f5826 2067
fbcc39ad 2068 # engine instance
2069 $class->engine( $engine->new );
2070}
2071
b5ecfcf0 2072=head2 $c->setup_home
fbcc39ad 2073
ae1e6b59 2074Sets up the home directory.
2075
fbcc39ad 2076=cut
2077
2078sub setup_home {
2079 my ( $class, $home ) = @_;
2080
2081 if ( $ENV{CATALYST_HOME} ) {
2082 $home = $ENV{CATALYST_HOME};
2083 }
2084
2085 if ( $ENV{ uc($class) . '_HOME' } ) {
cc95842f 2086 $class =~ s/::/_/g;
fbcc39ad 2087 $home = $ENV{ uc($class) . '_HOME' };
2088 }
2089
2090 unless ($home) {
2091 $home = Catalyst::Utils::home($class);
2092 }
2093
2094 if ($home) {
2095 $class->config->{home} ||= $home;
a738ab68 2096 $class->config->{root} ||= Path::Class::Dir->new($home)->subdir('root');
fbcc39ad 2097 }
2098}
2099
b5ecfcf0 2100=head2 $c->setup_log
fbcc39ad 2101
ae1e6b59 2102Sets up log.
2103
fbcc39ad 2104=cut
2105
2106sub setup_log {
2107 my ( $class, $debug ) = @_;
2108
2109 unless ( $class->log ) {
2110 $class->log( Catalyst::Log->new );
2111 }
af3ff00e 2112
71f074a9 2113 my $app_flag = Catalyst::Utils::class2env($class) . '_DEBUG';
71f074a9 2114
af3ff00e 2115 if (
2116 ( defined( $ENV{CATALYST_DEBUG} ) || defined( $ENV{$app_flag} ) )
2117 ? ( $ENV{CATALYST_DEBUG} || $ENV{$app_flag} )
2118 : $debug
2119 )
2120 {
fbcc39ad 2121 no strict 'refs';
2122 *{"$class\::debug"} = sub { 1 };
2123 $class->log->debug('Debug messages enabled');
2124 }
2125}
2126
b5ecfcf0 2127=head2 $c->setup_plugins
fbcc39ad 2128
ae1e6b59 2129Sets up plugins.
2130
fbcc39ad 2131=cut
2132
836e1134 2133=head2 $c->registered_plugins
2134
2135Returns a sorted list of the plugins which have either been stated in the
2136import list or which have been added via C<< MyApp->plugin(@args); >>.
2137
2138If passed a given plugin name, it will report a boolean value indicating
2139whether or not that plugin is loaded. A fully qualified name is required if
2140the plugin name does not begin with C<Catalyst::Plugin::>.
2141
2142 if ($c->registered_plugins('Some::Plugin')) {
2143 ...
2144 }
2145
2146=cut
fbcc39ad 2147
836e1134 2148{
97b58e17 2149
2150 sub registered_plugins {
836e1134 2151 my $proto = shift;
197bd788 2152 return sort keys %{ $proto->_plugins } unless @_;
836e1134 2153 my $plugin = shift;
d0d4d785 2154 return 1 if exists $proto->_plugins->{$plugin};
2155 return exists $proto->_plugins->{"Catalyst::Plugin::$plugin"};
836e1134 2156 }
fbcc39ad 2157
836e1134 2158 sub _register_plugin {
2159 my ( $proto, $plugin, $instant ) = @_;
2160 my $class = ref $proto || $proto;
fbcc39ad 2161
893f05d2 2162 Catalyst::Utils::ensure_class_loaded( $plugin, { ignore_loaded => 1 } );
fbcc39ad 2163
197bd788 2164 $proto->_plugins->{$plugin} = 1;
836e1134 2165 unless ($instant) {
fbcc39ad 2166 no strict 'refs';
2167 unshift @{"$class\::ISA"}, $plugin;
2168 }
836e1134 2169 return $class;
2170 }
2171
2172 sub setup_plugins {
2173 my ( $class, $plugins ) = @_;
2174
d0d4d785 2175 $class->_plugins( {} ) unless $class->_plugins;
836e1134 2176 $plugins ||= [];
2177 for my $plugin ( reverse @$plugins ) {
2178
2179 unless ( $plugin =~ s/\A\+// ) {
2180 $plugin = "Catalyst::Plugin::$plugin";
2181 }
2182
2183 $class->_register_plugin($plugin);
2184 }
fbcc39ad 2185 }
2186}
2187
b5ecfcf0 2188=head2 $c->stack
8767c5a3 2189
86418559 2190Returns an arrayref of the internal execution stack (actions that are
2191currently executing).
8767c5a3 2192
b5ecfcf0 2193=head2 $c->write( $data )
fbcc39ad 2194
ae1e6b59 2195Writes $data to the output stream. When using this method directly, you
2196will need to manually set the C<Content-Length> header to the length of
2197your output data, if known.
fbcc39ad 2198
2199=cut
2200
4f5ebacd 2201sub write {
2202 my $c = shift;
2203
2204 # Finalize headers if someone manually writes output
2205 $c->finalize_headers;
2206
2207 return $c->engine->write( $c, @_ );
2208}
fbcc39ad 2209
b5ecfcf0 2210=head2 version
bf88a181 2211
ae1e6b59 2212Returns the Catalyst version number. Mostly useful for "powered by"
2213messages in template systems.
bf88a181 2214
2215=cut
2216
2217sub version { return $Catalyst::VERSION }
2218
b0bb11ec 2219=head1 INTERNAL ACTIONS
2220
ae1e6b59 2221Catalyst uses internal actions like C<_DISPATCH>, C<_BEGIN>, C<_AUTO>,
2222C<_ACTION>, and C<_END>. These are by default not shown in the private
3e705254 2223action table, but you can make them visible with a config parameter.
b0bb11ec 2224
2225 MyApp->config->{show_internal_actions} = 1;
2226
d2ee9760 2227=head1 CASE SENSITIVITY
2228
3e705254 2229By default Catalyst is not case sensitive, so C<MyApp::C::FOO::Bar> is
ae1e6b59 2230mapped to C</foo/bar>. You can activate case sensitivity with a config
3e705254 2231parameter.
d2ee9760 2232
2233 MyApp->config->{case_sensitive} = 1;
2234
3e705254 2235This causes C<MyApp::C::Foo::Bar> to map to C</Foo/Bar>.
fbcc39ad 2236
2237=head1 ON-DEMAND PARSER
2238
2239The request body is usually parsed at the beginning of a request,
3e705254 2240but if you want to handle input yourself or speed things up a bit,
fbcc39ad 2241you can enable on-demand parsing with a config parameter.
2242
2243 MyApp->config->{parse_on_demand} = 1;
2244
2245=head1 PROXY SUPPORT
2246
ae1e6b59 2247Many production servers operate using the common double-server approach,
2248with a lightweight frontend web server passing requests to a larger
2249backend server. An application running on the backend server must deal
2250with two problems: the remote user always appears to be C<127.0.0.1> and
2251the server's hostname will appear to be C<localhost> regardless of the
2252virtual host that the user connected through.
fbcc39ad 2253
ae1e6b59 2254Catalyst will automatically detect this situation when you are running
2255the frontend and backend servers on the same machine. The following
2256changes are made to the request.
fbcc39ad 2257
ae1e6b59 2258 $c->req->address is set to the user's real IP address, as read from
2259 the HTTP X-Forwarded-For header.
fbcc39ad 2260
ae1e6b59 2261 The host value for $c->req->base and $c->req->uri is set to the real
2262 host, as read from the HTTP X-Forwarded-Host header.
fbcc39ad 2263
3e705254 2264Obviously, your web server must support these headers for this to work.
fbcc39ad 2265
ae1e6b59 2266In a more complex server farm environment where you may have your
2267frontend proxy server(s) on different machines, you will need to set a
2268configuration option to tell Catalyst to read the proxied data from the
2269headers.
fbcc39ad 2270
2271 MyApp->config->{using_frontend_proxy} = 1;
2272
2273If you do not wish to use the proxy support at all, you may set:
d1a31ac6 2274
fbcc39ad 2275 MyApp->config->{ignore_frontend_proxy} = 1;
2276
2277=head1 THREAD SAFETY
2278
86418559 2279Catalyst has been tested under Apache 2's threading C<mpm_worker>,
2280C<mpm_winnt>, and the standalone forking HTTP server on Windows. We
2281believe the Catalyst core to be thread-safe.
fbcc39ad 2282
2283If you plan to operate in a threaded environment, remember that all other
3e705254 2284modules you are using must also be thread-safe. Some modules, most notably
2285L<DBD::SQLite>, are not thread-safe.
d1a31ac6 2286
3cb1db8c 2287=head1 SUPPORT
2288
2289IRC:
2290
4eaf7c88 2291 Join #catalyst on irc.perl.org.
3cb1db8c 2292
3e705254 2293Mailing Lists:
3cb1db8c 2294
2295 http://lists.rawmode.org/mailman/listinfo/catalyst
2296 http://lists.rawmode.org/mailman/listinfo/catalyst-dev
1985c30b 2297
432d507d 2298Web:
2299
2300 http://catalyst.perl.org
2301
0ef52a96 2302Wiki:
2303
2304 http://dev.catalyst.perl.org
2305
fc7ec1d9 2306=head1 SEE ALSO
2307
829a28ca 2308=head2 L<Task::Catalyst> - All you need to start with Catalyst
2309
b5ecfcf0 2310=head2 L<Catalyst::Manual> - The Catalyst Manual
e7f1cf73 2311
b5ecfcf0 2312=head2 L<Catalyst::Component>, L<Catalyst::Base> - Base classes for components
61b1e958 2313
b5ecfcf0 2314=head2 L<Catalyst::Engine> - Core engine
61b1e958 2315
b5ecfcf0 2316=head2 L<Catalyst::Log> - Log class.
61b1e958 2317
b5ecfcf0 2318=head2 L<Catalyst::Request> - Request object
61b1e958 2319
b5ecfcf0 2320=head2 L<Catalyst::Response> - Response object
61b1e958 2321
b5ecfcf0 2322=head2 L<Catalyst::Test> - The test suite.
fc7ec1d9 2323
15f0b5b7 2324=head1 CREDITS
fc7ec1d9 2325
15f0b5b7 2326Andy Grundman
2327
fbcc39ad 2328Andy Wardley
2329
33108eaf 2330Andreas Marienborg
2331
f4a57de4 2332Andrew Bramble
2333
15f0b5b7 2334Andrew Ford
2335
2336Andrew Ruthven
2337
fbcc39ad 2338Arthur Bergman
2339
15f0b5b7 2340Autrijus Tang
2341
0cf56dbc 2342Brian Cassidy
2343
6aaa1c60 2344Carl Franks
2345
15f0b5b7 2346Christian Hansen
2347
2348Christopher Hicks
2349
2350Dan Sully
2351
2352Danijel Milicevic
2353
0ef52a96 2354David Kamholz
2355
15f0b5b7 2356David Naughton
2357
61bef238 2358Drew Taylor
2359
15f0b5b7 2360Gary Ashton Jones
2361
2362Geoff Richards
2363
2364Jesse Sheidlower
2365
fbcc39ad 2366Jesse Vincent
2367
15f0b5b7 2368Jody Belka
2369
2370Johan Lindstrom
2371
2372Juan Camacho
2373
2374Leon Brocard
2375
2376Marcus Ramberg
2377
2378Matt S Trout
2379
71c3bcc3 2380Robert Sedlacek
2381
a727119f 2382Sam Vilain
2383
1cf1c56a 2384Sascha Kiefer
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;