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