Remove use of overload
[catagits/Catalyst-Runtime.git] / lib / Catalyst.pm
CommitLineData
fc7ec1d9 1package Catalyst;
2
0fc2d522 3use Class::C3;
a7caa492 4use Moose;
5extends 'Catalyst::Component';
fbcc39ad 6use bytes;
a2f2cde9 7use Catalyst::Exception;
fc7ec1d9 8use Catalyst::Log;
fbcc39ad 9use Catalyst::Request;
10use Catalyst::Request::Upload;
11use Catalyst::Response;
812a28c9 12use Catalyst::Utils;
31375184 13use Catalyst::Controller;
364d7324 14use Devel::InnerPackage ();
8f62c91a 15use File::stat;
c50f595c 16use Module::Pluggable::Object ();
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
6680c772 33has stack => (is => 'rw', default => sub { [] });
34has stash => (is => 'rw', default => sub { {} });
35has state => (is => 'rw', default => 0);
b6d4ee6e 36has stats => (is => 'rw');
37has action => (is => 'rw');
6680c772 38has counter => (is => 'rw', default => sub { {} });
39has request => (is => 'rw', default => sub { $_[0]->request_class->new({}) }, required => 1, lazy => 1);
40has response => (is => 'rw', default => sub { $_[0]->response_class->new({}) }, required => 1, lazy => 1);
e63bdf38 41has namespace => (is => 'rw');
42
0fc2d522 43no Moose;
10dd6896 44
684d10ed 45attributes->import( __PACKAGE__, \&namespace, 'lvalue' );
261c571e 46
8767c5a3 47sub depth { scalar @{ shift->stack || [] }; }
0fc2d522 48sub comp { shift->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
0fc2d522 60sub finalize_output { shift->finalize_body(@_) };
fbcc39ad 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
0fc2d522 382sub stash {
b4b01a8a 383 my $c = shift;
384 if (@_) {
385 my $stash = @_ > 1 ? {@_} : $_[0];
85d9fce6 386 croak('stash takes a hash or hashref') unless ref $stash;
c82ed742 387 foreach my $key ( keys %$stash ) {
0fc2d522 388 #shouldn't we hold this in a var and save ourselves the subcall?
389 $c->next::method->{$key} = $stash->{$key};
b4b01a8a 390 }
391 }
0fc2d522 392
393 return $c->next::method;
394}
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
0fc2d522 707sub config {
3643e890 708 my $c = shift;
709
710 $c->log->warn("Setting config after setup has been run is not a good idea.")
711 if ( @_ and $c->setup_finished );
712
0fc2d522 713 $c->next::method(@_);
714}
3643e890 715
b5ecfcf0 716=head2 $c->log
0ef52a96 717
86418559 718Returns the logging object instance. Unless it is already set, Catalyst
719sets this up with a L<Catalyst::Log> object. To use your own log class,
720set the logger with the C<< __PACKAGE__->log >> method prior to calling
9e7673af 721C<< __PACKAGE__->setup >>.
722
723 __PACKAGE__->log( MyLogger->new );
724 __PACKAGE__->setup;
725
726And later:
0ef52a96 727
ae1e6b59 728 $c->log->info( 'Now logging with my own logger!' );
0ef52a96 729
86418559 730Your log class should implement the methods described in
731L<Catalyst::Log>.
af3ff00e 732
b4b01a8a 733
734=head2 $c->debug
735
736Overload to enable debug messages (same as -Debug option).
737
e80e8542 738Note that this is a static method, not an accessor and should be overloaded
739by declaring "sub debug { 1 }" in your MyApp.pm, not by calling $c->debug(1).
740
af3ff00e 741=cut
742
b4b01a8a 743sub debug { 0 }
744
745=head2 $c->dispatcher
746
747Returns the dispatcher instance. Stringifies to class name. See
748L<Catalyst::Dispatcher>.
749
750=head2 $c->engine
751
752Returns the engine instance. Stringifies to the class name. See
753L<Catalyst::Engine>.
754
755
f7b672ef 756=head2 UTILITY METHODS
66e28e3f 757
b5ecfcf0 758=head2 $c->path_to(@path)
01033d73 759
cc95842f 760Merges C<@path> with C<< $c->config->{home} >> and returns a
761L<Path::Class::Dir> object.
01033d73 762
763For example:
764
765 $c->path_to( 'db', 'sqlite.db' );
766
767=cut
768
769sub path_to {
770 my ( $c, @path ) = @_;
a738ab68 771 my $path = Path::Class::Dir->new( $c->config->{home}, @path );
01033d73 772 if ( -d $path ) { return $path }
a738ab68 773 else { return Path::Class::File->new( $c->config->{home}, @path ) }
01033d73 774}
775
b5ecfcf0 776=head2 $c->plugin( $name, $class, @args )
0ef52a96 777
ae1e6b59 778Helper method for plugins. It creates a classdata accessor/mutator and
779loads and instantiates the given class.
0ef52a96 780
781 MyApp->plugin( 'prototype', 'HTML::Prototype' );
782
783 $c->prototype->define_javascript_functions;
784
785=cut
786
787sub plugin {
788 my ( $class, $name, $plugin, @args ) = @_;
97b58e17 789 $class->_register_plugin( $plugin, 1 );
0ef52a96 790
791 eval { $plugin->import };
792 $class->mk_classdata($name);
793 my $obj;
794 eval { $obj = $plugin->new(@args) };
795
796 if ($@) {
797 Catalyst::Exception->throw( message =>
798 qq/Couldn't instantiate instant plugin "$plugin", "$@"/ );
799 }
800
801 $class->$name($obj);
802 $class->log->debug(qq/Initialized instant plugin "$plugin" as "$name"/)
803 if $class->debug;
804}
805
b5ecfcf0 806=head2 MyApp->setup
fbcc39ad 807
e7f1cf73 808Initializes the dispatcher and engine, loads any plugins, and loads the
ae1e6b59 809model, view, and controller components. You may also specify an array
810of plugins to load here, if you choose to not load them in the C<use
811Catalyst> line.
fbcc39ad 812
0ef52a96 813 MyApp->setup;
814 MyApp->setup( qw/-Debug/ );
fbcc39ad 815
816=cut
817
818sub setup {
0319a12c 819 my ( $class, @arguments ) = @_;
599b5295 820
5168a5fc 821 $class->log->warn("Running setup twice is not a good idea.")
822 if ( $class->setup_finished );
823
fbcc39ad 824 unless ( $class->isa('Catalyst') ) {
953b0e15 825
fbcc39ad 826 Catalyst::Exception->throw(
827 message => qq/'$class' does not inherit from Catalyst/ );
1c99e125 828 }
0319a12c 829
fbcc39ad 830 if ( $class->arguments ) {
831 @arguments = ( @arguments, @{ $class->arguments } );
832 }
833
834 # Process options
835 my $flags = {};
836
837 foreach (@arguments) {
838
839 if (/^-Debug$/) {
840 $flags->{log} =
841 ( $flags->{log} ) ? 'debug,' . $flags->{log} : 'debug';
842 }
843 elsif (/^-(\w+)=?(.*)$/) {
844 $flags->{ lc $1 } = $2;
845 }
846 else {
847 push @{ $flags->{plugins} }, $_;
848 }
849 }
850
99f187d6 851 $class->setup_home( delete $flags->{home} );
852
fbcc39ad 853 $class->setup_log( delete $flags->{log} );
854 $class->setup_plugins( delete $flags->{plugins} );
855 $class->setup_dispatcher( delete $flags->{dispatcher} );
856 $class->setup_engine( delete $flags->{engine} );
dc5f035e 857 $class->setup_stats( delete $flags->{stats} );
fbcc39ad 858
859 for my $flag ( sort keys %{$flags} ) {
860
861 if ( my $code = $class->can( 'setup_' . $flag ) ) {
862 &$code( $class, delete $flags->{$flag} );
863 }
864 else {
865 $class->log->warn(qq/Unknown flag "$flag"/);
866 }
867 }
868
0eb4af72 869 eval { require Catalyst::Devel; };
870 if( !$@ && $ENV{CATALYST_SCRIPT_GEN} && ( $ENV{CATALYST_SCRIPT_GEN} < $Catalyst::Devel::CATALYST_SCRIPT_GEN ) ) {
871 $class->log->warn(<<"EOF");
4ff0d824 872You are running an old script!
873
34a83d89 874 Please update by running (this will overwrite existing files):
875 catalyst.pl -force -scripts $class
876
877 or (this will not overwrite existing files):
878 catalyst.pl -scripts $class
1cf0345b 879
4ff0d824 880EOF
0eb4af72 881 }
ac5c933b 882
fbcc39ad 883 if ( $class->debug ) {
6601f2ad 884 my @plugins = map { "$_ " . ( $_->VERSION || '' ) } $class->registered_plugins;
fbcc39ad 885
886 if (@plugins) {
34d28dfd 887 my $t = Text::SimpleTable->new(74);
8c113188 888 $t->row($_) for @plugins;
1cf0345b 889 $class->log->debug( "Loaded plugins:\n" . $t->draw . "\n" );
fbcc39ad 890 }
891
892 my $dispatcher = $class->dispatcher;
893 my $engine = $class->engine;
894 my $home = $class->config->{home};
895
896 $class->log->debug(qq/Loaded dispatcher "$dispatcher"/);
897 $class->log->debug(qq/Loaded engine "$engine"/);
898
899 $home
900 ? ( -d $home )
901 ? $class->log->debug(qq/Found home "$home"/)
902 : $class->log->debug(qq/Home "$home" doesn't exist/)
903 : $class->log->debug(q/Couldn't find home/);
904 }
905
906 # Call plugins setup
907 {
908 no warnings qw/redefine/;
909 local *setup = sub { };
910 $class->setup;
911 }
912
913 # Initialize our data structure
914 $class->components( {} );
915
916 $class->setup_components;
917
918 if ( $class->debug ) {
34d28dfd 919 my $t = Text::SimpleTable->new( [ 63, 'Class' ], [ 8, 'Type' ] );
684d10ed 920 for my $comp ( sort keys %{ $class->components } ) {
921 my $type = ref $class->components->{$comp} ? 'instance' : 'class';
922 $t->row( $comp, $type );
923 }
1cf0345b 924 $class->log->debug( "Loaded components:\n" . $t->draw . "\n" )
8c113188 925 if ( keys %{ $class->components } );
fbcc39ad 926 }
927
928 # Add our self to components, since we are also a component
929 $class->components->{$class} = $class;
930
931 $class->setup_actions;
932
933 if ( $class->debug ) {
934 my $name = $class->config->{name} || 'Application';
935 $class->log->info("$name powered by Catalyst $Catalyst::VERSION");
936 }
937 $class->log->_flush() if $class->log->can('_flush');
3643e890 938
939 $class->setup_finished(1);
fbcc39ad 940}
941
73664287 942=head2 $c->uri_for( $path, @args?, \%query_values? )
fbcc39ad 943
c50f595c 944Merges path with C<< $c->request->base >> for absolute URIs and with
945C<< $c->namespace >> for relative URIs, then returns a normalized L<URI>
86418559 946object. If any args are passed, they are added at the end of the path.
947If the last argument to C<uri_for> is a hash reference, it is assumed to
948contain GET parameter key/value pairs, which will be appended to the URI
949in standard fashion.
fbcc39ad 950
8dc69021 951Note that uri_for is destructive to the passed hashref. Subsequent calls
952with the same hashref may have unintended results.
953
86418559 954Instead of C<$path>, you can also optionally pass a C<$action> object
955which will be resolved to a path using
147869cd 956C<< $c->dispatcher->uri_for_action >>; if the first element of
86418559 957C<@args> is an arrayref it is treated as a list of captures to be passed
958to C<uri_for_action>.
ea0e58d9 959
fbcc39ad 960=cut
961
962sub uri_for {
00e6a2b7 963 my ( $c, $path, @args ) = @_;
00e6a2b7 964
ea0e58d9 965 if ( Scalar::Util::blessed($path) ) { # action object
966 my $captures = ( scalar @args && ref $args[0] eq 'ARRAY'
967 ? shift(@args)
968 : [] );
969 $path = $c->dispatcher->uri_for_action($path, $captures);
970 return undef unless defined($path);
81e75875 971 $path = '/' if $path eq '';
ea0e58d9 972 }
973
51674a63 974 undef($path) if (defined $path && $path eq '');
00e6a2b7 975
97b58e17 976 my $params =
977 ( scalar @args && ref $args[$#args] eq 'HASH' ? pop @args : {} );
8327e2e2 978
cbb93105 979 carp "uri_for called with undef argument" if grep { ! defined $_ } @args;
51674a63 980 s/([^$URI::uric])/$URI::Escape::escapes{$1}/go for @args;
981
982 unshift(@args, $path);
983
984 unless (defined $path && $path =~ s!^/!!) { # in-place strip
985 my $namespace = $c->namespace;
986 if (defined $path) { # cheesy hack to handle path '../foo'
987 $namespace =~ s{(?:^|/)[^/]+$}{} while $args[0] =~ s{^\.\./}{};
6601f2ad 988 }
51674a63 989 unshift(@args, $namespace || '');
990 }
ac5c933b 991
189e2a51 992 # join args with '/', or a blank string
51674a63 993 my $args = join('/', grep { defined($_) } @args);
994 $args =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
995 $args =~ s!^/!!;
996 my $base = $c->req->base;
997 my $class = ref($base);
998 $base =~ s{(?<!/)$}{/};
999
1000 my $query = '';
1001
1002 if (my @keys = keys %$params) {
1003 # somewhat lifted from URI::_query's query_form
1004 $query = '?'.join('&', map {
1005 s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/go;
1006 s/ /+/g;
1007 my $key = $_;
1008 my $val = $params->{$_};
1009 $val = '' unless defined $val;
1010 (map {
1011 $_ = "$_";
0ce485e9 1012 utf8::encode( $_ ) if utf8::is_utf8($_);
51674a63 1013 # using the URI::Escape pattern here so utf8 chars survive
1014 s/([^A-Za-z0-9\-_.!~*'() ])/$URI::Escape::escapes{$1}/go;
1015 s/ /+/g;
1016 "${key}=$_"; } ( ref $val eq 'ARRAY' ? @$val : $val ));
1017 } @keys);
1018 }
1019
1020 my $res = bless(\"${base}${args}${query}", $class);
d3e7a648 1021 $res;
fbcc39ad 1022}
1023
b5ecfcf0 1024=head2 $c->welcome_message
ab2374d3 1025
1026Returns the Catalyst welcome HTML page.
1027
1028=cut
1029
1030sub welcome_message {
bf1f2c60 1031 my $c = shift;
1032 my $name = $c->config->{name};
1033 my $logo = $c->uri_for('/static/images/catalyst_logo.png');
1034 my $prefix = Catalyst::Utils::appprefix( ref $c );
80cdbbff 1035 $c->response->content_type('text/html; charset=utf-8');
ab2374d3 1036 return <<"EOF";
80cdbbff 1037<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1038 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1039<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
ab2374d3 1040 <head>
85d9fce6 1041 <meta http-equiv="Content-Language" content="en" />
1042 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
ab2374d3 1043 <title>$name on Catalyst $VERSION</title>
1044 <style type="text/css">
1045 body {
ab2374d3 1046 color: #000;
1047 background-color: #eee;
1048 }
1049 div#content {
1050 width: 640px;
80cdbbff 1051 margin-left: auto;
1052 margin-right: auto;
ab2374d3 1053 margin-top: 10px;
1054 margin-bottom: 10px;
1055 text-align: left;
1056 background-color: #ccc;
1057 border: 1px solid #aaa;
ab2374d3 1058 }
d84c4dab 1059 p, h1, h2 {
ab2374d3 1060 margin-left: 20px;
1061 margin-right: 20px;
16215972 1062 font-family: verdana, tahoma, sans-serif;
ab2374d3 1063 }
d84c4dab 1064 a {
1065 font-family: verdana, tahoma, sans-serif;
1066 }
d114e033 1067 :link, :visited {
1068 text-decoration: none;
1069 color: #b00;
1070 border-bottom: 1px dotted #bbb;
1071 }
1072 :link:hover, :visited:hover {
d114e033 1073 color: #555;
1074 }
ab2374d3 1075 div#topbar {
1076 margin: 0px;
1077 }
3e82a295 1078 pre {
3e82a295 1079 margin: 10px;
1080 padding: 8px;
1081 }
ab2374d3 1082 div#answers {
1083 padding: 8px;
1084 margin: 10px;
d114e033 1085 background-color: #fff;
ab2374d3 1086 border: 1px solid #aaa;
ab2374d3 1087 }
1088 h1 {
33108eaf 1089 font-size: 0.9em;
1090 font-weight: normal;
ab2374d3 1091 text-align: center;
1092 }
1093 h2 {
1094 font-size: 1.0em;
1095 }
1096 p {
1097 font-size: 0.9em;
1098 }
ae7c5252 1099 p img {
1100 float: right;
1101 margin-left: 10px;
1102 }
9619f23c 1103 span#appname {
1104 font-weight: bold;
33108eaf 1105 font-size: 1.6em;
ab2374d3 1106 }
1107 </style>
1108 </head>
1109 <body>
1110 <div id="content">
1111 <div id="topbar">
9619f23c 1112 <h1><span id="appname">$name</span> on <a href="http://catalyst.perl.org">Catalyst</a>
d84c4dab 1113 $VERSION</h1>
ab2374d3 1114 </div>
1115 <div id="answers">
ae7c5252 1116 <p>
80cdbbff 1117 <img src="$logo" alt="Catalyst Logo" />
ae7c5252 1118 </p>
596aaffe 1119 <p>Welcome to the world of Catalyst.
f92fd545 1120 This <a href="http://en.wikipedia.org/wiki/MVC">MVC</a>
1121 framework will make web development something you had
60dd6e1d 1122 never expected it to be: Fun, rewarding, and quick.</p>
ab2374d3 1123 <h2>What to do now?</h2>
4b8cb778 1124 <p>That really depends on what <b>you</b> want to do.
ab2374d3 1125 We do, however, provide you with a few starting points.</p>
1126 <p>If you want to jump right into web development with Catalyst
596aaffe 1127 you might want want to start with a tutorial.</p>
b607f8a0 1128<pre>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Tutorial.pod">Catalyst::Manual::Tutorial</a></code>
596aaffe 1129</pre>
1130<p>Afterwards you can go on to check out a more complete look at our features.</p>
1131<pre>
b607f8a0 1132<code>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Intro.pod">Catalyst::Manual::Intro</a>
1133<!-- Something else should go here, but the Catalyst::Manual link seems unhelpful -->
1134</code></pre>
ab2374d3 1135 <h2>What to do next?</h2>
f5681c92 1136 <p>Next it's time to write an actual application. Use the
80cdbbff 1137 helper scripts to generate <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AController%3A%3A&amp;mode=all">controllers</a>,
60dd6e1d 1138 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AModel%3A%3A&amp;mode=all">models</a>, and
1139 <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AView%3A%3A&amp;mode=all">views</a>;
bf1f2c60 1140 they can save you a lot of work.</p>
1141 <pre><code>script/${prefix}_create.pl -help</code></pre>
1142 <p>Also, be sure to check out the vast and growing
60dd6e1d 1143 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 1144 you are likely to find what you need there.
f5681c92 1145 </p>
1146
82245cc4 1147 <h2>Need help?</h2>
f5681c92 1148 <p>Catalyst has a very active community. Here are the main places to
1149 get in touch with us.</p>
16215972 1150 <ul>
1151 <li>
2b9a7d76 1152 <a href="http://dev.catalyst.perl.org">Wiki</a>
16215972 1153 </li>
1154 <li>
1155 <a href="http://lists.rawmode.org/mailman/listinfo/catalyst">Mailing-List</a>
1156 </li>
1157 <li>
4eaf7c88 1158 <a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
16215972 1159 </li>
1160 </ul>
ab2374d3 1161 <h2>In conclusion</h2>
ac5c933b 1162 <p>The Catalyst team hopes you will enjoy using Catalyst as much
f5681c92 1163 as we enjoyed making it. Please contact us if you have ideas
1164 for improvement or other feedback.</p>
ab2374d3 1165 </div>
1166 </div>
1167 </body>
1168</html>
1169EOF
1170}
1171
fbcc39ad 1172=head1 INTERNAL METHODS
1173
ae1e6b59 1174These methods are not meant to be used by end users.
1175
b5ecfcf0 1176=head2 $c->components
fbcc39ad 1177
e7f1cf73 1178Returns a hash of components.
fbcc39ad 1179
b5ecfcf0 1180=head2 $c->context_class
1f9cb7c1 1181
e7f1cf73 1182Returns or sets the context class.
1f9cb7c1 1183
b5ecfcf0 1184=head2 $c->counter
fbcc39ad 1185
ae1e6b59 1186Returns a hashref containing coderefs and execution counts (needed for
1187deep recursion detection).
fbcc39ad 1188
b5ecfcf0 1189=head2 $c->depth
fbcc39ad 1190
e7f1cf73 1191Returns the number of actions on the current internal execution stack.
fbcc39ad 1192
b5ecfcf0 1193=head2 $c->dispatch
fbcc39ad 1194
e7f1cf73 1195Dispatches a request to actions.
fbcc39ad 1196
1197=cut
1198
1199sub dispatch { my $c = shift; $c->dispatcher->dispatch( $c, @_ ) }
1200
b5ecfcf0 1201=head2 $c->dispatcher_class
1f9cb7c1 1202
e7f1cf73 1203Returns or sets the dispatcher class.
1f9cb7c1 1204
b5ecfcf0 1205=head2 $c->dump_these
7f92deef 1206
ae1e6b59 1207Returns a list of 2-element array references (name, structure) pairs
1208that will be dumped on the error page in debug mode.
7f92deef 1209
1210=cut
1211
1212sub dump_these {
1213 my $c = shift;
ac5c933b 1214 [ Request => $c->req ],
1215 [ Response => $c->res ],
052a2d89 1216 [ Stash => $c->stash ],
1217 [ Config => $c->config ];
7f92deef 1218}
1219
b5ecfcf0 1220=head2 $c->engine_class
1f9cb7c1 1221
e7f1cf73 1222Returns or sets the engine class.
1f9cb7c1 1223
b5ecfcf0 1224=head2 $c->execute( $class, $coderef )
fbcc39ad 1225
0ef52a96 1226Execute a coderef in given class and catch exceptions. Errors are available
1227via $c->error.
fbcc39ad 1228
1229=cut
1230
1231sub execute {
1232 my ( $c, $class, $code ) = @_;
858828dd 1233 $class = $c->component($class) || $class;
fbcc39ad 1234 $c->state(0);
a0eca838 1235
197bd788 1236 if ( $c->depth >= $RECURSION ) {
f3414019 1237 my $action = $code->reverse();
91d08727 1238 $action = "/$action" unless $action =~ /->/;
f3414019 1239 my $error = qq/Deep recursion detected calling "${action}"/;
1627551a 1240 $c->log->error($error);
1241 $c->error($error);
1242 $c->state(0);
1243 return $c->state;
1244 }
1245
dc5f035e 1246 my $stats_info = $c->_stats_start_execute( $code ) if $c->use_stats;
22247e54 1247
8767c5a3 1248 push( @{ $c->stack }, $code );
ac5c933b 1249
f3414019 1250 eval { $c->state( $code->execute( $class, $c, @{ $c->req->args } ) || 0 ) };
22247e54 1251
dc5f035e 1252 $c->_stats_finish_execute( $stats_info ) if $c->use_stats and $stats_info;
ac5c933b 1253
a6724a82 1254 my $last = pop( @{ $c->stack } );
fbcc39ad 1255
1256 if ( my $error = $@ ) {
88879e92 1257 if ( !ref($error) and $error eq $DETACH ) { die $DETACH if $c->depth > 1 }
fbcc39ad 1258 else {
1259 unless ( ref $error ) {
91d08727 1260 no warnings 'uninitialized';
fbcc39ad 1261 chomp $error;
f59def82 1262 my $class = $last->class;
1263 my $name = $last->name;
1264 $error = qq/Caught exception in $class->$name "$error"/;
fbcc39ad 1265 }
fbcc39ad 1266 $c->error($error);
1267 $c->state(0);
1268 }
1269 }
1270 return $c->state;
1271}
1272
7a7d7af5 1273sub _stats_start_execute {
1274 my ( $c, $code ) = @_;
1275
a6724a82 1276 return if ( ( $code->name =~ /^_.*/ )
1277 && ( !$c->config->{show_internal_actions} ) );
7a7d7af5 1278
f3414019 1279 my $action_name = $code->reverse();
1280 $c->counter->{$action_name}++;
7a7d7af5 1281
f3414019 1282 my $action = $action_name;
a6724a82 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
f3414019 1301 my $uid = $action_name . $c->counter->{$action_name};
74efc144 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;