revert MyApp instantiation
[catagits/Catalyst-Runtime.git] / lib / Catalyst.pm
CommitLineData
fc7ec1d9 1package Catalyst;
2
6f1f968a 3use MRO::Compat;
4use mro 'c3';
a7caa492 5use Moose;
6extends 'Catalyst::Component';
fbcc39ad 7use bytes;
a2f2cde9 8use Catalyst::Exception;
fc7ec1d9 9use Catalyst::Log;
fbcc39ad 10use Catalyst::Request;
11use Catalyst::Request::Upload;
12use Catalyst::Response;
812a28c9 13use Catalyst::Utils;
31375184 14use Catalyst::Controller;
364d7324 15use Devel::InnerPackage ();
8f62c91a 16use File::stat;
c50f595c 17use Module::Pluggable::Object ();
c50f595c 18use Text::SimpleTable ();
19use Path::Class::Dir ();
20use Path::Class::File ();
fbcc39ad 21use Time::HiRes qw/gettimeofday tv_interval/;
c50f595c 22use URI ();
933ba403 23use URI::http;
24use URI::https;
6a4a7002 25use Scalar::Util qw/weaken blessed/;
5513038d 26use Tree::Simple qw/use_weak_refs/;
27use Tree::Simple::Visitor::FindByUID;
261c571e 28use attributes;
5789a3d8 29use utf8;
c45c5d37 30use Carp qw/croak carp/;
fc7ec1d9 31
f63c03e4 32BEGIN { require 5.008001; }
33
6680c772 34has stack => (is => 'rw', default => sub { [] });
35has stash => (is => 'rw', default => sub { {} });
36has state => (is => 'rw', default => 0);
b6d4ee6e 37has stats => (is => 'rw');
38has action => (is => 'rw');
6680c772 39has counter => (is => 'rw', default => sub { {} });
40has request => (is => 'rw', default => sub { $_[0]->request_class->new({}) }, required => 1, lazy => 1);
41has response => (is => 'rw', default => sub { $_[0]->response_class->new({}) }, required => 1, lazy => 1);
e63bdf38 42has namespace => (is => 'rw');
43
0fc2d522 44no Moose;
10dd6896 45
684d10ed 46attributes->import( __PACKAGE__, \&namespace, 'lvalue' );
261c571e 47
8767c5a3 48sub depth { scalar @{ shift->stack || [] }; }
0fc2d522 49sub comp { shift->component(@_) }
6680c772 50
51sub req {
52 # carp "the use of req() is deprecated in favour of request()";
53 my $self = shift; return $self->request(@_);
54}
55sub res {
56 # carp "the use of res() is deprecated in favour of response()";
57 my $self = shift; return $self->response(@_);
58}
fbcc39ad 59
60# For backwards compatibility
0fc2d522 61sub finalize_output { shift->finalize_body(@_) };
fbcc39ad 62
63# For statistics
64our $COUNT = 1;
65our $START = time;
66our $RECURSION = 1000;
67our $DETACH = "catalyst_detach\n";
68
b6d4ee6e 69#I imagine that very few of these really need to be class variables. if any.
70#maybe we should just make them attributes with a default?
fbcc39ad 71__PACKAGE__->mk_classdata($_)
3cec521a 72 for qw/components arguments dispatcher engine log dispatcher_class
ac5c933b 73 engine_class context_class request_class response_class stats_class
dc5f035e 74 setup_finished/;
cb0354c6 75
3cec521a 76__PACKAGE__->dispatcher_class('Catalyst::Dispatcher');
77__PACKAGE__->engine_class('Catalyst::Engine::CGI');
78__PACKAGE__->request_class('Catalyst::Request');
79__PACKAGE__->response_class('Catalyst::Response');
dc5f035e 80__PACKAGE__->stats_class('Catalyst::Stats');
fbcc39ad 81
6415bb4d 82# Remember to update this in Catalyst::Runtime as well!
83
25f55123 84our $VERSION = '5.7013';
189e2a51 85
fbcc39ad 86sub import {
87 my ( $class, @arguments ) = @_;
88
89 # We have to limit $class to Catalyst to avoid pushing Catalyst upon every
90 # callers @ISA.
91 return unless $class eq 'Catalyst';
92
84ff88cf 93 my $caller = caller();
94 return if $caller eq 'main';
95 my $meta = Moose::Meta::Class->initialize($caller);
96 #Moose->import({ into => $caller }); #do we want to do this?
fbcc39ad 97
98 unless ( $caller->isa('Catalyst') ) {
84ff88cf 99 my @superclasses = ($meta->superclasses, $class, 'Catalyst::Controller');
100 $meta->superclasses(@superclasses);
101 }
102 unless( $meta->has_method('meta') ){
103 $meta->add_method(meta => sub { Moose::Meta::Class->initialize("${caller}") } );
fbcc39ad 104 }
105
106 $caller->arguments( [@arguments] );
107 $caller->setup_home;
108}
fc7ec1d9 109
110=head1 NAME
111
112Catalyst - The Elegant MVC Web Application Framework
113
114=head1 SYNOPSIS
115
e7ad3b81 116See the L<Catalyst::Manual> distribution for comprehensive
117documentation and tutorials.
118
86418559 119 # Install Catalyst::Devel for helpers and other development tools
b4b01a8a 120 # use the helper to create a new application
91864987 121 catalyst.pl MyApp
fc7ec1d9 122
123 # add models, views, controllers
cc95842f 124 script/myapp_create.pl model MyDatabase DBIC::Schema create=dynamic dbi:SQLite:/path/to/db
125 script/myapp_create.pl view MyTemplate TT
0ef52a96 126 script/myapp_create.pl controller Search
fc7ec1d9 127
e7f1cf73 128 # built in testserver -- use -r to restart automatically on changes
cc95842f 129 # --help to see all available options
ae4e40a7 130 script/myapp_server.pl
fc7ec1d9 131
0ef52a96 132 # command line testing interface
ae4e40a7 133 script/myapp_test.pl /yada
fc7ec1d9 134
b4b01a8a 135 ### in lib/MyApp.pm
0ef52a96 136 use Catalyst qw/-Debug/; # include plugins here as well
ac5c933b 137
85d9fce6 138 ### In lib/MyApp/Controller/Root.pm (autocreated)
0ef52a96 139 sub foo : Global { # called for /foo, /foo/1, /foo/1/2, etc.
ae1e6b59 140 my ( $self, $c, @args ) = @_; # args are qw/1 2/ for /foo/1/2
141 $c->stash->{template} = 'foo.tt'; # set the template
0ef52a96 142 # lookup something from db -- stash vars are passed to TT
ac5c933b 143 $c->stash->{data} =
b4b01a8a 144 $c->model('Database::Foo')->search( { country => $args[0] } );
0ef52a96 145 if ( $c->req->params->{bar} ) { # access GET or POST parameters
146 $c->forward( 'bar' ); # process another action
ac5c933b 147 # do something else after forward returns
0ef52a96 148 }
149 }
ac5c933b 150
ae1e6b59 151 # The foo.tt TT template can use the stash data from the database
0ef52a96 152 [% WHILE (item = data.next) %]
153 [% item.foo %]
154 [% END %]
ac5c933b 155
0ef52a96 156 # called for /bar/of/soap, /bar/of/soap/10, etc.
157 sub bar : Path('/bar/of/soap') { ... }
fc7ec1d9 158
ae1e6b59 159 # called for all actions, from the top-most controller downwards
ac5c933b 160 sub auto : Private {
0ef52a96 161 my ( $self, $c ) = @_;
b4b01a8a 162 if ( !$c->user_exists ) { # Catalyst::Plugin::Authentication
0ef52a96 163 $c->res->redirect( '/login' ); # require login
164 return 0; # abort request and go immediately to end()
165 }
ae1e6b59 166 return 1; # success; carry on to next action
0ef52a96 167 }
ac5c933b 168
ae1e6b59 169 # called after all actions are finished
ac5c933b 170 sub end : Private {
5a8ed4fe 171 my ( $self, $c ) = @_;
0ef52a96 172 if ( scalar @{ $c->error } ) { ... } # handle errors
173 return if $c->res->body; # already have a response
174 $c->forward( 'MyApp::View::TT' ); # render template
5a8ed4fe 175 }
176
0ef52a96 177 ### in MyApp/Controller/Foo.pm
178 # called for /foo/bar
179 sub bar : Local { ... }
ac5c933b 180
5400c668 181 # called for /blargle
182 sub blargle : Global { ... }
ac5c933b 183
5400c668 184 # an index action matches /foo, but not /foo/1, etc.
185 sub index : Private { ... }
ac5c933b 186
0ef52a96 187 ### in MyApp/Controller/Foo/Bar.pm
188 # called for /foo/bar/baz
189 sub baz : Local { ... }
ac5c933b 190
b4b01a8a 191 # first Root auto is called, then Foo auto, then this
0ef52a96 192 sub auto : Private { ... }
ac5c933b 193
0ef52a96 194 # powerful regular expression paths are also possible
195 sub details : Regex('^product/(\w+)/details$') {
5a8ed4fe 196 my ( $self, $c ) = @_;
0ef52a96 197 # extract the (\w+) from the URI
2982e768 198 my $product = $c->req->captures->[0];
5a8ed4fe 199 }
fc7ec1d9 200
0ef52a96 201See L<Catalyst::Manual::Intro> for additional information.
3803e98f 202
fc7ec1d9 203=head1 DESCRIPTION
204
86418559 205Catalyst is a modern framework for making web applications without the
206pain usually associated with this process. This document is a reference
207to the main Catalyst application. If you are a new user, we suggest you
208start with L<Catalyst::Manual::Tutorial> or L<Catalyst::Manual::Intro>.
fc7ec1d9 209
210See L<Catalyst::Manual> for more documentation.
211
ae1e6b59 212Catalyst plugins can be loaded by naming them as arguments to the "use
213Catalyst" statement. Omit the C<Catalyst::Plugin::> prefix from the
214plugin name, i.e., C<Catalyst::Plugin::My::Module> becomes
215C<My::Module>.
fc7ec1d9 216
0ef52a96 217 use Catalyst qw/My::Module/;
fc7ec1d9 218
836e1134 219If your plugin starts with a name other than C<Catalyst::Plugin::>, you can
220fully qualify the name by using a unary plus:
221
222 use Catalyst qw/
223 My::Module
224 +Fully::Qualified::Plugin::Name
225 /;
226
ae1e6b59 227Special flags like C<-Debug> and C<-Engine> can also be specified as
228arguments when Catalyst is loaded:
fc7ec1d9 229
230 use Catalyst qw/-Debug My::Module/;
231
ae1e6b59 232The position of plugins and flags in the chain is important, because
86418559 233they are loaded in the order in which they appear.
fc7ec1d9 234
23f9d934 235The following flags are supported:
236
b5ecfcf0 237=head2 -Debug
23f9d934 238
f8ad6ea5 239Enables debug output. You can also force this setting from the system
86418559 240environment with CATALYST_DEBUG or <MYAPP>_DEBUG. The environment
241settings override the application, with <MYAPP>_DEBUG having the highest
242priority.
fc7ec1d9 243
b5ecfcf0 244=head2 -Engine
fc7ec1d9 245
ae1e6b59 246Forces Catalyst to use a specific engine. Omit the
247C<Catalyst::Engine::> prefix of the engine name, i.e.:
fc7ec1d9 248
0ef52a96 249 use Catalyst qw/-Engine=CGI/;
fc7ec1d9 250
b5ecfcf0 251=head2 -Home
fbcc39ad 252
ae1e6b59 253Forces Catalyst to use a specific home directory, e.g.:
254
86418559 255 use Catalyst qw[-Home=/usr/mst];
fbcc39ad 256
cc95842f 257This can also be done in the shell environment by setting either the
258C<CATALYST_HOME> environment variable or C<MYAPP_HOME>; where C<MYAPP>
259is replaced with the uppercased name of your application, any "::" in
260the name will be replaced with underscores, e.g. MyApp::Web should use
261MYAPP_WEB_HOME. If both variables are set, the MYAPP_HOME one will be used.
262
b5ecfcf0 263=head2 -Log
fbcc39ad 264
0ef52a96 265Specifies log level.
fbcc39ad 266
dc5f035e 267=head2 -Stats
268
269Enables statistics collection and reporting. You can also force this setting
270from the system environment with CATALYST_STATS or <MYAPP>_STATS. The
271environment settings override the application, with <MYAPP>_STATS having the
272highest priority.
273
ac5c933b 274e.g.
dc5f035e 275
276 use Catalyst qw/-Stats=1/
277
23f9d934 278=head1 METHODS
279
f7b672ef 280=head2 INFORMATION ABOUT THE CURRENT REQUEST
0ef52a96 281
b5ecfcf0 282=head2 $c->action
66e28e3f 283
ae1e6b59 284Returns a L<Catalyst::Action> object for the current action, which
285stringifies to the action name. See L<Catalyst::Action>.
0ef52a96 286
b5ecfcf0 287=head2 $c->namespace
0ef52a96 288
86418559 289Returns the namespace of the current action, i.e., the URI prefix
ae1e6b59 290corresponding to the controller of the current action. For example:
291
292 # in Controller::Foo::Bar
293 $c->namespace; # returns 'foo/bar';
0ef52a96 294
b5ecfcf0 295=head2 $c->request
0ef52a96 296
b5ecfcf0 297=head2 $c->req
0ef52a96 298
86418559 299Returns the current L<Catalyst::Request> object, giving access to
300information about the current client request (including parameters,
301cookies, HTTP headers, etc.). See L<Catalyst::Request>.
0ef52a96 302
b4b01a8a 303=head2 REQUEST FLOW HANDLING
0ef52a96 304
b5ecfcf0 305=head2 $c->forward( $action [, \@arguments ] )
0ef52a96 306
b5ecfcf0 307=head2 $c->forward( $class, $method, [, \@arguments ] )
0ef52a96 308
86418559 309Forwards processing to another action, by its private name. If you give a
b4b01a8a 310class name but no method, C<process()> is called. You may also optionally
311pass arguments in an arrayref. The action will receive the arguments in
cc95842f 312C<@_> and C<< $c->req->args >>. Upon returning from the function,
313C<< $c->req->args >> will be restored to the previous values.
0ef52a96 314
3b984c64 315Any data C<return>ed from the action forwarded to, will be returned by the
d759db1e 316call to forward.
3b984c64 317
318 my $foodata = $c->forward('/foo');
0ef52a96 319 $c->forward('index');
e112461a 320 $c->forward(qw/MyApp::Model::DBIC::Foo do_stuff/);
0ef52a96 321 $c->forward('MyApp::View::TT');
322
86418559 323Note that forward implies an C<<eval { }>> around the call (actually
324C<execute> does), thus de-fatalizing all 'dies' within the called
325action. If you want C<die> to propagate you need to do something like:
f3e6a8c0 326
327 $c->forward('foo');
328 die $c->error if $c->error;
329
86418559 330Or make sure to always return true values from your actions and write
331your code like this:
f3e6a8c0 332
333 $c->forward('foo') || return;
334
0ef52a96 335=cut
336
6680c772 337sub forward { my $c = shift; no warnings 'recursion'; $c->dispatcher->forward( $c, @_ ) }
0ef52a96 338
b5ecfcf0 339=head2 $c->detach( $action [, \@arguments ] )
0ef52a96 340
b5ecfcf0 341=head2 $c->detach( $class, $method, [, \@arguments ] )
0ef52a96 342
264bac8c 343=head2 $c->detach()
344
ac5c933b 345The same as C<forward>, but doesn't return to the previous action when
346processing is finished.
0ef52a96 347
264bac8c 348When called with no arguments it escapes the processing chain entirely.
349
0ef52a96 350=cut
351
352sub detach { my $c = shift; $c->dispatcher->detach( $c, @_ ) }
353
b4b01a8a 354=head2 $c->response
355
356=head2 $c->res
357
cc95842f 358Returns the current L<Catalyst::Response> object, see there for details.
b4b01a8a 359
360=head2 $c->stash
361
362Returns a hashref to the stash, which may be used to store data and pass
363it between components during a request. You can also set hash keys by
364passing arguments. The stash is automatically sent to the view. The
365stash is cleared at the end of a request; it cannot be used for
86418559 366persistent storage (for this you must use a session; see
367L<Catalyst::Plugin::Session> for a complete system integrated with
368Catalyst).
b4b01a8a 369
370 $c->stash->{foo} = $bar;
371 $c->stash( { moose => 'majestic', qux => 0 } );
372 $c->stash( bar => 1, gorch => 2 ); # equivalent to passing a hashref
ac5c933b 373
b4b01a8a 374 # stash is automatically passed to the view for use in a template
cc95842f 375 $c->forward( 'MyApp::View::TT' );
b4b01a8a 376
377=cut
378
0fc2d522 379sub stash {
b4b01a8a 380 my $c = shift;
381 if (@_) {
382 my $stash = @_ > 1 ? {@_} : $_[0];
85d9fce6 383 croak('stash takes a hash or hashref') unless ref $stash;
c82ed742 384 foreach my $key ( keys %$stash ) {
0fc2d522 385 #shouldn't we hold this in a var and save ourselves the subcall?
386 $c->next::method->{$key} = $stash->{$key};
b4b01a8a 387 }
388 }
0fc2d522 389
390 return $c->next::method;
391}
392
b4b01a8a 393
b5ecfcf0 394=head2 $c->error
0ef52a96 395
b5ecfcf0 396=head2 $c->error($error, ...)
0ef52a96 397
b5ecfcf0 398=head2 $c->error($arrayref)
0ef52a96 399
83a8fcac 400Returns an arrayref containing error messages. If Catalyst encounters an
401error while processing a request, it stores the error in $c->error. This
e7ad3b81 402method should only be used to store fatal error messages.
0ef52a96 403
404 my @error = @{ $c->error };
405
406Add a new error.
407
408 $c->error('Something bad happened');
409
0ef52a96 410=cut
411
412sub error {
413 my $c = shift;
414 if ( $_[0] ) {
415 my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
9ce44430 416 croak @$error unless ref $c;
0ef52a96 417 push @{ $c->{error} }, @$error;
418 }
419 elsif ( defined $_[0] ) { $c->{error} = undef }
420 return $c->{error} || [];
421}
422
b4b01a8a 423
424=head2 $c->state
425
426Contains the return value of the last executed action.
427
ca81eb67 428=head2 $c->clear_errors
429
430Clear errors. You probably don't want to clear the errors unless you are
431implementing a custom error screen.
432
433This is equivalent to running
434
435 $c->error(0);
436
437=cut
438
439sub clear_errors {
440 my $c = shift;
441 $c->error(0);
442}
443
0ef52a96 444
0756fe3b 445# search via regex
446sub _comp_search {
197bd788 447 my ( $c, @names ) = @_;
0756fe3b 448
449 foreach my $name (@names) {
450 foreach my $component ( keys %{ $c->components } ) {
197bd788 451 return $c->components->{$component} if $component =~ /$name/i;
0756fe3b 452 }
453 }
454
455 return undef;
456}
457
458# try explicit component names
459sub _comp_explicit {
197bd788 460 my ( $c, @names ) = @_;
0756fe3b 461
462 foreach my $try (@names) {
197bd788 463 return $c->components->{$try} if ( exists $c->components->{$try} );
0756fe3b 464 }
465
466 return undef;
467}
468
469# like component, but try just these prefixes before regex searching,
470# and do not try to return "sort keys %{ $c->components }"
471sub _comp_prefixes {
197bd788 472 my ( $c, $name, @prefixes ) = @_;
0756fe3b 473
474 my $appclass = ref $c || $c;
475
476 my @names = map { "${appclass}::${_}::${name}" } @prefixes;
477
478 my $comp = $c->_comp_explicit(@names);
479 return $comp if defined($comp);
480 $comp = $c->_comp_search($name);
481 return $comp;
482}
483
ac5c933b 484# Find possible names for a prefix
3b88a455 485
486sub _comp_names {
487 my ( $c, @prefixes ) = @_;
488
489 my $appclass = ref $c || $c;
490
491 my @pre = map { "${appclass}::${_}::" } @prefixes;
492
493 my @names;
494
495 COMPONENT: foreach my $comp ($c->component) {
496 foreach my $p (@pre) {
497 if ($comp =~ s/^$p//) {
498 push(@names, $comp);
499 next COMPONENT;
500 }
501 }
502 }
503
504 return @names;
505}
506
649fd1fa 507# Return a component if only one matches.
508sub _comp_singular {
197bd788 509 my ( $c, @prefixes ) = @_;
649fd1fa 510
511 my $appclass = ref $c || $c;
512
197bd788 513 my ( $comp, $rest ) =
514 map { $c->_comp_search("^${appclass}::${_}::") } @prefixes;
649fd1fa 515 return $comp unless $rest;
516}
517
197bd788 518# Filter a component before returning by calling ACCEPT_CONTEXT if available
519sub _filter_component {
520 my ( $c, $comp, @args ) = @_;
521 if ( eval { $comp->can('ACCEPT_CONTEXT'); } ) {
522 return $comp->ACCEPT_CONTEXT( $c, @args );
523 }
524 else { return $comp }
525}
526
f7b672ef 527=head2 COMPONENT ACCESSORS
0ef52a96 528
b5ecfcf0 529=head2 $c->controller($name)
af3ff00e 530
0ef52a96 531Gets a L<Catalyst::Controller> instance by name.
af3ff00e 532
533 $c->controller('Foo')->do_stuff;
534
86418559 535If the name is omitted, will return the controller for the dispatched
536action.
649fd1fa 537
af3ff00e 538=cut
539
540sub controller {
197bd788 541 my ( $c, $name, @args ) = @_;
542 return $c->_filter_component( $c->_comp_prefixes( $name, qw/Controller C/ ),
543 @args )
544 if ($name);
545 return $c->component( $c->action->class );
af3ff00e 546}
547
b5ecfcf0 548=head2 $c->model($name)
fc7ec1d9 549
0ef52a96 550Gets a L<Catalyst::Model> instance by name.
551
552 $c->model('Foo')->do_stuff;
fc7ec1d9 553
72f87c4b 554Any extra arguments are directly passed to ACCEPT_CONTEXT.
555
ac5c933b 556If the name is omitted, it will look for
a3b71f0f 557 - a model object in $c->stash{current_model_instance}, then
558 - a model name in $c->stash->{current_model}, then
559 - a config setting 'default_model', or
560 - check if there is only one model, and return it if that's the case.
649fd1fa 561
fc7ec1d9 562=cut
563
0ef52a96 564sub model {
197bd788 565 my ( $c, $name, @args ) = @_;
566 return $c->_filter_component( $c->_comp_prefixes( $name, qw/Model M/ ),
567 @args )
568 if $name;
a3b71f0f 569 if (ref $c) {
ac5c933b 570 return $c->stash->{current_model_instance}
a3b71f0f 571 if $c->stash->{current_model_instance};
572 return $c->model( $c->stash->{current_model} )
573 if $c->stash->{current_model};
a3b71f0f 574 }
72f87c4b 575 return $c->model( $c->config->{default_model} )
576 if $c->config->{default_model};
577 return $c->_filter_component( $c->_comp_singular(qw/Model M/) );
649fd1fa 578
0ef52a96 579}
fc7ec1d9 580
b4b01a8a 581=head2 $c->controllers
3b88a455 582
b4b01a8a 583Returns the available names which can be passed to $c->controller
3b88a455 584
585=cut
586
b4b01a8a 587sub controllers {
3b88a455 588 my ( $c ) = @_;
b4b01a8a 589 return $c->_comp_names(qw/Controller C/);
3b88a455 590}
591
b4b01a8a 592
b5ecfcf0 593=head2 $c->view($name)
0ef52a96 594
595Gets a L<Catalyst::View> instance by name.
fc7ec1d9 596
0ef52a96 597 $c->view('Foo')->do_stuff;
fc7ec1d9 598
72f87c4b 599Any extra arguments are directly passed to ACCEPT_CONTEXT.
600
ac5c933b 601If the name is omitted, it will look for
a3b71f0f 602 - a view object in $c->stash{current_view_instance}, then
603 - a view name in $c->stash->{current_view}, then
604 - a config setting 'default_view', or
605 - check if there is only one view, and return it if that's the case.
649fd1fa 606
fc7ec1d9 607=cut
608
0ef52a96 609sub view {
197bd788 610 my ( $c, $name, @args ) = @_;
611 return $c->_filter_component( $c->_comp_prefixes( $name, qw/View V/ ),
612 @args )
613 if $name;
a3b71f0f 614 if (ref $c) {
ac5c933b 615 return $c->stash->{current_view_instance}
a3b71f0f 616 if $c->stash->{current_view_instance};
617 return $c->view( $c->stash->{current_view} )
618 if $c->stash->{current_view};
a3b71f0f 619 }
72f87c4b 620 return $c->view( $c->config->{default_view} )
621 if $c->config->{default_view};
197bd788 622 return $c->_filter_component( $c->_comp_singular(qw/View V/) );
0ef52a96 623}
fbcc39ad 624
b4b01a8a 625=head2 $c->models
626
627Returns the available names which can be passed to $c->model
628
629=cut
630
631sub models {
632 my ( $c ) = @_;
633 return $c->_comp_names(qw/Model M/);
634}
635
636
3b88a455 637=head2 $c->views
638
639Returns the available names which can be passed to $c->view
640
641=cut
642
643sub views {
644 my ( $c ) = @_;
645 return $c->_comp_names(qw/View V/);
646}
647
b4b01a8a 648=head2 $c->comp($name)
649
650=head2 $c->component($name)
651
cc95842f 652Gets a component object by name. This method is not recommended,
b4b01a8a 653unless you want to get a specific component by full
cc95842f 654class. C<< $c->controller >>, C<< $c->model >>, and C<< $c->view >>
b4b01a8a 655should be used instead.
656
657=cut
658
659sub component {
660 my $c = shift;
661
662 if (@_) {
663
664 my $name = shift;
665
666 my $appclass = ref $c || $c;
667
668 my @names = (
669 $name, "${appclass}::${name}",
670 map { "${appclass}::${_}::${name}" }
671 qw/Model M Controller C View V/
672 );
673
674 my $comp = $c->_comp_explicit(@names);
675 return $c->_filter_component( $comp, @_ ) if defined($comp);
676
677 $comp = $c->_comp_search($name);
678 return $c->_filter_component( $comp, @_ ) if defined($comp);
679 }
680
681 return sort keys %{ $c->components };
682}
683
684
685
686=head2 CLASS DATA AND HELPER CLASSES
fbcc39ad 687
b5ecfcf0 688=head2 $c->config
fbcc39ad 689
0ef52a96 690Returns or takes a hashref containing the application's configuration.
691
61b1d329 692 __PACKAGE__->config( { db => 'dsn:SQLite:foo.db' } );
81557adf 693
cc95842f 694You can also use a C<YAML>, C<XML> or C<Config::General> config file
695like myapp.yml in your applications home directory. See
696L<Catalyst::Plugin::ConfigLoader>.
a6ad13b6 697
698 ---
699 db: dsn:SQLite:foo.db
700
b4b01a8a 701
3643e890 702=cut
703
0fc2d522 704sub config {
3643e890 705 my $c = shift;
706
707 $c->log->warn("Setting config after setup has been run is not a good idea.")
708 if ( @_ and $c->setup_finished );
709
0fc2d522 710 $c->next::method(@_);
711}
3643e890 712
b5ecfcf0 713=head2 $c->log
0ef52a96 714
86418559 715Returns the logging object instance. Unless it is already set, Catalyst
716sets this up with a L<Catalyst::Log> object. To use your own log class,
717set the logger with the C<< __PACKAGE__->log >> method prior to calling
9e7673af 718C<< __PACKAGE__->setup >>.
719
720 __PACKAGE__->log( MyLogger->new );
721 __PACKAGE__->setup;
722
723And later:
0ef52a96 724
ae1e6b59 725 $c->log->info( 'Now logging with my own logger!' );
0ef52a96 726
86418559 727Your log class should implement the methods described in
728L<Catalyst::Log>.
af3ff00e 729
b4b01a8a 730
731=head2 $c->debug
732
733Overload to enable debug messages (same as -Debug option).
734
e80e8542 735Note that this is a static method, not an accessor and should be overloaded
736by declaring "sub debug { 1 }" in your MyApp.pm, not by calling $c->debug(1).
737
af3ff00e 738=cut
739
b4b01a8a 740sub debug { 0 }
741
742=head2 $c->dispatcher
743
744Returns the dispatcher instance. Stringifies to class name. See
745L<Catalyst::Dispatcher>.
746
747=head2 $c->engine
748
749Returns the engine instance. Stringifies to the class name. See
750L<Catalyst::Engine>.
751
752
f7b672ef 753=head2 UTILITY METHODS
66e28e3f 754
b5ecfcf0 755=head2 $c->path_to(@path)
01033d73 756
cc95842f 757Merges C<@path> with C<< $c->config->{home} >> and returns a
758L<Path::Class::Dir> object.
01033d73 759
760For example:
761
762 $c->path_to( 'db', 'sqlite.db' );
763
764=cut
765
766sub path_to {
767 my ( $c, @path ) = @_;
a738ab68 768 my $path = Path::Class::Dir->new( $c->config->{home}, @path );
01033d73 769 if ( -d $path ) { return $path }
a738ab68 770 else { return Path::Class::File->new( $c->config->{home}, @path ) }
01033d73 771}
772
b5ecfcf0 773=head2 $c->plugin( $name, $class, @args )
0ef52a96 774
ae1e6b59 775Helper method for plugins. It creates a classdata accessor/mutator and
776loads and instantiates the given class.
0ef52a96 777
778 MyApp->plugin( 'prototype', 'HTML::Prototype' );
779
780 $c->prototype->define_javascript_functions;
781
782=cut
783
784sub plugin {
785 my ( $class, $name, $plugin, @args ) = @_;
97b58e17 786 $class->_register_plugin( $plugin, 1 );
0ef52a96 787
788 eval { $plugin->import };
789 $class->mk_classdata($name);
790 my $obj;
791 eval { $obj = $plugin->new(@args) };
792
793 if ($@) {
794 Catalyst::Exception->throw( message =>
795 qq/Couldn't instantiate instant plugin "$plugin", "$@"/ );
796 }
797
798 $class->$name($obj);
799 $class->log->debug(qq/Initialized instant plugin "$plugin" as "$name"/)
800 if $class->debug;
801}
802
b5ecfcf0 803=head2 MyApp->setup
fbcc39ad 804
e7f1cf73 805Initializes the dispatcher and engine, loads any plugins, and loads the
ae1e6b59 806model, view, and controller components. You may also specify an array
807of plugins to load here, if you choose to not load them in the C<use
808Catalyst> line.
fbcc39ad 809
0ef52a96 810 MyApp->setup;
811 MyApp->setup( qw/-Debug/ );
fbcc39ad 812
813=cut
814
815sub setup {
0319a12c 816 my ( $class, @arguments ) = @_;
6f1f968a 817 Class::C3::initialize;
5168a5fc 818 $class->log->warn("Running setup twice is not a good idea.")
819 if ( $class->setup_finished );
820
fbcc39ad 821 unless ( $class->isa('Catalyst') ) {
953b0e15 822
fbcc39ad 823 Catalyst::Exception->throw(
824 message => qq/'$class' does not inherit from Catalyst/ );
1c99e125 825 }
0319a12c 826
fbcc39ad 827 if ( $class->arguments ) {
828 @arguments = ( @arguments, @{ $class->arguments } );
829 }
830
831 # Process options
832 my $flags = {};
833
834 foreach (@arguments) {
835
836 if (/^-Debug$/) {
837 $flags->{log} =
838 ( $flags->{log} ) ? 'debug,' . $flags->{log} : 'debug';
839 }
840 elsif (/^-(\w+)=?(.*)$/) {
841 $flags->{ lc $1 } = $2;
842 }
843 else {
844 push @{ $flags->{plugins} }, $_;
845 }
846 }
847
99f187d6 848 $class->setup_home( delete $flags->{home} );
849
fbcc39ad 850 $class->setup_log( delete $flags->{log} );
851 $class->setup_plugins( delete $flags->{plugins} );
852 $class->setup_dispatcher( delete $flags->{dispatcher} );
853 $class->setup_engine( delete $flags->{engine} );
dc5f035e 854 $class->setup_stats( delete $flags->{stats} );
fbcc39ad 855
856 for my $flag ( sort keys %{$flags} ) {
857
858 if ( my $code = $class->can( 'setup_' . $flag ) ) {
859 &$code( $class, delete $flags->{$flag} );
860 }
861 else {
862 $class->log->warn(qq/Unknown flag "$flag"/);
863 }
864 }
865
0eb4af72 866 eval { require Catalyst::Devel; };
867 if( !$@ && $ENV{CATALYST_SCRIPT_GEN} && ( $ENV{CATALYST_SCRIPT_GEN} < $Catalyst::Devel::CATALYST_SCRIPT_GEN ) ) {
868 $class->log->warn(<<"EOF");
4ff0d824 869You are running an old script!
870
34a83d89 871 Please update by running (this will overwrite existing files):
872 catalyst.pl -force -scripts $class
873
874 or (this will not overwrite existing files):
875 catalyst.pl -scripts $class
1cf0345b 876
4ff0d824 877EOF
0eb4af72 878 }
ac5c933b 879
fbcc39ad 880 if ( $class->debug ) {
6601f2ad 881 my @plugins = map { "$_ " . ( $_->VERSION || '' ) } $class->registered_plugins;
fbcc39ad 882
883 if (@plugins) {
34d28dfd 884 my $t = Text::SimpleTable->new(74);
8c113188 885 $t->row($_) for @plugins;
1cf0345b 886 $class->log->debug( "Loaded plugins:\n" . $t->draw . "\n" );
fbcc39ad 887 }
888
889 my $dispatcher = $class->dispatcher;
890 my $engine = $class->engine;
891 my $home = $class->config->{home};
892
893 $class->log->debug(qq/Loaded dispatcher "$dispatcher"/);
894 $class->log->debug(qq/Loaded engine "$engine"/);
895
896 $home
897 ? ( -d $home )
898 ? $class->log->debug(qq/Found home "$home"/)
899 : $class->log->debug(qq/Home "$home" doesn't exist/)
900 : $class->log->debug(q/Couldn't find home/);
901 }
902
903 # Call plugins setup
904 {
905 no warnings qw/redefine/;
906 local *setup = sub { };
907 $class->setup;
908 }
909
910 # Initialize our data structure
911 $class->components( {} );
912
913 $class->setup_components;
914
915 if ( $class->debug ) {
34d28dfd 916 my $t = Text::SimpleTable->new( [ 63, 'Class' ], [ 8, 'Type' ] );
684d10ed 917 for my $comp ( sort keys %{ $class->components } ) {
918 my $type = ref $class->components->{$comp} ? 'instance' : 'class';
919 $t->row( $comp, $type );
920 }
1cf0345b 921 $class->log->debug( "Loaded components:\n" . $t->draw . "\n" )
8c113188 922 if ( keys %{ $class->components } );
fbcc39ad 923 }
924
925 # Add our self to components, since we are also a component
96d8d513 926 if( $class->isa('Catalyst::Controller') ){
927 $class->components->{$class} = $class;
928 }
fbcc39ad 929
930 $class->setup_actions;
931
932 if ( $class->debug ) {
933 my $name = $class->config->{name} || 'Application';
934 $class->log->info("$name powered by Catalyst $Catalyst::VERSION");
935 }
936 $class->log->_flush() if $class->log->can('_flush');
3643e890 937
938 $class->setup_finished(1);
6f1f968a 939 Class::C3::initialize;
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"/
84ff88cf 1939 ) unless blessed($instance);
364d7324 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
84ff88cf 1991 $class->meta->add_method('apache' => sub { shift->engine->apache });
fbcc39ad 1992
1993 my ( $software, $version ) =
1994 $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
1995
1996 $version =~ s/_//g;
1997 $version =~ s/(\.[^.]+)\./$1/g;
1998
1999 if ( $software eq 'mod_perl' ) {
2000
9b0a3e0f 2001 if ( !$engine ) {
22247e54 2002
9b0a3e0f 2003 if ( $version >= 1.99922 ) {
2004 $engine = 'Catalyst::Engine::Apache2::MP20';
2005 }
22247e54 2006
9b0a3e0f 2007 elsif ( $version >= 1.9901 ) {
2008 $engine = 'Catalyst::Engine::Apache2::MP19';
2009 }
22247e54 2010
9b0a3e0f 2011 elsif ( $version >= 1.24 ) {
2012 $engine = 'Catalyst::Engine::Apache::MP13';
2013 }
22247e54 2014
9b0a3e0f 2015 else {
2016 Catalyst::Exception->throw( message =>
2017 qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
2018 }
fbcc39ad 2019
fbcc39ad 2020 }
2021
2022 # install the correct mod_perl handler
2023 if ( $version >= 1.9901 ) {
2024 *handler = sub : method {
2025 shift->handle_request(@_);
2026 };
2027 }
2028 else {
2029 *handler = sub ($$) { shift->handle_request(@_) };
2030 }
2031
2032 }
2033
2034 elsif ( $software eq 'Zeus-Perl' ) {
2035 $engine = 'Catalyst::Engine::Zeus';
2036 }
2037
2038 else {
2039 Catalyst::Exception->throw(
2040 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
2041 }
2042 }
2043
2044 unless ($engine) {
cb0354c6 2045 $engine = $class->engine_class;
fbcc39ad 2046 }
2047
e63bdf38 2048 Class::MOP::load_class($engine);
2049 #unless (Class::Inspector->loaded($engine)) {
2050 # require Class::Inspector->filename($engine);
2051 #}
0e7f5826 2052
d54484bf 2053 # check for old engines that are no longer compatible
2054 my $old_engine;
0e7f5826 2055 if ( $engine->isa('Catalyst::Engine::Apache')
2056 && !Catalyst::Engine::Apache->VERSION )
d54484bf 2057 {
2058 $old_engine = 1;
2059 }
0e7f5826 2060
d54484bf 2061 elsif ( $engine->isa('Catalyst::Engine::Server::Base')
0e7f5826 2062 && Catalyst::Engine::Server->VERSION le '0.02' )
d54484bf 2063 {
2064 $old_engine = 1;
2065 }
0e7f5826 2066
2067 elsif ($engine->isa('Catalyst::Engine::HTTP::POE')
2068 && $engine->VERSION eq '0.01' )
d54484bf 2069 {
2070 $old_engine = 1;
2071 }
0e7f5826 2072
2073 elsif ($engine->isa('Catalyst::Engine::Zeus')
2074 && $engine->VERSION eq '0.01' )
d54484bf 2075 {
2076 $old_engine = 1;
2077 }
fbcc39ad 2078
d54484bf 2079 if ($old_engine) {
2080 Catalyst::Exception->throw( message =>
0e7f5826 2081 qq/Engine "$engine" is not supported by this version of Catalyst/
d54484bf 2082 );
2083 }
0e7f5826 2084
fbcc39ad 2085 # engine instance
2086 $class->engine( $engine->new );
2087}
2088
b5ecfcf0 2089=head2 $c->setup_home
fbcc39ad 2090
ae1e6b59 2091Sets up the home directory.
2092
fbcc39ad 2093=cut
2094
2095sub setup_home {
2096 my ( $class, $home ) = @_;
2097
cb69249e 2098 if ( my $env = Catalyst::Utils::env_value( $class, 'HOME' ) ) {
2099 $home = $env;
fbcc39ad 2100 }
2101
b6d4ee6e 2102 $home ||= Catalyst::Utils::home($class);
fbcc39ad 2103
2104 if ($home) {
e63bdf38 2105 #I remember recently being scolded for assigning config values like this
fbcc39ad 2106 $class->config->{home} ||= $home;
a738ab68 2107 $class->config->{root} ||= Path::Class::Dir->new($home)->subdir('root');
fbcc39ad 2108 }
2109}
2110
b5ecfcf0 2111=head2 $c->setup_log
fbcc39ad 2112
ae1e6b59 2113Sets up log.
2114
fbcc39ad 2115=cut
2116
2117sub setup_log {
2118 my ( $class, $debug ) = @_;
2119
2120 unless ( $class->log ) {
2121 $class->log( Catalyst::Log->new );
2122 }
af3ff00e 2123
cb69249e 2124 my $env_debug = Catalyst::Utils::env_value( $class, 'DEBUG' );
2125 if ( defined($env_debug) ? $env_debug : $debug ) {
84ff88cf 2126 $class->meta->add_method('debug' => sub { 1 });
fbcc39ad 2127 $class->log->debug('Debug messages enabled');
2128 }
2129}
2130
b5ecfcf0 2131=head2 $c->setup_plugins
fbcc39ad 2132
ae1e6b59 2133Sets up plugins.
2134
fbcc39ad 2135=cut
2136
dc5f035e 2137=head2 $c->setup_stats
2138
2139Sets up timing statistics class.
2140
2141=cut
2142
2143sub setup_stats {
2144 my ( $class, $stats ) = @_;
2145
2146 Catalyst::Utils::ensure_class_loaded($class->stats_class);
2147
2148 my $env = Catalyst::Utils::env_value( $class, 'STATS' );
2149 if ( defined($env) ? $env : ($stats || $class->debug ) ) {
84ff88cf 2150 $class->meta->add_method('use_stats' => sub { 1 });
b01f0c69 2151 $class->log->debug('Statistics enabled');
dc5f035e 2152 }
2153}
2154
2155
ac5c933b 2156=head2 $c->registered_plugins
836e1134 2157
2158Returns a sorted list of the plugins which have either been stated in the
2159import list or which have been added via C<< MyApp->plugin(@args); >>.
2160
2161If passed a given plugin name, it will report a boolean value indicating
2162whether or not that plugin is loaded. A fully qualified name is required if
2163the plugin name does not begin with C<Catalyst::Plugin::>.
2164
2165 if ($c->registered_plugins('Some::Plugin')) {
2166 ...
2167 }
2168
2169=cut
fbcc39ad 2170
836e1134 2171{
97b58e17 2172
2173 sub registered_plugins {
836e1134 2174 my $proto = shift;
197bd788 2175 return sort keys %{ $proto->_plugins } unless @_;
836e1134 2176 my $plugin = shift;
d0d4d785 2177 return 1 if exists $proto->_plugins->{$plugin};
2178 return exists $proto->_plugins->{"Catalyst::Plugin::$plugin"};
836e1134 2179 }
fbcc39ad 2180
836e1134 2181 sub _register_plugin {
2182 my ( $proto, $plugin, $instant ) = @_;
2183 my $class = ref $proto || $proto;
fbcc39ad 2184
dd91afb5 2185 # no ignore_loaded here, the plugin may already have been
2186 # defined in memory and we don't want to error on "no file" if so
2187
b6d4ee6e 2188 Class::MOP::load_class( $plugin );
fbcc39ad 2189
197bd788 2190 $proto->_plugins->{$plugin} = 1;
836e1134 2191 unless ($instant) {
fbcc39ad 2192 no strict 'refs';
5fb67d52 2193 if( $class->can('meta') ){
2194 my @superclasses = ($plugin, $class->meta->superclasses );
2195 $class->meta->superclasses(@superclasses);
2196 } else {
2197 unshift @{"$class\::ISA"}, $plugin;
2198 }
fbcc39ad 2199 }
836e1134 2200 return $class;
2201 }
2202
2203 sub setup_plugins {
2204 my ( $class, $plugins ) = @_;
2205
d0d4d785 2206 $class->_plugins( {} ) unless $class->_plugins;
836e1134 2207 $plugins ||= [];
2208 for my $plugin ( reverse @$plugins ) {
2209
2210 unless ( $plugin =~ s/\A\+// ) {
2211 $plugin = "Catalyst::Plugin::$plugin";
2212 }
2213
2214 $class->_register_plugin($plugin);
2215 }
fbcc39ad 2216 }
2217}
2218
b5ecfcf0 2219=head2 $c->stack
8767c5a3 2220
86418559 2221Returns an arrayref of the internal execution stack (actions that are
2222currently executing).
8767c5a3 2223
dc5f035e 2224=head2 $c->stats_class
2225
2226Returns or sets the stats (timing statistics) class.
2227
2228=head2 $c->use_stats
2229
2230Returns 1 when stats collection is enabled. Stats collection is enabled
2231when the -Stats options is set, debug is on or when the <MYAPP>_STATS
2232environment variable is set.
2233
2234Note that this is a static method, not an accessor and should be overloaded
2235by declaring "sub use_stats { 1 }" in your MyApp.pm, not by calling $c->use_stats(1).
2236
2237=cut
2238
2239sub use_stats { 0 }
2240
2241
b5ecfcf0 2242=head2 $c->write( $data )
fbcc39ad 2243
ae1e6b59 2244Writes $data to the output stream. When using this method directly, you
2245will need to manually set the C<Content-Length> header to the length of
2246your output data, if known.
fbcc39ad 2247
2248=cut
2249
4f5ebacd 2250sub write {
2251 my $c = shift;
2252
2253 # Finalize headers if someone manually writes output
2254 $c->finalize_headers;
2255
2256 return $c->engine->write( $c, @_ );
2257}
fbcc39ad 2258
b5ecfcf0 2259=head2 version
bf88a181 2260
ae1e6b59 2261Returns the Catalyst version number. Mostly useful for "powered by"
2262messages in template systems.
bf88a181 2263
2264=cut
2265
2266sub version { return $Catalyst::VERSION }
2267
b0bb11ec 2268=head1 INTERNAL ACTIONS
2269
ae1e6b59 2270Catalyst uses internal actions like C<_DISPATCH>, C<_BEGIN>, C<_AUTO>,
2271C<_ACTION>, and C<_END>. These are by default not shown in the private
3e705254 2272action table, but you can make them visible with a config parameter.
b0bb11ec 2273
2274 MyApp->config->{show_internal_actions} = 1;
2275
d2ee9760 2276=head1 CASE SENSITIVITY
2277
3e705254 2278By default Catalyst is not case sensitive, so C<MyApp::C::FOO::Bar> is
ae1e6b59 2279mapped to C</foo/bar>. You can activate case sensitivity with a config
3e705254 2280parameter.
d2ee9760 2281
2282 MyApp->config->{case_sensitive} = 1;
2283
3e705254 2284This causes C<MyApp::C::Foo::Bar> to map to C</Foo/Bar>.
fbcc39ad 2285
2286=head1 ON-DEMAND PARSER
2287
2288The request body is usually parsed at the beginning of a request,
878b821c 2289but if you want to handle input yourself, you can enable on-demand
2290parsing with a config parameter.
fbcc39ad 2291
2292 MyApp->config->{parse_on_demand} = 1;
ac5c933b 2293
fbcc39ad 2294=head1 PROXY SUPPORT
2295
ae1e6b59 2296Many production servers operate using the common double-server approach,
2297with a lightweight frontend web server passing requests to a larger
2298backend server. An application running on the backend server must deal
2299with two problems: the remote user always appears to be C<127.0.0.1> and
2300the server's hostname will appear to be C<localhost> regardless of the
2301virtual host that the user connected through.
fbcc39ad 2302
ae1e6b59 2303Catalyst will automatically detect this situation when you are running
2304the frontend and backend servers on the same machine. The following
2305changes are made to the request.
fbcc39ad 2306
ac5c933b 2307 $c->req->address is set to the user's real IP address, as read from
ae1e6b59 2308 the HTTP X-Forwarded-For header.
ac5c933b 2309
ae1e6b59 2310 The host value for $c->req->base and $c->req->uri is set to the real
2311 host, as read from the HTTP X-Forwarded-Host header.
fbcc39ad 2312
3e705254 2313Obviously, your web server must support these headers for this to work.
fbcc39ad 2314
ae1e6b59 2315In a more complex server farm environment where you may have your
2316frontend proxy server(s) on different machines, you will need to set a
2317configuration option to tell Catalyst to read the proxied data from the
2318headers.
fbcc39ad 2319
2320 MyApp->config->{using_frontend_proxy} = 1;
ac5c933b 2321
fbcc39ad 2322If you do not wish to use the proxy support at all, you may set:
d1a31ac6 2323
fbcc39ad 2324 MyApp->config->{ignore_frontend_proxy} = 1;
2325
2326=head1 THREAD SAFETY
2327
86418559 2328Catalyst has been tested under Apache 2's threading C<mpm_worker>,
2329C<mpm_winnt>, and the standalone forking HTTP server on Windows. We
2330believe the Catalyst core to be thread-safe.
fbcc39ad 2331
2332If you plan to operate in a threaded environment, remember that all other
3e705254 2333modules you are using must also be thread-safe. Some modules, most notably
2334L<DBD::SQLite>, are not thread-safe.
d1a31ac6 2335
3cb1db8c 2336=head1 SUPPORT
2337
2338IRC:
2339
4eaf7c88 2340 Join #catalyst on irc.perl.org.
3cb1db8c 2341
3e705254 2342Mailing Lists:
3cb1db8c 2343
2344 http://lists.rawmode.org/mailman/listinfo/catalyst
2345 http://lists.rawmode.org/mailman/listinfo/catalyst-dev
1985c30b 2346
432d507d 2347Web:
2348
2349 http://catalyst.perl.org
2350
0ef52a96 2351Wiki:
2352
2353 http://dev.catalyst.perl.org
2354
fc7ec1d9 2355=head1 SEE ALSO
2356
829a28ca 2357=head2 L<Task::Catalyst> - All you need to start with Catalyst
2358
b5ecfcf0 2359=head2 L<Catalyst::Manual> - The Catalyst Manual
e7f1cf73 2360
b5ecfcf0 2361=head2 L<Catalyst::Component>, L<Catalyst::Base> - Base classes for components
61b1e958 2362
b5ecfcf0 2363=head2 L<Catalyst::Engine> - Core engine
61b1e958 2364
b5ecfcf0 2365=head2 L<Catalyst::Log> - Log class.
61b1e958 2366
b5ecfcf0 2367=head2 L<Catalyst::Request> - Request object
61b1e958 2368
b5ecfcf0 2369=head2 L<Catalyst::Response> - Response object
61b1e958 2370
b5ecfcf0 2371=head2 L<Catalyst::Test> - The test suite.
fc7ec1d9 2372
15f0b5b7 2373=head1 CREDITS
fc7ec1d9 2374
15f0b5b7 2375Andy Grundman
2376
fbcc39ad 2377Andy Wardley
2378
33108eaf 2379Andreas Marienborg
2380
f4a57de4 2381Andrew Bramble
2382
15f0b5b7 2383Andrew Ford
2384
2385Andrew Ruthven
2386
fbcc39ad 2387Arthur Bergman
2388
15f0b5b7 2389Autrijus Tang
2390
0cf56dbc 2391Brian Cassidy
2392
6aaa1c60 2393Carl Franks
2394
15f0b5b7 2395Christian Hansen
2396
2397Christopher Hicks
2398
2399Dan Sully
2400
2401Danijel Milicevic
2402
0ef52a96 2403David Kamholz
2404
15f0b5b7 2405David Naughton
2406
61bef238 2407Drew Taylor
2408
15f0b5b7 2409Gary Ashton Jones
2410
2411Geoff Richards
2412
2413Jesse Sheidlower
2414
fbcc39ad 2415Jesse Vincent
2416
15f0b5b7 2417Jody Belka
2418
2419Johan Lindstrom
2420
2421Juan Camacho
2422
2423Leon Brocard
2424
2425Marcus Ramberg
2426
2427Matt S Trout
2428
71c3bcc3 2429Robert Sedlacek
2430
a727119f 2431Sam Vilain
2432
1cf1c56a 2433Sascha Kiefer
2434
9c71d51d 2435Sebastian Willert
2436
15f0b5b7 2437Tatsuhiko Miyagawa
fc7ec1d9 2438
51f0308d 2439Ulf Edvinsson
2440
bdcb95ef 2441Yuval Kogman
2442
51f0308d 2443=head1 AUTHOR
2444
2445Sebastian Riedel, C<sri@oook.de>
2446
fc7ec1d9 2447=head1 LICENSE
2448
9ce5ab63 2449This library is free software, you can redistribute it and/or modify it under
41ca9ba7 2450the same terms as Perl itself.
fc7ec1d9 2451
2452=cut
2453
24541;