f36117b39b806391ea7ca74a60399b2336b03475
[catagits/Catalyst-Runtime.git] / lib / Catalyst.pm
1 package Catalyst;
2
3 use Moose;
4 use Moose::Meta::Class ();
5 extends 'Catalyst::Component';
6 use Moose::Util qw/find_meta/;
7 use B::Hooks::EndOfScope ();
8 use Catalyst::Exception;
9 use Catalyst::Exception::Detach;
10 use Catalyst::Exception::Go;
11 use Catalyst::Log;
12 use Catalyst::Request;
13 use Catalyst::Request::Upload;
14 use Catalyst::Response;
15 use Catalyst::Utils;
16 use Catalyst::Controller;
17 use Data::OptList;
18 use File::stat;
19 use Text::SimpleTable ();
20 use Path::Class::Dir ();
21 use Path::Class::File ();
22 use URI ();
23 use URI::http;
24 use URI::https;
25 use Tree::Simple qw/use_weak_refs/;
26 use Tree::Simple::Visitor::FindByUID;
27 use Class::C3::Adopt::NEXT;
28 use List::MoreUtils qw/uniq/;
29 use attributes;
30 use utf8;
31 use Carp qw/croak carp shortmess/;
32
33 BEGIN { require 5.008004; }
34
35 has stack => (is => 'ro', default => sub { [] });
36 has stash => (is => 'rw', default => sub { {} });
37 has state => (is => 'rw', default => 0);
38 has stats => (is => 'rw');
39 has action => (is => 'rw');
40 has counter => (is => 'rw', default => sub { {} });
41 has request => (is => 'rw', default => sub { $_[0]->request_class->new({}) }, required => 1, lazy => 1);
42 has response => (is => 'rw', default => sub { $_[0]->response_class->new({}) }, required => 1, lazy => 1);
43 has namespace => (is => 'rw');
44
45 sub depth { scalar @{ shift->stack || [] }; }
46 sub comp { shift->component(@_) }
47
48 sub req {
49     my $self = shift; return $self->request(@_);
50 }
51 sub res {
52     my $self = shift; return $self->response(@_);
53 }
54
55 # For backwards compatibility
56 sub finalize_output { shift->finalize_body(@_) };
57
58 # For statistics
59 our $COUNT     = 1;
60 our $START     = time;
61 our $RECURSION = 1000;
62 our $DETACH    = Catalyst::Exception::Detach->new;
63 our $GO        = Catalyst::Exception::Go->new;
64
65 #I imagine that very few of these really need to be class variables. if any.
66 #maybe we should just make them attributes with a default?
67 __PACKAGE__->mk_classdata($_)
68   for qw/container arguments dispatcher engine log dispatcher_class
69   engine_class context_class request_class response_class stats_class
70   setup_finished/;
71
72 __PACKAGE__->dispatcher_class('Catalyst::Dispatcher');
73 __PACKAGE__->engine_class('Catalyst::Engine::CGI');
74 __PACKAGE__->request_class('Catalyst::Request');
75 __PACKAGE__->response_class('Catalyst::Response');
76 __PACKAGE__->stats_class('Catalyst::Stats');
77
78 # Remember to update this in Catalyst::Runtime as well!
79
80 our $VERSION = '5.80033';
81
82 sub import {
83     my ( $class, @arguments ) = @_;
84
85     # We have to limit $class to Catalyst to avoid pushing Catalyst upon every
86     # callers @ISA.
87     return unless $class eq 'Catalyst';
88
89     my $caller = caller();
90     return if $caller eq 'main';
91
92     my $meta = Moose::Meta::Class->initialize($caller);
93
94     unless ( $caller->isa('Catalyst') ) { # XXX - Remove!
95         my @superclasses = ($meta->superclasses, $class, 'Catalyst::Component'); # XXX - Remove!
96         $meta->superclasses(@superclasses); # XXX - Remove!
97     } # XXX - Remove!
98
99     # Avoid possible C3 issues if 'Moose::Object' is already on RHS of MyApp
100     $meta->superclasses(grep { $_ ne 'Moose::Object' } $meta->superclasses);
101
102     unless( $meta->has_method('meta') ){
103         if ($Moose::VERSION >= 1.15) {
104             $meta->_add_meta_method('meta');
105         }
106         else {
107             $meta->add_method(meta => sub { Moose::Meta::Class->initialize("${caller}") } );
108         }
109     }
110
111     $caller->arguments( [@arguments] );
112     $caller->setup_home;
113 }
114
115 sub MODIFY_CODE_ATTRIBUTES {
116     Catalyst::Exception->throw(
117         "Catalyst applications (aka MyApp) cannot be controllers anymore. " .
118         "That has been deprecated and removed. You should create a " .
119         "controller class called Root.pm, and move relevant code to that class."
120     );
121 }
122
123
124 sub _application { $_[0] }
125
126 =head1 NAME
127
128 Catalyst - The Elegant MVC Web Application Framework
129
130 =head1 SYNOPSIS
131
132 See the L<Catalyst::Manual> distribution for comprehensive
133 documentation and tutorials.
134
135     # Install Catalyst::Devel for helpers and other development tools
136     # use the helper to create a new application
137     catalyst.pl MyApp
138
139     # add models, views, controllers
140     script/myapp_create.pl model MyDatabase DBIC::Schema create=static dbi:SQLite:/path/to/db
141     script/myapp_create.pl view MyTemplate TT
142     script/myapp_create.pl controller Search
143
144     # built in testserver -- use -r to restart automatically on changes
145     # --help to see all available options
146     script/myapp_server.pl
147
148     # command line testing interface
149     script/myapp_test.pl /yada
150
151     ### in lib/MyApp.pm
152     use Catalyst qw/-Debug/; # include plugins here as well
153
154     ### In lib/MyApp/Controller/Root.pm (autocreated)
155     sub foo : Global { # called for /foo, /foo/1, /foo/1/2, etc.
156         my ( $self, $c, @args ) = @_; # args are qw/1 2/ for /foo/1/2
157         $c->stash->{template} = 'foo.tt'; # set the template
158         # lookup something from db -- stash vars are passed to TT
159         $c->stash->{data} =
160           $c->model('Database::Foo')->search( { country => $args[0] } );
161         if ( $c->req->params->{bar} ) { # access GET or POST parameters
162             $c->forward( 'bar' ); # process another action
163             # do something else after forward returns
164         }
165     }
166
167     # The foo.tt TT template can use the stash data from the database
168     [% WHILE (item = data.next) %]
169         [% item.foo %]
170     [% END %]
171
172     # called for /bar/of/soap, /bar/of/soap/10, etc.
173     sub bar : Path('/bar/of/soap') { ... }
174
175     # called for all actions, from the top-most controller downwards
176     sub auto : Private {
177         my ( $self, $c ) = @_;
178         if ( !$c->user_exists ) { # Catalyst::Plugin::Authentication
179             $c->res->redirect( '/login' ); # require login
180             return 0; # abort request and go immediately to end()
181         }
182         return 1; # success; carry on to next action
183     }
184
185     # called after all actions are finished
186     sub end : Private {
187         my ( $self, $c ) = @_;
188         if ( scalar @{ $c->error } ) { ... } # handle errors
189         return if $c->res->body; # already have a response
190         $c->forward( 'MyApp::View::TT' ); # render template
191     }
192
193     ### in MyApp/Controller/Foo.pm
194     # called for /foo/bar
195     sub bar : Local { ... }
196
197     # called for /blargle
198     sub blargle : Global { ... }
199
200     # an index action matches /foo, but not /foo/1, etc.
201     sub index : Private { ... }
202
203     ### in MyApp/Controller/Foo/Bar.pm
204     # called for /foo/bar/baz
205     sub baz : Local { ... }
206
207     # first Root auto is called, then Foo auto, then this
208     sub auto : Private { ... }
209
210     # powerful regular expression paths are also possible
211     sub details : Regex('^product/(\w+)/details$') {
212         my ( $self, $c ) = @_;
213         # extract the (\w+) from the URI
214         my $product = $c->req->captures->[0];
215     }
216
217 See L<Catalyst::Manual::Intro> for additional information.
218
219 =head1 DESCRIPTION
220
221 Catalyst is a modern framework for making web applications without the
222 pain usually associated with this process. This document is a reference
223 to the main Catalyst application. If you are a new user, we suggest you
224 start with L<Catalyst::Manual::Tutorial> or L<Catalyst::Manual::Intro>.
225
226 See L<Catalyst::Manual> for more documentation.
227
228 Catalyst plugins can be loaded by naming them as arguments to the "use
229 Catalyst" statement. Omit the C<Catalyst::Plugin::> prefix from the
230 plugin name, i.e., C<Catalyst::Plugin::My::Module> becomes
231 C<My::Module>.
232
233     use Catalyst qw/My::Module/;
234
235 If your plugin starts with a name other than C<Catalyst::Plugin::>, you can
236 fully qualify the name by using a unary plus:
237
238     use Catalyst qw/
239         My::Module
240         +Fully::Qualified::Plugin::Name
241     /;
242
243 Special flags like C<-Debug> and C<-Engine> can also be specified as
244 arguments when Catalyst is loaded:
245
246     use Catalyst qw/-Debug My::Module/;
247
248 The position of plugins and flags in the chain is important, because
249 they are loaded in the order in which they appear.
250
251 The following flags are supported:
252
253 =head2 -Debug
254
255 Enables debug output. You can also force this setting from the system
256 environment with CATALYST_DEBUG or <MYAPP>_DEBUG. The environment
257 settings override the application, with <MYAPP>_DEBUG having the highest
258 priority.
259
260 This sets the log level to 'debug' and enables full debug output on the
261 error screen. If you only want the latter, see L<< $c->debug >>.
262
263 =head2 -Engine
264
265 Forces Catalyst to use a specific engine. Omit the
266 C<Catalyst::Engine::> prefix of the engine name, i.e.:
267
268     use Catalyst qw/-Engine=CGI/;
269
270 =head2 -Home
271
272 Forces Catalyst to use a specific home directory, e.g.:
273
274     use Catalyst qw[-Home=/usr/mst];
275
276 This can also be done in the shell environment by setting either the
277 C<CATALYST_HOME> environment variable or C<MYAPP_HOME>; where C<MYAPP>
278 is replaced with the uppercased name of your application, any "::" in
279 the name will be replaced with underscores, e.g. MyApp::Web should use
280 MYAPP_WEB_HOME. If both variables are set, the MYAPP_HOME one will be used.
281
282 If none of these are set, Catalyst will attempt to automatically detect the
283 home directory. If you are working in a development envirnoment, Catalyst
284 will try and find the directory containing either Makefile.PL, Build.PL or
285 dist.ini. If the application has been installed into the system (i.e.
286 you have done C<make install>), then Catalyst will use the path to your
287 application module, without the .pm extension (ie, /foo/MyApp if your
288 application was installed at /foo/MyApp.pm)
289
290 =head2 -Log
291
292     use Catalyst '-Log=warn,fatal,error';
293
294 Specifies a comma-delimited list of log levels.
295
296 =head2 -Stats
297
298 Enables statistics collection and reporting.
299
300    use Catalyst qw/-Stats=1/;
301
302 You can also force this setting from the system environment with CATALYST_STATS
303 or <MYAPP>_STATS. The environment settings override the application, with
304 <MYAPP>_STATS having the highest priority.
305
306 Stats are also enabled if L<< debugging |/"-Debug" >> is enabled.
307
308 =head1 METHODS
309
310 =head2 INFORMATION ABOUT THE CURRENT REQUEST
311
312 =head2 $c->action
313
314 Returns a L<Catalyst::Action> object for the current action, which
315 stringifies to the action name. See L<Catalyst::Action>.
316
317 =head2 $c->namespace
318
319 Returns the namespace of the current action, i.e., the URI prefix
320 corresponding to the controller of the current action. For example:
321
322     # in Controller::Foo::Bar
323     $c->namespace; # returns 'foo/bar';
324
325 =head2 $c->request
326
327 =head2 $c->req
328
329 Returns the current L<Catalyst::Request> object, giving access to
330 information about the current client request (including parameters,
331 cookies, HTTP headers, etc.). See L<Catalyst::Request>.
332
333 =head2 REQUEST FLOW HANDLING
334
335 =head2 $c->forward( $action [, \@arguments ] )
336
337 =head2 $c->forward( $class, $method, [, \@arguments ] )
338
339 Forwards processing to another action, by its private name. If you give a
340 class name but no method, C<process()> is called. You may also optionally
341 pass arguments in an arrayref. The action will receive the arguments in
342 C<@_> and C<< $c->req->args >>. Upon returning from the function,
343 C<< $c->req->args >> will be restored to the previous values.
344
345 Any data C<return>ed from the action forwarded to, will be returned by the
346 call to forward.
347
348     my $foodata = $c->forward('/foo');
349     $c->forward('index');
350     $c->forward(qw/Model::DBIC::Foo do_stuff/);
351     $c->forward('View::TT');
352
353 Note that L<< forward|/"$c->forward( $action [, \@arguments ] )" >> implies
354 an C<< eval { } >> around the call (actually
355 L<< execute|/"$c->execute( $class, $coderef )" >> does), thus de-fatalizing
356 all 'dies' within the called action. If you want C<die> to propagate you
357 need to do something like:
358
359     $c->forward('foo');
360     die join "\n", @{ $c->error } if @{ $c->error };
361
362 Or make sure to always return true values from your actions and write
363 your code like this:
364
365     $c->forward('foo') || return;
366
367 Another note is that C<< $c->forward >> always returns a scalar because it
368 actually returns $c->state which operates in a scalar context.
369 Thus, something like:
370
371     return @array;
372
373 in an action that is forwarded to is going to return a scalar,
374 i.e. how many items are in that array, which is probably not what you want.
375 If you need to return an array then return a reference to it,
376 or stash it like so:
377
378     $c->stash->{array} = \@array;
379
380 and access it from the stash.
381
382 Keep in mind that the C<end> method used is that of the caller action. So a C<$c-E<gt>detach> inside a forwarded action would run the C<end> method from the original action requested.
383
384 =cut
385
386 sub forward { my $c = shift; no warnings 'recursion'; $c->dispatcher->forward( $c, @_ ) }
387
388 =head2 $c->detach( $action [, \@arguments ] )
389
390 =head2 $c->detach( $class, $method, [, \@arguments ] )
391
392 =head2 $c->detach()
393
394 The same as L<< forward|/"$c->forward( $action [, \@arguments ] )" >>, but
395 doesn't return to the previous action when processing is finished.
396
397 When called with no arguments it escapes the processing chain entirely.
398
399 =cut
400
401 sub detach { my $c = shift; $c->dispatcher->detach( $c, @_ ) }
402
403 =head2 $c->visit( $action [, \@captures, \@arguments ] )
404
405 =head2 $c->visit( $class, $method, [, \@captures, \@arguments ] )
406
407 Almost the same as L<< forward|/"$c->forward( $action [, \@arguments ] )" >>,
408 but does a full dispatch, instead of just calling the new C<$action> /
409 C<< $class->$method >>. This means that C<begin>, C<auto> and the method
410 you go to are called, just like a new request.
411
412 In addition both C<< $c->action >> and C<< $c->namespace >> are localized.
413 This means, for example, that C<< $c->action >> methods such as
414 L<name|Catalyst::Action/name>, L<class|Catalyst::Action/class> and
415 L<reverse|Catalyst::Action/reverse> return information for the visited action
416 when they are invoked within the visited action.  This is different from the
417 behavior of L<< forward|/"$c->forward( $action [, \@arguments ] )" >>, which
418 continues to use the $c->action object from the caller action even when
419 invoked from the callee.
420
421 C<< $c->stash >> is kept unchanged.
422
423 In effect, L<< visit|/"$c->visit( $action [, \@captures, \@arguments ] )" >>
424 allows you to "wrap" another action, just as it would have been called by
425 dispatching from a URL, while the analogous
426 L<< go|/"$c->go( $action [, \@captures, \@arguments ] )" >> allows you to
427 transfer control to another action as if it had been reached directly from a URL.
428
429 =cut
430
431 sub visit { my $c = shift; $c->dispatcher->visit( $c, @_ ) }
432
433 =head2 $c->go( $action [, \@captures, \@arguments ] )
434
435 =head2 $c->go( $class, $method, [, \@captures, \@arguments ] )
436
437 The relationship between C<go> and
438 L<< visit|/"$c->visit( $action [, \@captures, \@arguments ] )" >> is the same as
439 the relationship between
440 L<< forward|/"$c->forward( $class, $method, [, \@arguments ] )" >> and
441 L<< detach|/"$c->detach( $action [, \@arguments ] )" >>. Like C<< $c->visit >>,
442 C<< $c->go >> will perform a full dispatch on the specified action or method,
443 with localized C<< $c->action >> and C<< $c->namespace >>. Like C<detach>,
444 C<go> escapes the processing of the current request chain on completion, and
445 does not return to its caller.
446
447 @arguments are arguments to the final destination of $action. @captures are
448 arguments to the intermediate steps, if any, on the way to the final sub of
449 $action.
450
451 =cut
452
453 sub go { my $c = shift; $c->dispatcher->go( $c, @_ ) }
454
455 =head2 $c->response
456
457 =head2 $c->res
458
459 Returns the current L<Catalyst::Response> object, see there for details.
460
461 =head2 $c->stash
462
463 Returns a hashref to the stash, which may be used to store data and pass
464 it between components during a request. You can also set hash keys by
465 passing arguments. The stash is automatically sent to the view. The
466 stash is cleared at the end of a request; it cannot be used for
467 persistent storage (for this you must use a session; see
468 L<Catalyst::Plugin::Session> for a complete system integrated with
469 Catalyst).
470
471     $c->stash->{foo} = $bar;
472     $c->stash( { moose => 'majestic', qux => 0 } );
473     $c->stash( bar => 1, gorch => 2 ); # equivalent to passing a hashref
474
475     # stash is automatically passed to the view for use in a template
476     $c->forward( 'MyApp::View::TT' );
477
478 =cut
479
480 around stash => sub {
481     my $orig = shift;
482     my $c = shift;
483     my $stash = $orig->($c);
484     if (@_) {
485         my $new_stash = @_ > 1 ? {@_} : $_[0];
486         croak('stash takes a hash or hashref') unless ref $new_stash;
487         foreach my $key ( keys %$new_stash ) {
488           $stash->{$key} = $new_stash->{$key};
489         }
490     }
491
492     return $stash;
493 };
494
495
496 =head2 $c->error
497
498 =head2 $c->error($error, ...)
499
500 =head2 $c->error($arrayref)
501
502 Returns an arrayref containing error messages.  If Catalyst encounters an
503 error while processing a request, it stores the error in $c->error.  This
504 method should only be used to store fatal error messages.
505
506     my @error = @{ $c->error };
507
508 Add a new error.
509
510     $c->error('Something bad happened');
511
512 =cut
513
514 sub error {
515     my $c = shift;
516     if ( $_[0] ) {
517         my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
518         croak @$error unless ref $c;
519         push @{ $c->{error} }, @$error;
520     }
521     elsif ( defined $_[0] ) { $c->{error} = undef }
522     return $c->{error} || [];
523 }
524
525
526 =head2 $c->state
527
528 Contains the return value of the last executed action.
529 Note that << $c->state >> operates in a scalar context which means that all
530 values it returns are scalar.
531
532 =head2 $c->clear_errors
533
534 Clear errors.  You probably don't want to clear the errors unless you are
535 implementing a custom error screen.
536
537 This is equivalent to running
538
539     $c->error(0);
540
541 =cut
542
543 sub clear_errors {
544     my $c = shift;
545     $c->error(0);
546 }
547
548 =head2 COMPONENT ACCESSORS
549
550 =head2 $c->controller($name)
551
552 Gets a L<Catalyst::Controller> instance by name.
553
554     $c->controller('Foo')->do_stuff;
555
556 If the name is omitted, will return the controller for the dispatched
557 action.
558
559 If you want to search for controllers, pass in a regexp as the argument.
560
561     # find all controllers that start with Foo
562     my @foo_controllers = $c->controller(qr{^Foo});
563
564
565 =cut
566
567 sub controller { shift->_lookup_mvc('controller', @_) }
568
569 =head2 $c->model($name)
570
571 Gets a L<Catalyst::Model> instance by name.
572
573     $c->model('Foo')->do_stuff;
574
575 Any extra arguments are directly passed to ACCEPT_CONTEXT.
576
577 If the name is omitted, it will look for
578  - a model object in $c->stash->{current_model_instance}, then
579  - a model name in $c->stash->{current_model}, then
580  - a config setting 'default_model', or
581  - check if there is only one model, and return it if that's the case.
582
583 If you want to search for models, pass in a regexp as the argument.
584
585     # find all models that start with Foo
586     my @foo_models = $c->model(qr{^Foo});
587
588 =cut
589
590 sub model { shift->_lookup_mvc('model', @_) }
591
592 =head2 $c->view($name)
593
594 Gets a L<Catalyst::View> instance by name.
595
596     $c->view('Foo')->do_stuff;
597
598 Any extra arguments are directly passed to ACCEPT_CONTEXT.
599
600 If the name is omitted, it will look for
601  - a view object in $c->stash->{current_view_instance}, then
602  - a view name in $c->stash->{current_view}, then
603  - a config setting 'default_view', or
604  - check if there is only one view, and return it if that's the case.
605
606 If you want to search for views, pass in a regexp as the argument.
607
608     # find all views that start with Foo
609     my @foo_views = $c->view(qr{^Foo});
610
611 =cut
612
613 sub view { shift->_lookup_mvc('view', @_) }
614
615 sub _lookup_mvc {
616     my ( $c, $type, $name, @args ) = @_;
617
618     if (ref $c && !$name && $type ne 'controller') {
619         my $current_instance = $c->stash->{"current_${type}_instance"};
620         return $current_instance
621             if $current_instance;
622
623         $name = $c->stash->{"current_${type}"};
624     }
625
626     $name ||= Catalyst::Utils::class2classshortsuffix($c->action->class);
627
628     return $c->container->get_component_from_sub_container($type, $name, $c, @args);
629 }
630
631 =head2 $c->controllers
632
633 Returns the available names which can be passed to $c->controller
634
635 =cut
636
637 sub controllers {
638     my ( $c ) = @_;
639     return $c->container->get_sub_container('controller')->get_service_list;
640 }
641
642 =head2 $c->models
643
644 Returns the available names which can be passed to $c->model
645
646 =cut
647
648 sub models {
649     my ( $c ) = @_;
650     return $c->container->get_sub_container('model')->get_service_list;
651 }
652
653
654 =head2 $c->views
655
656 Returns the available names which can be passed to $c->view
657
658 =cut
659
660 sub views {
661     my ( $c ) = @_;
662     return $c->container->get_sub_container('view')->get_service_list;
663 }
664
665 =head2 $c->comp($name)
666
667 =head2 $c->component($name)
668
669 Gets a component object by name. This method is not recommended,
670 unless you want to get a specific component by full
671 class. C<< $c->controller >>, C<< $c->model >>, and C<< $c->view >>
672 should be used instead.
673
674 If C<$name> is a regexp, a list of components matched against the full
675 component name will be returned.
676
677 =cut
678
679 sub component {
680     my ( $c, $component, @args ) = @_;
681
682     unless ($component) {
683         $c->log->warn('Calling $c->component with no args is deprecated and ');
684         $c->log->warn('will be removed in a future release.');
685         $c->log->warn('Use $c->component_list instead.');
686         return $c->component_list;
687     }
688
689     my @result = $c->container->find_component( $component, $c, @args );
690
691     # list context for regexp searches
692     return @result if ref $component;
693
694     # only one component (if it's found) for string searches
695     return shift @result if @result;
696
697     if (ref $c eq $component) {
698         $c->log->warn('You are calling $c->comp("MyApp"). This behaviour is');
699         $c->log->warn('deprecated, and will be removed in a future release.');
700         return $c;
701     }
702
703     $c->log->warn("Looking for '$component', but nothing was found.");
704
705     # I would expect to return an empty list here, but that breaks back-compat
706     $c->log->warn('Component not found, returning the list of existing');
707     $c->log->warn('components. This behavior is deprecated and will be');
708     $c->log->warn('removed in a future release. Use $c->component_list');
709     $c->log->warn('instead.');
710
711     return $c->component_list;
712 }
713
714 =head2 $c->component_list
715
716 Returns the sorted list of the component names of the application.
717
718 =cut
719
720 sub component_list { sort keys %{ shift->components } }
721
722 =head2 CLASS DATA AND HELPER CLASSES
723
724 =head2 $c->config
725
726 Returns or takes a hashref containing the application's configuration.
727
728     __PACKAGE__->config( { db => 'dsn:SQLite:foo.db' } );
729
730 You can also use a C<YAML>, C<XML> or L<Config::General> config file
731 like C<myapp.conf> in your applications home directory. See
732 L<Catalyst::Plugin::ConfigLoader>.
733
734 =head3 Cascading configuration
735
736 The config method is present on all Catalyst components, and configuration
737 will be merged when an application is started. Configuration loaded with
738 L<Catalyst::Plugin::ConfigLoader> takes precedence over other configuration,
739 followed by configuration in your top level C<MyApp> class. These two
740 configurations are merged, and then configuration data whose hash key matches a
741 component name is merged with configuration for that component.
742
743 The configuration for a component is then passed to the C<new> method when a
744 component is constructed.
745
746 For example:
747
748     MyApp->config({ 'Model::Foo' => { bar => 'baz', overrides => 'me' } });
749     MyApp::Model::Foo->config({ quux => 'frob', overrides => 'this' });
750
751 will mean that C<MyApp::Model::Foo> receives the following data when
752 constructed:
753
754     MyApp::Model::Foo->new({
755         bar => 'baz',
756         quux => 'frob',
757         overrides => 'me',
758     });
759
760 It's common practice to use a Moose attribute
761 on the receiving component to access the config value.
762
763     package MyApp::Model::Foo;
764
765     use Moose;
766
767     # this attr will receive 'baz' at construction time
768     has 'bar' => (
769         is  => 'rw',
770         isa => 'Str',
771     );
772
773 You can then get the value 'baz' by calling $c->model('Foo')->bar
774 (or $self->bar inside code in the model).
775
776 B<NOTE:> you MUST NOT call C<< $self->config >> or C<< __PACKAGE__->config >>
777 as a way of reading config within your code, as this B<will not> give you the
778 correctly merged config back. You B<MUST> take the config values supplied to
779 the constructor and use those instead.
780
781 =cut
782
783 around config => sub {
784     my $orig = shift;
785     my $c = shift;
786
787     croak('Setting config after setup has been run is not allowed.')
788         if ( @_ and $c->setup_finished );
789
790     $c->$orig(@_);
791 };
792
793 =head2 $c->log
794
795 Returns the logging object instance. Unless it is already set, Catalyst
796 sets this up with a L<Catalyst::Log> object. To use your own log class,
797 set the logger with the C<< __PACKAGE__->log >> method prior to calling
798 C<< __PACKAGE__->setup >>.
799
800  __PACKAGE__->log( MyLogger->new );
801  __PACKAGE__->setup;
802
803 And later:
804
805     $c->log->info( 'Now logging with my own logger!' );
806
807 Your log class should implement the methods described in
808 L<Catalyst::Log>.
809
810
811 =head2 $c->debug
812
813 Returns 1 if debug mode is enabled, 0 otherwise.
814
815 You can enable debug mode in several ways:
816
817 =over
818
819 =item By calling myapp_server.pl with the -d flag
820
821 =item With the environment variables MYAPP_DEBUG, or CATALYST_DEBUG
822
823 =item The -Debug option in your MyApp.pm
824
825 =item By declaring C<sub debug { 1 }> in your MyApp.pm.
826
827 =back
828
829 The first three also set the log level to 'debug'.
830
831 Calling C<< $c->debug(1) >> has no effect.
832
833 =cut
834
835 sub debug { 0 }
836
837 =head2 $c->dispatcher
838
839 Returns the dispatcher instance. See L<Catalyst::Dispatcher>.
840
841 =head2 $c->engine
842
843 Returns the engine instance. See L<Catalyst::Engine>.
844
845
846 =head2 UTILITY METHODS
847
848 =head2 $c->path_to(@path)
849
850 Merges C<@path> with C<< $c->config->{home} >> and returns a
851 L<Path::Class::Dir> object. Note you can usually use this object as
852 a filename, but sometimes you will have to explicitly stringify it
853 yourself by calling the C<< ->stringify >> method.
854
855 For example:
856
857     $c->path_to( 'db', 'sqlite.db' );
858
859 =cut
860
861 sub path_to {
862     my ( $c, @path ) = @_;
863     my $path = Path::Class::Dir->new( $c->config->{home}, @path );
864     if ( -d $path ) { return $path }
865     else { return Path::Class::File->new( $c->config->{home}, @path ) }
866 }
867
868 =head2 $c->plugin( $name, $class, @args )
869
870 Helper method for plugins. It creates a class data accessor/mutator and
871 loads and instantiates the given class.
872
873     MyApp->plugin( 'prototype', 'HTML::Prototype' );
874
875     $c->prototype->define_javascript_functions;
876
877 B<Note:> This method of adding plugins is deprecated. The ability
878 to add plugins like this B<will be removed> in a Catalyst 5.81.
879 Please do not use this functionality in new code.
880
881 =cut
882
883 sub plugin {
884     my ( $class, $name, $plugin, @args ) = @_;
885
886     # See block comment in t/aggregate/unit_core_plugin.t
887     $class->log->warn(qq/Adding plugin using the ->plugin method is deprecated, and will be removed in Catalyst 5.81/);
888
889     $class->_register_plugin( $plugin, 1 );
890
891     eval { $plugin->import };
892     $class->mk_classdata($name);
893     my $obj;
894     eval { $obj = $plugin->new(@args) };
895
896     if ($@) {
897         Catalyst::Exception->throw( message =>
898               qq/Couldn't instantiate instant plugin "$plugin", "$@"/ );
899     }
900
901     $class->$name($obj);
902     $class->log->debug(qq/Initialized instant plugin "$plugin" as "$name"/)
903       if $class->debug;
904 }
905
906 =head2 MyApp->setup
907
908 Initializes the dispatcher and engine, loads any plugins, and loads the
909 model, view, and controller components. You may also specify an array
910 of plugins to load here, if you choose to not load them in the C<use
911 Catalyst> line.
912
913     MyApp->setup;
914     MyApp->setup( qw/-Debug/ );
915
916 =cut
917
918 sub setup {
919     my ( $class, @arguments ) = @_;
920     croak('Running setup more than once')
921         if ( $class->setup_finished );
922
923     unless ( $class->isa('Catalyst') ) {
924
925         Catalyst::Exception->throw(
926             message => qq/'$class' does not inherit from Catalyst/ );
927     }
928
929     if ( $class->arguments ) {
930         @arguments = ( @arguments, @{ $class->arguments } );
931     }
932
933     # Process options
934     my $flags = {};
935
936     foreach (@arguments) {
937
938         if (/^-Debug$/) {
939             $flags->{log} =
940               ( $flags->{log} ) ? 'debug,' . $flags->{log} : 'debug';
941         }
942         elsif (/^-(\w+)=?(.*)$/) {
943             $flags->{ lc $1 } = $2;
944         }
945         else {
946             push @{ $flags->{plugins} }, $_;
947         }
948     }
949
950     $class->setup_config();
951     $class->setup_home( delete $flags->{home} );
952
953     $class->setup_log( delete $flags->{log} );
954     $class->setup_plugins( delete $flags->{plugins} );
955     $class->setup_dispatcher( delete $flags->{dispatcher} );
956     $class->setup_engine( delete $flags->{engine} );
957     $class->setup_stats( delete $flags->{stats} );
958
959     for my $flag ( sort keys %{$flags} ) {
960
961         if ( my $code = $class->can( 'setup_' . $flag ) ) {
962             &$code( $class, delete $flags->{$flag} );
963         }
964         else {
965             $class->log->warn(qq/Unknown flag "$flag"/);
966         }
967     }
968
969     eval { require Catalyst::Devel; };
970     if( !$@ && $ENV{CATALYST_SCRIPT_GEN} && ( $ENV{CATALYST_SCRIPT_GEN} < $Catalyst::Devel::CATALYST_SCRIPT_GEN ) ) {
971         $class->log->warn(<<"EOF");
972 You are running an old script!
973
974   Please update by running (this will overwrite existing files):
975     catalyst.pl -force -scripts $class
976
977   or (this will not overwrite existing files):
978     catalyst.pl -scripts $class
979
980 EOF
981     }
982
983     if ( $class->debug ) {
984         my @plugins = map { "$_  " . ( $_->VERSION || '' ) } $class->registered_plugins;
985
986         if (@plugins) {
987             my $column_width = Catalyst::Utils::term_width() - 6;
988             my $t = Text::SimpleTable->new($column_width);
989             $t->row($_) for @plugins;
990             $class->log->debug( "Loaded plugins:\n" . $t->draw . "\n" );
991         }
992
993         my $dispatcher = $class->dispatcher;
994         my $engine     = $class->engine;
995         my $home       = $class->config->{home};
996
997         $class->log->debug(sprintf(q/Loaded dispatcher "%s"/, blessed($dispatcher)));
998         $class->log->debug(sprintf(q/Loaded engine "%s"/, blessed($engine)));
999
1000         $home
1001           ? ( -d $home )
1002           ? $class->log->debug(qq/Found home "$home"/)
1003           : $class->log->debug(qq/Home "$home" doesn't exist/)
1004           : $class->log->debug(q/Couldn't find home/);
1005     }
1006
1007     # Call plugins setup, this is stupid and evil.
1008     # Also screws C3 badly on 5.10, hack to avoid.
1009     {
1010         no warnings qw/redefine/;
1011         local *setup = sub { };
1012         $class->setup unless $Catalyst::__AM_RESTARTING;
1013     }
1014
1015     $class->setup_components;
1016
1017     if (
1018         $class->debug and
1019         my @comps_names_types = $class->container->get_components_names_types
1020     ) {
1021         my $column_width = Catalyst::Utils::term_width() - 8 - 9;
1022         my $t = Text::SimpleTable->new( [ $column_width, 'Class' ], [ 8, 'Type' ] );
1023         $t->row( @$_ ) for @comps_names_types;
1024
1025         $class->log->debug( "Loaded components:\n" . $t->draw . "\n" );
1026     }
1027
1028     $class->setup_actions;
1029
1030     if ( $class->debug ) {
1031         my $name = $class->config->{name} || 'Application';
1032         $class->log->info("$name powered by Catalyst $Catalyst::VERSION");
1033     }
1034
1035     # Make sure that the application class becomes immutable at this point,
1036     B::Hooks::EndOfScope::on_scope_end {
1037         return if $@;
1038         my $meta = Class::MOP::get_metaclass_by_name($class);
1039         if (
1040             $meta->is_immutable
1041             && ! { $meta->immutable_options }->{replace_constructor}
1042             && (
1043                    $class->isa('Class::Accessor::Fast')
1044                 || $class->isa('Class::Accessor')
1045             )
1046         ) {
1047             warn "You made your application class ($class) immutable, "
1048                 . "but did not inline the\nconstructor. "
1049                 . "This will break catalyst, as your app \@ISA "
1050                 . "Class::Accessor(::Fast)?\nPlease pass "
1051                 . "(replace_constructor => 1)\nwhen making your class immutable.\n";
1052         }
1053         $meta->make_immutable(
1054             replace_constructor => 1,
1055         ) unless $meta->is_immutable;
1056     };
1057
1058     if ($class->config->{case_sensitive}) {
1059         $class->log->warn($class . "->config->{case_sensitive} is set.");
1060         $class->log->warn("This setting is deprecated and planned to be removed in Catalyst 5.81.");
1061     }
1062
1063     $class->setup_finalize;
1064     # Should be the last thing we do so that user things hooking
1065     # setup_finalize can log..
1066     $class->log->_flush() if $class->log->can('_flush');
1067     return 1; # Explicit return true as people have __PACKAGE__->setup as the last thing in their class. HATE.
1068 }
1069
1070 =head2 $app->setup_finalize
1071
1072 A hook to attach modifiers to. This method does not do anything except set the
1073 C<setup_finished> accessor.
1074
1075 Applying method modifiers to the C<setup> method doesn't work, because of quirky things done for plugin setup.
1076
1077 Example:
1078
1079     after setup_finalize => sub {
1080         my $app = shift;
1081
1082         ## do stuff here..
1083     };
1084
1085 =cut
1086
1087 sub setup_finalize {
1088     my ($class) = @_;
1089     $class->setup_finished(1);
1090 }
1091
1092 =head2 $c->uri_for( $path?, @args?, \%query_values? )
1093
1094 =head2 $c->uri_for( $action, \@captures?, @args?, \%query_values? )
1095
1096 Constructs an absolute L<URI> object based on the application root, the
1097 provided path, and the additional arguments and query parameters provided.
1098 When used as a string, provides a textual URI.  If you need more flexibility
1099 than this (i.e. the option to provide relative URIs etc.) see
1100 L<Catalyst::Plugin::SmartURI>.
1101
1102 If no arguments are provided, the URI for the current action is returned.
1103 To return the current action and also provide @args, use
1104 C<< $c->uri_for( $c->action, @args ) >>.
1105
1106 If the first argument is a string, it is taken as a public URI path relative
1107 to C<< $c->namespace >> (if it doesn't begin with a forward slash) or
1108 relative to the application root (if it does). It is then merged with
1109 C<< $c->request->base >>; any C<@args> are appended as additional path
1110 components; and any C<%query_values> are appended as C<?foo=bar> parameters.
1111
1112 If the first argument is a L<Catalyst::Action> it represents an action which
1113 will have its path resolved using C<< $c->dispatcher->uri_for_action >>. The
1114 optional C<\@captures> argument (an arrayref) allows passing the captured
1115 variables that are needed to fill in the paths of Chained and Regex actions;
1116 once the path is resolved, C<uri_for> continues as though a path was
1117 provided, appending any arguments or parameters and creating an absolute
1118 URI.
1119
1120 The captures for the current request can be found in
1121 C<< $c->request->captures >>, and actions can be resolved using
1122 C<< Catalyst::Controller->action_for($name) >>. If you have a private action
1123 path, use C<< $c->uri_for_action >> instead.
1124
1125   # Equivalent to $c->req->uri
1126   $c->uri_for($c->action, $c->req->captures,
1127       @{ $c->req->args }, $c->req->params);
1128
1129   # For the Foo action in the Bar controller
1130   $c->uri_for($c->controller('Bar')->action_for('Foo'));
1131
1132   # Path to a static resource
1133   $c->uri_for('/static/images/logo.png');
1134
1135 =cut
1136
1137 sub uri_for {
1138     my ( $c, $path, @args ) = @_;
1139
1140     if (blessed($path) && $path->isa('Catalyst::Controller')) {
1141         $path = $path->path_prefix;
1142         $path =~ s{/+\z}{};
1143         $path .= '/';
1144     }
1145
1146     undef($path) if (defined $path && $path eq '');
1147
1148     my $params =
1149       ( scalar @args && ref $args[$#args] eq 'HASH' ? pop @args : {} );
1150
1151     carp "uri_for called with undef argument" if grep { ! defined $_ } @args;
1152     foreach my $arg (@args) {
1153         utf8::encode($arg) if utf8::is_utf8($arg);
1154         $arg =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
1155     }
1156
1157     if ( blessed($path) ) { # action object
1158         s|/|%2F|g for @args;
1159         my $captures = [ map { s|/|%2F|g; $_; }
1160                         ( scalar @args && ref $args[0] eq 'ARRAY'
1161                          ? @{ shift(@args) }
1162                          : ()) ];
1163
1164         foreach my $capture (@$captures) {
1165             utf8::encode($capture) if utf8::is_utf8($capture);
1166             $capture =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
1167         }
1168
1169         my $action = $path;
1170         $path = $c->dispatcher->uri_for_action($action, $captures);
1171         if (not defined $path) {
1172             $c->log->debug(qq/Can't find uri_for action '$action' @$captures/)
1173                 if $c->debug;
1174             return undef;
1175         }
1176         $path = '/' if $path eq '';
1177     }
1178
1179     unshift(@args, $path);
1180
1181     unless (defined $path && $path =~ s!^/!!) { # in-place strip
1182         my $namespace = $c->namespace;
1183         if (defined $path) { # cheesy hack to handle path '../foo'
1184            $namespace =~ s{(?:^|/)[^/]+$}{} while $args[0] =~ s{^\.\./}{};
1185         }
1186         unshift(@args, $namespace || '');
1187     }
1188
1189     # join args with '/', or a blank string
1190     my $args = join('/', grep { defined($_) } @args);
1191     $args =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE
1192     $args =~ s!^/+!!;
1193     my $base = $c->req->base;
1194     my $class = ref($base);
1195     $base =~ s{(?<!/)$}{/};
1196
1197     my $query = '';
1198
1199     if (my @keys = keys %$params) {
1200       # somewhat lifted from URI::_query's query_form
1201       $query = '?'.join('&', map {
1202           my $val = $params->{$_};
1203           s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/go;
1204           s/ /+/g;
1205           my $key = $_;
1206           $val = '' unless defined $val;
1207           (map {
1208               my $param = "$_";
1209               utf8::encode( $param ) if utf8::is_utf8($param);
1210               # using the URI::Escape pattern here so utf8 chars survive
1211               $param =~ s/([^A-Za-z0-9\-_.!~*'() ])/$URI::Escape::escapes{$1}/go;
1212               $param =~ s/ /+/g;
1213               "${key}=$param"; } ( ref $val eq 'ARRAY' ? @$val : $val ));
1214       } @keys);
1215     }
1216
1217     my $res = bless(\"${base}${args}${query}", $class);
1218     $res;
1219 }
1220
1221 =head2 $c->uri_for_action( $path, \@captures?, @args?, \%query_values? )
1222
1223 =head2 $c->uri_for_action( $action, \@captures?, @args?, \%query_values? )
1224
1225 =over
1226
1227 =item $path
1228
1229 A private path to the Catalyst action you want to create a URI for.
1230
1231 This is a shortcut for calling C<< $c->dispatcher->get_action_by_path($path)
1232 >> and passing the resulting C<$action> and the remaining arguments to C<<
1233 $c->uri_for >>.
1234
1235 You can also pass in a Catalyst::Action object, in which case it is passed to
1236 C<< $c->uri_for >>.
1237
1238 Note that although the path looks like a URI that dispatches to the wanted action, it is not a URI, but an internal path to that action.
1239
1240 For example, if the action looks like:
1241
1242  package MyApp::Controller::Users;
1243
1244  sub lst : Path('the-list') {}
1245
1246 You can use:
1247
1248  $c->uri_for_action('/users/lst')
1249
1250 and it will create the URI /users/the-list.
1251
1252 =back
1253
1254 =cut
1255
1256 sub uri_for_action {
1257     my ( $c, $path, @args ) = @_;
1258     my $action = blessed($path)
1259       ? $path
1260       : $c->dispatcher->get_action_by_path($path);
1261     unless (defined $action) {
1262       croak "Can't find action for path '$path'";
1263     }
1264     return $c->uri_for( $action, @args );
1265 }
1266
1267 =head2 $c->welcome_message
1268
1269 Returns the Catalyst welcome HTML page.
1270
1271 =cut
1272
1273 sub welcome_message {
1274     my $c      = shift;
1275     my $name   = $c->config->{name};
1276     my $logo   = $c->uri_for('/static/images/catalyst_logo.png');
1277     my $prefix = Catalyst::Utils::appprefix( ref $c );
1278     $c->response->content_type('text/html; charset=utf-8');
1279     return <<"EOF";
1280 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1281     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1282 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
1283     <head>
1284     <meta http-equiv="Content-Language" content="en" />
1285     <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1286         <title>$name on Catalyst $VERSION</title>
1287         <style type="text/css">
1288             body {
1289                 color: #000;
1290                 background-color: #eee;
1291             }
1292             div#content {
1293                 width: 640px;
1294                 margin-left: auto;
1295                 margin-right: auto;
1296                 margin-top: 10px;
1297                 margin-bottom: 10px;
1298                 text-align: left;
1299                 background-color: #ccc;
1300                 border: 1px solid #aaa;
1301             }
1302             p, h1, h2 {
1303                 margin-left: 20px;
1304                 margin-right: 20px;
1305                 font-family: verdana, tahoma, sans-serif;
1306             }
1307             a {
1308                 font-family: verdana, tahoma, sans-serif;
1309             }
1310             :link, :visited {
1311                     text-decoration: none;
1312                     color: #b00;
1313                     border-bottom: 1px dotted #bbb;
1314             }
1315             :link:hover, :visited:hover {
1316                     color: #555;
1317             }
1318             div#topbar {
1319                 margin: 0px;
1320             }
1321             pre {
1322                 margin: 10px;
1323                 padding: 8px;
1324             }
1325             div#answers {
1326                 padding: 8px;
1327                 margin: 10px;
1328                 background-color: #fff;
1329                 border: 1px solid #aaa;
1330             }
1331             h1 {
1332                 font-size: 0.9em;
1333                 font-weight: normal;
1334                 text-align: center;
1335             }
1336             h2 {
1337                 font-size: 1.0em;
1338             }
1339             p {
1340                 font-size: 0.9em;
1341             }
1342             p img {
1343                 float: right;
1344                 margin-left: 10px;
1345             }
1346             span#appname {
1347                 font-weight: bold;
1348                 font-size: 1.6em;
1349             }
1350         </style>
1351     </head>
1352     <body>
1353         <div id="content">
1354             <div id="topbar">
1355                 <h1><span id="appname">$name</span> on <a href="http://catalyst.perl.org">Catalyst</a>
1356                     $VERSION</h1>
1357              </div>
1358              <div id="answers">
1359                  <p>
1360                  <img src="$logo" alt="Catalyst Logo" />
1361                  </p>
1362                  <p>Welcome to the  world of Catalyst.
1363                     This <a href="http://en.wikipedia.org/wiki/MVC">MVC</a>
1364                     framework will make web development something you had
1365                     never expected it to be: Fun, rewarding, and quick.</p>
1366                  <h2>What to do now?</h2>
1367                  <p>That really depends  on what <b>you</b> want to do.
1368                     We do, however, provide you with a few starting points.</p>
1369                  <p>If you want to jump right into web development with Catalyst
1370                     you might want to start with a tutorial.</p>
1371 <pre>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Tutorial.pod">Catalyst::Manual::Tutorial</a></code>
1372 </pre>
1373 <p>Afterwards you can go on to check out a more complete look at our features.</p>
1374 <pre>
1375 <code>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Intro.pod">Catalyst::Manual::Intro</a>
1376 <!-- Something else should go here, but the Catalyst::Manual link seems unhelpful -->
1377 </code></pre>
1378                  <h2>What to do next?</h2>
1379                  <p>Next it's time to write an actual application. Use the
1380                     helper scripts to generate <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AController%3A%3A&amp;mode=all">controllers</a>,
1381                     <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AModel%3A%3A&amp;mode=all">models</a>, and
1382                     <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AView%3A%3A&amp;mode=all">views</a>;
1383                     they can save you a lot of work.</p>
1384                     <pre><code>script/${prefix}_create.pl --help</code></pre>
1385                     <p>Also, be sure to check out the vast and growing
1386                     collection of <a href="http://search.cpan.org/search?query=Catalyst">plugins for Catalyst on CPAN</a>;
1387                     you are likely to find what you need there.
1388                     </p>
1389
1390                  <h2>Need help?</h2>
1391                  <p>Catalyst has a very active community. Here are the main places to
1392                     get in touch with us.</p>
1393                  <ul>
1394                      <li>
1395                          <a href="http://dev.catalyst.perl.org">Wiki</a>
1396                      </li>
1397                      <li>
1398                          <a href="http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst">Mailing-List</a>
1399                      </li>
1400                      <li>
1401                          <a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
1402                      </li>
1403                  </ul>
1404                  <h2>In conclusion</h2>
1405                  <p>The Catalyst team hopes you will enjoy using Catalyst as much
1406                     as we enjoyed making it. Please contact us if you have ideas
1407                     for improvement or other feedback.</p>
1408              </div>
1409          </div>
1410     </body>
1411 </html>
1412 EOF
1413 }
1414
1415 =head1 INTERNAL METHODS
1416
1417 These methods are not meant to be used by end users.
1418
1419 =head2 $c->components
1420
1421 Returns a hash of components.
1422
1423 =cut
1424
1425 sub components {
1426     my ( $class, $comps ) = @_;
1427
1428     # people create components calling this sub directly, before setup
1429     $class->setup_config unless $class->container;
1430
1431     my $container = $class->container;
1432
1433     if ( $comps ) {
1434         $container->add_component( $_ ) for keys %$comps;
1435     }
1436
1437     return $container->get_all_components();
1438 }
1439
1440 =head2 $c->context_class
1441
1442 Returns or sets the context class.
1443
1444 =head2 $c->counter
1445
1446 Returns a hashref containing coderefs and execution counts (needed for
1447 deep recursion detection).
1448
1449 =head2 $c->depth
1450
1451 Returns the number of actions on the current internal execution stack.
1452
1453 =head2 $c->dispatch
1454
1455 Dispatches a request to actions.
1456
1457 =cut
1458
1459 sub dispatch { my $c = shift; $c->dispatcher->dispatch( $c, @_ ) }
1460
1461 =head2 $c->dispatcher_class
1462
1463 Returns or sets the dispatcher class.
1464
1465 =head2 $c->dump_these
1466
1467 Returns a list of 2-element array references (name, structure) pairs
1468 that will be dumped on the error page in debug mode.
1469
1470 =cut
1471
1472 sub dump_these {
1473     my $c = shift;
1474     [ Request => $c->req ],
1475     [ Response => $c->res ],
1476     [ Stash => $c->stash ],
1477     [ Config => $c->config ];
1478 }
1479
1480 =head2 $c->engine_class
1481
1482 Returns or sets the engine class.
1483
1484 =head2 $c->execute( $class, $coderef )
1485
1486 Execute a coderef in given class and catch exceptions. Errors are available
1487 via $c->error.
1488
1489 =cut
1490
1491 sub execute {
1492     my ( $c, $class, $code ) = @_;
1493     $class = $c->component($class) || $class;
1494     $c->state(0);
1495
1496     if ( $c->depth >= $RECURSION ) {
1497         my $action = $code->reverse();
1498         $action = "/$action" unless $action =~ /->/;
1499         my $error = qq/Deep recursion detected calling "${action}"/;
1500         $c->log->error($error);
1501         $c->error($error);
1502         $c->state(0);
1503         return $c->state;
1504     }
1505
1506     my $stats_info = $c->_stats_start_execute( $code ) if $c->use_stats;
1507
1508     push( @{ $c->stack }, $code );
1509
1510     no warnings 'recursion';
1511     # N.B. This used to be combined, but I have seen $c get clobbered if so, and
1512     #      I have no idea how, ergo $ret (which appears to fix the issue)
1513     eval { my $ret = $code->execute( $class, $c, @{ $c->req->args } ) || 0; $c->state( $ret ) };
1514
1515     $c->_stats_finish_execute( $stats_info ) if $c->use_stats and $stats_info;
1516
1517     my $last = pop( @{ $c->stack } );
1518
1519     if ( my $error = $@ ) {
1520         if ( blessed($error) and $error->isa('Catalyst::Exception::Detach') ) {
1521             $error->rethrow if $c->depth > 1;
1522         }
1523         elsif ( blessed($error) and $error->isa('Catalyst::Exception::Go') ) {
1524             $error->rethrow if $c->depth > 0;
1525         }
1526         else {
1527             unless ( ref $error ) {
1528                 no warnings 'uninitialized';
1529                 chomp $error;
1530                 my $class = $last->class;
1531                 my $name  = $last->name;
1532                 $error = qq/Caught exception in $class->$name "$error"/;
1533             }
1534             $c->error($error);
1535         }
1536         $c->state(0);
1537     }
1538     return $c->state;
1539 }
1540
1541 sub _stats_start_execute {
1542     my ( $c, $code ) = @_;
1543     my $appclass = ref($c) || $c;
1544     return if ( ( $code->name =~ /^_.*/ )
1545         && ( !$appclass->config->{show_internal_actions} ) );
1546
1547     my $action_name = $code->reverse();
1548     $c->counter->{$action_name}++;
1549
1550     my $action = $action_name;
1551     $action = "/$action" unless $action =~ /->/;
1552
1553     # determine if the call was the result of a forward
1554     # this is done by walking up the call stack and looking for a calling
1555     # sub of Catalyst::forward before the eval
1556     my $callsub = q{};
1557     for my $index ( 2 .. 11 ) {
1558         last
1559         if ( ( caller($index) )[0] eq 'Catalyst'
1560             && ( caller($index) )[3] eq '(eval)' );
1561
1562         if ( ( caller($index) )[3] =~ /forward$/ ) {
1563             $callsub = ( caller($index) )[3];
1564             $action  = "-> $action";
1565             last;
1566         }
1567     }
1568
1569     my $uid = $action_name . $c->counter->{$action_name};
1570
1571     # is this a root-level call or a forwarded call?
1572     if ( $callsub =~ /forward$/ ) {
1573         my $parent = $c->stack->[-1];
1574
1575         # forward, locate the caller
1576         if ( defined $parent && exists $c->counter->{"$parent"} ) {
1577             $c->stats->profile(
1578                 begin  => $action,
1579                 parent => "$parent" . $c->counter->{"$parent"},
1580                 uid    => $uid,
1581             );
1582         }
1583         else {
1584
1585             # forward with no caller may come from a plugin
1586             $c->stats->profile(
1587                 begin => $action,
1588                 uid   => $uid,
1589             );
1590         }
1591     }
1592     else {
1593
1594         # root-level call
1595         $c->stats->profile(
1596             begin => $action,
1597             uid   => $uid,
1598         );
1599     }
1600     return $action;
1601
1602 }
1603
1604 sub _stats_finish_execute {
1605     my ( $c, $info ) = @_;
1606     $c->stats->profile( end => $info );
1607 }
1608
1609 =head2 $c->finalize
1610
1611 Finalizes the request.
1612
1613 =cut
1614
1615 sub finalize {
1616     my $c = shift;
1617
1618     for my $error ( @{ $c->error } ) {
1619         $c->log->error($error);
1620     }
1621
1622     # Allow engine to handle finalize flow (for POE)
1623     my $engine = $c->engine;
1624     if ( my $code = $engine->can('finalize') ) {
1625         $engine->$code($c);
1626     }
1627     else {
1628
1629         $c->finalize_uploads;
1630
1631         # Error
1632         if ( $#{ $c->error } >= 0 ) {
1633             $c->finalize_error;
1634         }
1635
1636         $c->finalize_headers;
1637
1638         # HEAD request
1639         if ( $c->request->method eq 'HEAD' ) {
1640             $c->response->body('');
1641         }
1642
1643         $c->finalize_body;
1644     }
1645
1646     $c->log_response;
1647
1648     if ($c->use_stats) {
1649         my $elapsed = sprintf '%f', $c->stats->elapsed;
1650         my $av = $elapsed == 0 ? '??' : sprintf '%.3f', 1 / $elapsed;
1651         $c->log->info(
1652             "Request took ${elapsed}s ($av/s)\n" . $c->stats->report . "\n" );
1653     }
1654
1655     return $c->response->status;
1656 }
1657
1658 =head2 $c->finalize_body
1659
1660 Finalizes body.
1661
1662 =cut
1663
1664 sub finalize_body { my $c = shift; $c->engine->finalize_body( $c, @_ ) }
1665
1666 =head2 $c->finalize_cookies
1667
1668 Finalizes cookies.
1669
1670 =cut
1671
1672 sub finalize_cookies { my $c = shift; $c->engine->finalize_cookies( $c, @_ ) }
1673
1674 =head2 $c->finalize_error
1675
1676 Finalizes error.
1677
1678 =cut
1679
1680 sub finalize_error { my $c = shift; $c->engine->finalize_error( $c, @_ ) }
1681
1682 =head2 $c->finalize_headers
1683
1684 Finalizes headers.
1685
1686 =cut
1687
1688 sub finalize_headers {
1689     my $c = shift;
1690
1691     my $response = $c->response; #accessor calls can add up?
1692
1693     # Check if we already finalized headers
1694     return if $response->finalized_headers;
1695
1696     # Handle redirects
1697     if ( my $location = $response->redirect ) {
1698         $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
1699         $response->header( Location => $location );
1700
1701         if ( !$response->has_body ) {
1702             # Add a default body if none is already present
1703             $response->body(
1704                 qq{<html><body><p>This item has moved <a href="$location">here</a>.</p></body></html>}
1705             );
1706         }
1707     }
1708
1709     # Content-Length
1710     if ( defined $response->body && length $response->body && !$response->content_length ) {
1711
1712         # get the length from a filehandle
1713         if ( blessed( $response->body ) && $response->body->can('read') || ref( $response->body ) eq 'GLOB' )
1714         {
1715             my $stat = stat $response->body;
1716             if ( $stat && $stat->size > 0 ) {
1717                 $response->content_length( $stat->size );
1718             }
1719             else {
1720                 $c->log->warn('Serving filehandle without a content-length');
1721             }
1722         }
1723         else {
1724             # everything should be bytes at this point, but just in case
1725             $response->content_length( length( $response->body ) );
1726         }
1727     }
1728
1729     # Errors
1730     if ( $response->status =~ /^(1\d\d|[23]04)$/ ) {
1731         $response->headers->remove_header("Content-Length");
1732         $response->body('');
1733     }
1734
1735     $c->finalize_cookies;
1736
1737     $c->engine->finalize_headers( $c, @_ );
1738
1739     # Done
1740     $response->finalized_headers(1);
1741 }
1742
1743 =head2 $c->finalize_output
1744
1745 An alias for finalize_body.
1746
1747 =head2 $c->finalize_read
1748
1749 Finalizes the input after reading is complete.
1750
1751 =cut
1752
1753 sub finalize_read { my $c = shift; $c->engine->finalize_read( $c, @_ ) }
1754
1755 =head2 $c->finalize_uploads
1756
1757 Finalizes uploads. Cleans up any temporary files.
1758
1759 =cut
1760
1761 sub finalize_uploads { my $c = shift; $c->engine->finalize_uploads( $c, @_ ) }
1762
1763 =head2 $c->get_action( $action, $namespace )
1764
1765 Gets an action in a given namespace.
1766
1767 =cut
1768
1769 sub get_action { my $c = shift; $c->dispatcher->get_action(@_) }
1770
1771 =head2 $c->get_actions( $action, $namespace )
1772
1773 Gets all actions of a given name in a namespace and all parent
1774 namespaces.
1775
1776 =cut
1777
1778 sub get_actions { my $c = shift; $c->dispatcher->get_actions( $c, @_ ) }
1779
1780 =head2 $app->handle_request( @arguments )
1781
1782 Called to handle each HTTP request.
1783
1784 =cut
1785
1786 sub handle_request {
1787     my ( $class, @arguments ) = @_;
1788
1789     # Always expect worst case!
1790     my $status = -1;
1791     eval {
1792         if ($class->debug) {
1793             my $secs = time - $START || 1;
1794             my $av = sprintf '%.3f', $COUNT / $secs;
1795             my $time = localtime time;
1796             $class->log->info("*** Request $COUNT ($av/s) [$$] [$time] ***");
1797         }
1798
1799         my $c = $class->prepare(@arguments);
1800         $c->dispatch;
1801         $status = $c->finalize;
1802     };
1803
1804     if ( my $error = $@ ) {
1805         chomp $error;
1806         $class->log->error(qq/Caught exception in engine "$error"/);
1807     }
1808
1809     $COUNT++;
1810
1811     if(my $coderef = $class->log->can('_flush')){
1812         $class->log->$coderef();
1813     }
1814     return $status;
1815 }
1816
1817 =head2 $c->prepare( @arguments )
1818
1819 Creates a Catalyst context from an engine-specific request (Apache, CGI,
1820 etc.).
1821
1822 =cut
1823
1824 sub prepare {
1825     my ( $class, @arguments ) = @_;
1826
1827     # XXX
1828     # After the app/ctxt split, this should become an attribute based on something passed
1829     # into the application.
1830     $class->context_class( ref $class || $class ) unless $class->context_class;
1831
1832     my $c = $class->context_class->new({});
1833
1834     # For on-demand data
1835     $c->request->_context($c);
1836     $c->response->_context($c);
1837
1838     #surely this is not the most efficient way to do things...
1839     $c->stats($class->stats_class->new)->enable($c->use_stats);
1840     if ( $c->debug || $c->config->{enable_catalyst_header} ) {
1841         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
1842     }
1843
1844     #XXX reuse coderef from can
1845     # Allow engine to direct the prepare flow (for POE)
1846     if ( $c->engine->can('prepare') ) {
1847         $c->engine->prepare( $c, @arguments );
1848     }
1849     else {
1850         $c->prepare_request(@arguments);
1851         $c->prepare_connection;
1852         $c->prepare_query_parameters;
1853         $c->prepare_headers;
1854         $c->prepare_cookies;
1855         $c->prepare_path;
1856
1857         # Prepare the body for reading, either by prepare_body
1858         # or the user, if they are using $c->read
1859         $c->prepare_read;
1860
1861         # Parse the body unless the user wants it on-demand
1862         unless ( ref($c)->config->{parse_on_demand} ) {
1863             $c->prepare_body;
1864         }
1865     }
1866
1867     my $method  = $c->req->method  || '';
1868     my $path    = $c->req->path;
1869     $path       = '/' unless length $path;
1870     my $address = $c->req->address || '';
1871
1872     $c->log_request;
1873
1874     $c->prepare_action;
1875
1876     return $c;
1877 }
1878
1879 =head2 $c->prepare_action
1880
1881 Prepares action. See L<Catalyst::Dispatcher>.
1882
1883 =cut
1884
1885 sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
1886
1887 =head2 $c->prepare_body
1888
1889 Prepares message body.
1890
1891 =cut
1892
1893 sub prepare_body {
1894     my $c = shift;
1895
1896     return if $c->request->_has_body;
1897
1898     # Initialize on-demand data
1899     $c->engine->prepare_body( $c, @_ );
1900     $c->prepare_parameters;
1901     $c->prepare_uploads;
1902 }
1903
1904 =head2 $c->prepare_body_chunk( $chunk )
1905
1906 Prepares a chunk of data before sending it to L<HTTP::Body>.
1907
1908 See L<Catalyst::Engine>.
1909
1910 =cut
1911
1912 sub prepare_body_chunk {
1913     my $c = shift;
1914     $c->engine->prepare_body_chunk( $c, @_ );
1915 }
1916
1917 =head2 $c->prepare_body_parameters
1918
1919 Prepares body parameters.
1920
1921 =cut
1922
1923 sub prepare_body_parameters {
1924     my $c = shift;
1925     $c->engine->prepare_body_parameters( $c, @_ );
1926 }
1927
1928 =head2 $c->prepare_connection
1929
1930 Prepares connection.
1931
1932 =cut
1933
1934 sub prepare_connection {
1935     my $c = shift;
1936     $c->engine->prepare_connection( $c, @_ );
1937 }
1938
1939 =head2 $c->prepare_cookies
1940
1941 Prepares cookies.
1942
1943 =cut
1944
1945 sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
1946
1947 =head2 $c->prepare_headers
1948
1949 Prepares headers.
1950
1951 =cut
1952
1953 sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
1954
1955 =head2 $c->prepare_parameters
1956
1957 Prepares parameters.
1958
1959 =cut
1960
1961 sub prepare_parameters {
1962     my $c = shift;
1963     $c->prepare_body_parameters;
1964     $c->engine->prepare_parameters( $c, @_ );
1965 }
1966
1967 =head2 $c->prepare_path
1968
1969 Prepares path and base.
1970
1971 =cut
1972
1973 sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
1974
1975 =head2 $c->prepare_query_parameters
1976
1977 Prepares query parameters.
1978
1979 =cut
1980
1981 sub prepare_query_parameters {
1982     my $c = shift;
1983
1984     $c->engine->prepare_query_parameters( $c, @_ );
1985 }
1986
1987 =head2 $c->log_request
1988
1989 Writes information about the request to the debug logs.  This includes:
1990
1991 =over 4
1992
1993 =item * Request method, path, and remote IP address
1994
1995 =item * Query keywords (see L<Catalyst::Request/query_keywords>)
1996
1997 =item * Request parameters
1998
1999 =item * File uploads
2000
2001 =back
2002
2003 =cut
2004
2005 sub log_request {
2006     my $c = shift;
2007
2008     return unless $c->debug;
2009
2010     my($dump) = grep {$_->[0] eq 'Request' } $c->dump_these;
2011     my $request = $dump->[1];
2012
2013     my ( $method, $path, $address ) = ( $request->method, $request->path, $request->address );
2014     $method ||= '';
2015     $path = '/' unless length $path;
2016     $address ||= '';
2017     $c->log->debug(qq/"$method" request for "$path" from "$address"/);
2018
2019     $c->log_request_headers($request->headers);
2020
2021     if ( my $keywords = $request->query_keywords ) {
2022         $c->log->debug("Query keywords are: $keywords");
2023     }
2024
2025     $c->log_request_parameters( query => $request->query_parameters, $request->_has_body ? (body => $request->body_parameters) : () );
2026
2027     $c->log_request_uploads($request);
2028 }
2029
2030 =head2 $c->log_response
2031
2032 Writes information about the response to the debug logs by calling
2033 C<< $c->log_response_status_line >> and C<< $c->log_response_headers >>.
2034
2035 =cut
2036
2037 sub log_response {
2038     my $c = shift;
2039
2040     return unless $c->debug;
2041
2042     my($dump) = grep {$_->[0] eq 'Response' } $c->dump_these;
2043     my $response = $dump->[1];
2044
2045     $c->log_response_status_line($response);
2046     $c->log_response_headers($response->headers);
2047 }
2048
2049 =head2 $c->log_response_status_line($response)
2050
2051 Writes one line of information about the response to the debug logs.  This includes:
2052
2053 =over 4
2054
2055 =item * Response status code
2056
2057 =item * Content-Type header (if present)
2058
2059 =item * Content-Length header (if present)
2060
2061 =back
2062
2063 =cut
2064
2065 sub log_response_status_line {
2066     my ($c, $response) = @_;
2067
2068     $c->log->debug(
2069         sprintf(
2070             'Response Code: %s; Content-Type: %s; Content-Length: %s',
2071             $response->status                            || 'unknown',
2072             $response->headers->header('Content-Type')   || 'unknown',
2073             $response->headers->header('Content-Length') || 'unknown'
2074         )
2075     );
2076 }
2077
2078 =head2 $c->log_response_headers($headers);
2079
2080 Hook method which can be wrapped by plugins to log the responseheaders.
2081 No-op in the default implementation.
2082
2083 =cut
2084
2085 sub log_response_headers {}
2086
2087 =head2 $c->log_request_parameters( query => {}, body => {} )
2088
2089 Logs request parameters to debug logs
2090
2091 =cut
2092
2093 sub log_request_parameters {
2094     my $c          = shift;
2095     my %all_params = @_;
2096
2097     return unless $c->debug;
2098
2099     my $column_width = Catalyst::Utils::term_width() - 44;
2100     foreach my $type (qw(query body)) {
2101         my $params = $all_params{$type};
2102         next if ! keys %$params;
2103         my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ $column_width, 'Value' ] );
2104         for my $key ( sort keys %$params ) {
2105             my $param = $params->{$key};
2106             my $value = defined($param) ? $param : '';
2107             $t->row( $key, ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
2108         }
2109         $c->log->debug( ucfirst($type) . " Parameters are:\n" . $t->draw );
2110     }
2111 }
2112
2113 =head2 $c->log_request_uploads
2114
2115 Logs file uploads included in the request to the debug logs.
2116 The parameter name, filename, file type, and file size are all included in
2117 the debug logs.
2118
2119 =cut
2120
2121 sub log_request_uploads {
2122     my $c = shift;
2123     my $request = shift;
2124     return unless $c->debug;
2125     my $uploads = $request->uploads;
2126     if ( keys %$uploads ) {
2127         my $t = Text::SimpleTable->new(
2128             [ 12, 'Parameter' ],
2129             [ 26, 'Filename' ],
2130             [ 18, 'Type' ],
2131             [ 9,  'Size' ]
2132         );
2133         for my $key ( sort keys %$uploads ) {
2134             my $upload = $uploads->{$key};
2135             for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
2136                 $t->row( $key, $u->filename, $u->type, $u->size );
2137             }
2138         }
2139         $c->log->debug( "File Uploads are:\n" . $t->draw );
2140     }
2141 }
2142
2143 =head2 $c->log_request_headers($headers);
2144
2145 Hook method which can be wrapped by plugins to log the request headers.
2146 No-op in the default implementation.
2147
2148 =cut
2149
2150 sub log_request_headers {}
2151
2152 =head2 $c->log_headers($type => $headers)
2153
2154 Logs L<HTTP::Headers> (either request or response) to the debug logs.
2155
2156 =cut
2157
2158 sub log_headers {
2159     my $c       = shift;
2160     my $type    = shift;
2161     my $headers = shift;    # an HTTP::Headers instance
2162
2163     return unless $c->debug;
2164
2165     my $column_width = Catalyst::Utils::term_width() - 28;
2166     my $t = Text::SimpleTable->new( [ 15, 'Header Name' ], [ $column_width, 'Value' ] );
2167     $headers->scan(
2168         sub {
2169             my ( $name, $value ) = @_;
2170             $t->row( $name, $value );
2171         }
2172     );
2173     $c->log->debug( ucfirst($type) . " Headers:\n" . $t->draw );
2174 }
2175
2176
2177 =head2 $c->prepare_read
2178
2179 Prepares the input for reading.
2180
2181 =cut
2182
2183 sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
2184
2185 =head2 $c->prepare_request
2186
2187 Prepares the engine request.
2188
2189 =cut
2190
2191 sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
2192
2193 =head2 $c->prepare_uploads
2194
2195 Prepares uploads.
2196
2197 =cut
2198
2199 sub prepare_uploads {
2200     my $c = shift;
2201
2202     $c->engine->prepare_uploads( $c, @_ );
2203 }
2204
2205 =head2 $c->prepare_write
2206
2207 Prepares the output for writing.
2208
2209 =cut
2210
2211 sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
2212
2213 =head2 $c->request_class
2214
2215 Returns or sets the request class. Defaults to L<Catalyst::Request>.
2216
2217 =head2 $c->response_class
2218
2219 Returns or sets the response class. Defaults to L<Catalyst::Response>.
2220
2221 =head2 $c->read( [$maxlength] )
2222
2223 Reads a chunk of data from the request body. This method is designed to
2224 be used in a while loop, reading C<$maxlength> bytes on every call.
2225 C<$maxlength> defaults to the size of the request if not specified.
2226
2227 You have to set C<< MyApp->config(parse_on_demand => 1) >> to use this
2228 directly.
2229
2230 Warning: If you use read(), Catalyst will not process the body,
2231 so you will not be able to access POST parameters or file uploads via
2232 $c->request.  You must handle all body parsing yourself.
2233
2234 =cut
2235
2236 sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
2237
2238 =head2 $c->run
2239
2240 Starts the engine.
2241
2242 =cut
2243
2244 sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
2245
2246 =head2 $c->set_action( $action, $code, $namespace, $attrs )
2247
2248 Sets an action in a given namespace.
2249
2250 =cut
2251
2252 sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
2253
2254 =head2 $c->setup_actions($component)
2255
2256 Sets up actions for a component.
2257
2258 =cut
2259
2260 sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
2261
2262 =head2 $c->setup_config
2263
2264 =cut
2265
2266 sub setup_config {
2267     my $class = shift;
2268
2269     my %args = %{ $class->config || {} };
2270
2271     my @container_classes = ( "${class}::Container", 'Catalyst::IOC::Container');
2272     unshift @container_classes, delete $args{container_class} if exists $args{container_class};
2273
2274     my $container_class = Class::MOP::load_first_existing_class(@container_classes);
2275
2276     my $container = $container_class->new( %args, application_name => "$class", name => "$class" );
2277     $class->container($container);
2278
2279     my $config = $container->resolve( service => 'config' );
2280     $class->config($config);
2281     $class->finalize_config; # back-compat
2282 }
2283
2284 =head2 $c->finalize_config
2285
2286 =cut
2287
2288 sub finalize_config { }
2289
2290 =head2 $c->setup_components
2291
2292 This method is called internally to set up the application's components.
2293
2294 It finds modules by calling the L<locate_components> method, expands them to
2295 package names with the $container->expand_component_module method, and then
2296 installs each component into the application.
2297
2298 The C<setup_components> config option is passed to both of the above methods.
2299
2300 =cut
2301
2302 sub setup_components {
2303     shift->container->setup_components();
2304 }
2305
2306 =head2 locate_components
2307
2308 =cut
2309
2310 # FIXME - removed locate_components
2311 # don't people mess with this method directly?
2312 # what to do with that?
2313
2314 sub locate_components {
2315     my $class = shift;
2316
2317     $class->log->warn('The locate_components method has been deprecated.');
2318     $class->log->warn('Please read Catalyst::IOC::Container documentation to');
2319     $class->log->warn('update your application.');
2320
2321     # XXX think about ditching this sort entirely
2322     return sort { length $a <=> length $b }
2323         @{ $class->container->resolve( service => 'locate_components' ) };
2324 }
2325
2326
2327 =head2 $c->setup_dispatcher
2328
2329 Sets up dispatcher.
2330
2331 =cut
2332
2333 sub setup_dispatcher {
2334     my ( $class, $dispatcher ) = @_;
2335
2336     if ($dispatcher) {
2337         $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
2338     }
2339
2340     if ( my $env = Catalyst::Utils::env_value( $class, 'DISPATCHER' ) ) {
2341         $dispatcher = 'Catalyst::Dispatcher::' . $env;
2342     }
2343
2344     unless ($dispatcher) {
2345         $dispatcher = $class->dispatcher_class;
2346     }
2347
2348     Class::MOP::load_class($dispatcher);
2349
2350     # dispatcher instance
2351     $class->dispatcher( $dispatcher->new );
2352 }
2353
2354 =head2 $c->setup_engine
2355
2356 Sets up engine.
2357
2358 =cut
2359
2360 sub setup_engine {
2361     my ( $class, $engine ) = @_;
2362
2363     if ($engine) {
2364         $engine = 'Catalyst::Engine::' . $engine;
2365     }
2366
2367     if ( my $env = Catalyst::Utils::env_value( $class, 'ENGINE' ) ) {
2368         $engine = 'Catalyst::Engine::' . $env;
2369     }
2370
2371     if ( $ENV{MOD_PERL} ) {
2372         my $meta = Class::MOP::get_metaclass_by_name($class);
2373
2374         # create the apache method
2375         $meta->add_method('apache' => sub { shift->engine->apache });
2376
2377         my ( $software, $version ) =
2378           $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
2379
2380         $version =~ s/_//g;
2381         $version =~ s/(\.[^.]+)\./$1/g;
2382
2383         if ( $software eq 'mod_perl' ) {
2384
2385             if ( !$engine ) {
2386
2387                 if ( $version >= 1.99922 ) {
2388                     $engine = 'Catalyst::Engine::Apache2::MP20';
2389                 }
2390
2391                 elsif ( $version >= 1.9901 ) {
2392                     $engine = 'Catalyst::Engine::Apache2::MP19';
2393                 }
2394
2395                 elsif ( $version >= 1.24 ) {
2396                     $engine = 'Catalyst::Engine::Apache::MP13';
2397                 }
2398
2399                 else {
2400                     Catalyst::Exception->throw( message =>
2401                           qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
2402                 }
2403
2404             }
2405
2406             # install the correct mod_perl handler
2407             if ( $version >= 1.9901 ) {
2408                 *handler = sub  : method {
2409                     shift->handle_request(@_);
2410                 };
2411             }
2412             else {
2413                 *handler = sub ($$) { shift->handle_request(@_) };
2414             }
2415
2416         }
2417
2418         elsif ( $software eq 'Zeus-Perl' ) {
2419             $engine = 'Catalyst::Engine::Zeus';
2420         }
2421
2422         else {
2423             Catalyst::Exception->throw(
2424                 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
2425         }
2426     }
2427
2428     unless ($engine) {
2429         $engine = $class->engine_class;
2430     }
2431
2432     Class::MOP::load_class($engine);
2433
2434     # check for old engines that are no longer compatible
2435     my $old_engine;
2436     if ( $engine->isa('Catalyst::Engine::Apache')
2437         && !Catalyst::Engine::Apache->VERSION )
2438     {
2439         $old_engine = 1;
2440     }
2441
2442     elsif ( $engine->isa('Catalyst::Engine::Server::Base')
2443         && Catalyst::Engine::Server->VERSION le '0.02' )
2444     {
2445         $old_engine = 1;
2446     }
2447
2448     elsif ($engine->isa('Catalyst::Engine::HTTP::POE')
2449         && $engine->VERSION eq '0.01' )
2450     {
2451         $old_engine = 1;
2452     }
2453
2454     elsif ($engine->isa('Catalyst::Engine::Zeus')
2455         && $engine->VERSION eq '0.01' )
2456     {
2457         $old_engine = 1;
2458     }
2459
2460     if ($old_engine) {
2461         Catalyst::Exception->throw( message =>
2462               qq/Engine "$engine" is not supported by this version of Catalyst/
2463         );
2464     }
2465
2466     # engine instance
2467     $class->engine( $engine->new );
2468 }
2469
2470 =head2 $c->setup_home
2471
2472 Sets up the home directory.
2473
2474 =cut
2475
2476 sub setup_home {
2477     my ( $class, $home ) = @_;
2478
2479     if ( my $env = Catalyst::Utils::env_value( $class, 'HOME' ) ) {
2480         $home = $env;
2481     }
2482
2483     $home ||= Catalyst::Utils::home($class);
2484
2485     if ($home) {
2486         #I remember recently being scolded for assigning config values like this
2487         $class->config->{home} ||= $home;
2488         $class->config->{root} ||= Path::Class::Dir->new($home)->subdir('root');
2489     }
2490 }
2491
2492 =head2 $c->setup_log
2493
2494 Sets up log by instantiating a L<Catalyst::Log|Catalyst::Log> object and
2495 passing it to C<log()>. Pass in a comma-delimited list of levels to set the
2496 log to.
2497
2498 This method also installs a C<debug> method that returns a true value into the
2499 catalyst subclass if the "debug" level is passed in the comma-delimited list,
2500 or if the C<$CATALYST_DEBUG> environment variable is set to a true value.
2501
2502 Note that if the log has already been setup, by either a previous call to
2503 C<setup_log> or by a call such as C<< __PACKAGE__->log( MyLogger->new ) >>,
2504 that this method won't actually set up the log object.
2505
2506 =cut
2507
2508 sub setup_log {
2509     my ( $class, $levels ) = @_;
2510
2511     $levels ||= '';
2512     $levels =~ s/^\s+//;
2513     $levels =~ s/\s+$//;
2514     my %levels = map { $_ => 1 } split /\s*,\s*/, $levels;
2515
2516     my $env_debug = Catalyst::Utils::env_value( $class, 'DEBUG' );
2517     if ( defined $env_debug ) {
2518         $levels{debug} = 1 if $env_debug; # Ugly!
2519         delete($levels{debug}) unless $env_debug;
2520     }
2521
2522     unless ( $class->log ) {
2523         $class->log( Catalyst::Log->new(keys %levels) );
2524     }
2525
2526     if ( $levels{debug} ) {
2527         Class::MOP::get_metaclass_by_name($class)->add_method('debug' => sub { 1 });
2528         $class->log->debug('Debug messages enabled');
2529     }
2530 }
2531
2532 =head2 $c->setup_plugins
2533
2534 Sets up plugins.
2535
2536 =cut
2537
2538 =head2 $c->setup_stats
2539
2540 Sets up timing statistics class.
2541
2542 =cut
2543
2544 sub setup_stats {
2545     my ( $class, $stats ) = @_;
2546
2547     Catalyst::Utils::ensure_class_loaded($class->stats_class);
2548
2549     my $env = Catalyst::Utils::env_value( $class, 'STATS' );
2550     if ( defined($env) ? $env : ($stats || $class->debug ) ) {
2551         Class::MOP::get_metaclass_by_name($class)->add_method('use_stats' => sub { 1 });
2552         $class->log->debug('Statistics enabled');
2553     }
2554 }
2555
2556
2557 =head2 $c->registered_plugins
2558
2559 Returns a sorted list of the plugins which have either been stated in the
2560 import list or which have been added via C<< MyApp->plugin(@args); >>.
2561
2562 If passed a given plugin name, it will report a boolean value indicating
2563 whether or not that plugin is loaded.  A fully qualified name is required if
2564 the plugin name does not begin with C<Catalyst::Plugin::>.
2565
2566  if ($c->registered_plugins('Some::Plugin')) {
2567      ...
2568  }
2569
2570 =cut
2571
2572 {
2573
2574     sub registered_plugins {
2575         my $proto = shift;
2576         return sort keys %{ $proto->_plugins } unless @_;
2577         my $plugin = shift;
2578         return 1 if exists $proto->_plugins->{$plugin};
2579         return exists $proto->_plugins->{"Catalyst::Plugin::$plugin"};
2580     }
2581
2582     sub _register_plugin {
2583         my ( $proto, $plugin, $instant ) = @_;
2584         my $class = ref $proto || $proto;
2585
2586         Class::MOP::load_class( $plugin );
2587         $class->log->warn( "$plugin inherits from 'Catalyst::Component' - this is deprecated and will not work in 5.81" )
2588             if $plugin->isa( 'Catalyst::Component' );
2589         $proto->_plugins->{$plugin} = 1;
2590         unless ($instant) {
2591             my $meta = Class::MOP::get_metaclass_by_name($class);
2592             $meta->superclasses($plugin, $meta->superclasses);
2593         }
2594         return $class;
2595     }
2596
2597     sub setup_plugins {
2598         my ( $class, $plugins ) = @_;
2599
2600         $class->_plugins( {} ) unless $class->_plugins;
2601         $plugins = Data::OptList::mkopt($plugins || []);
2602
2603         my @plugins = map {
2604             [ Catalyst::Utils::resolve_namespace(
2605                   $class . '::Plugin',
2606                   'Catalyst::Plugin', $_->[0]
2607               ),
2608               $_->[1],
2609             ]
2610          } @{ $plugins };
2611
2612         for my $plugin ( reverse @plugins ) {
2613             Class::MOP::load_class($plugin->[0], $plugin->[1]);
2614             my $meta = find_meta($plugin->[0]);
2615             next if $meta && $meta->isa('Moose::Meta::Role');
2616
2617             $class->_register_plugin($plugin->[0]);
2618         }
2619
2620         my @roles =
2621             map  { $_->[0]->name, $_->[1] }
2622             grep { blessed($_->[0]) && $_->[0]->isa('Moose::Meta::Role') }
2623             map  { [find_meta($_->[0]), $_->[1]] }
2624             @plugins;
2625
2626         Moose::Util::apply_all_roles(
2627             $class => @roles
2628         ) if @roles;
2629     }
2630 }
2631
2632 =head2 $c->stack
2633
2634 Returns an arrayref of the internal execution stack (actions that are
2635 currently executing).
2636
2637 =head2 $c->stats
2638
2639 Returns the current timing statistics object. By default Catalyst uses
2640 L<Catalyst::Stats|Catalyst::Stats>, but can be set otherwise with
2641 L<< stats_class|/"$c->stats_class" >>.
2642
2643 Even if L<< -Stats|/"-Stats" >> is not enabled, the stats object is still
2644 available. By enabling it with C< $c->stats->enabled(1) >, it can be used to
2645 profile explicitly, although MyApp.pm still won't profile nor output anything
2646 by itself.
2647
2648 =head2 $c->stats_class
2649
2650 Returns or sets the stats (timing statistics) class. L<Catalyst::Stats|Catalyst::Stats> is used by default.
2651
2652 =head2 $c->use_stats
2653
2654 Returns 1 when L<< stats collection|/"-Stats" >> is enabled.
2655
2656 Note that this is a static method, not an accessor and should be overridden
2657 by declaring C<sub use_stats { 1 }> in your MyApp.pm, not by calling C<< $c->use_stats(1) >>.
2658
2659 =cut
2660
2661 sub use_stats { 0 }
2662
2663
2664 =head2 $c->write( $data )
2665
2666 Writes $data to the output stream. When using this method directly, you
2667 will need to manually set the C<Content-Length> header to the length of
2668 your output data, if known.
2669
2670 =cut
2671
2672 sub write {
2673     my $c = shift;
2674
2675     # Finalize headers if someone manually writes output
2676     $c->finalize_headers;
2677
2678     return $c->engine->write( $c, @_ );
2679 }
2680
2681 =head2 version
2682
2683 Returns the Catalyst version number. Mostly useful for "powered by"
2684 messages in template systems.
2685
2686 =cut
2687
2688 sub version { return $Catalyst::VERSION }
2689
2690 =head1 CONFIGURATION
2691
2692 There are a number of 'base' config variables which can be set:
2693
2694 =over
2695
2696 =item *
2697
2698 C<default_model> - The default model picked if you say C<< $c->model >>. See L<< /$c->model($name) >>.
2699
2700 =item *
2701
2702 C<default_view> - The default view to be rendered or returned when C<< $c->view >> is called. See L<< /$c->view($name) >>.
2703
2704 =item *
2705
2706 C<home> - The application home directory. In an uninstalled application,
2707 this is the top level application directory. In an installed application,
2708 this will be the directory containing C<< MyApp.pm >>.
2709
2710 =item *
2711
2712 C<ignore_frontend_proxy> - See L</PROXY SUPPORT>
2713
2714 =item *
2715
2716 C<name> - The name of the application in debug messages and the debug and
2717 welcome screens
2718
2719 =item *
2720
2721 C<parse_on_demand> - The request body (for example file uploads) will not be parsed
2722 until it is accessed. This allows you to (for example) check authentication (and reject
2723 the upload) before actually recieving all the data. See L</ON-DEMAND PARSER>
2724
2725 =item *
2726
2727 C<root> - The root directory for templates. Usually this is just a
2728 subdirectory of the home directory, but you can set it to change the
2729 templates to a different directory.
2730
2731 =item *
2732
2733 C<show_internal_actions> - If true, causes internal actions such as C<< _DISPATCH >>
2734 to be shown in hit debug tables in the test server.
2735
2736 =item *
2737
2738 C<use_request_uri_for_path> - Controlls if the C<REQUEST_URI> or C<PATH_INFO> environment
2739 variable should be used for determining the request path. See L<Catalyst::Engine::CGI/PATH DECODING>
2740 for more information.
2741
2742 =item *
2743
2744 C<using_frontend_proxy> - See L</PROXY SUPPORT>.
2745
2746 =back
2747
2748 =head1 INTERNAL ACTIONS
2749
2750 Catalyst uses internal actions like C<_DISPATCH>, C<_BEGIN>, C<_AUTO>,
2751 C<_ACTION>, and C<_END>. These are by default not shown in the private
2752 action table, but you can make them visible with a config parameter.
2753
2754     MyApp->config(show_internal_actions => 1);
2755
2756 =head1 ON-DEMAND PARSER
2757
2758 The request body is usually parsed at the beginning of a request,
2759 but if you want to handle input yourself, you can enable on-demand
2760 parsing with a config parameter.
2761
2762     MyApp->config(parse_on_demand => 1);
2763
2764 =head1 PROXY SUPPORT
2765
2766 Many production servers operate using the common double-server approach,
2767 with a lightweight frontend web server passing requests to a larger
2768 backend server. An application running on the backend server must deal
2769 with two problems: the remote user always appears to be C<127.0.0.1> and
2770 the server's hostname will appear to be C<localhost> regardless of the
2771 virtual host that the user connected through.
2772
2773 Catalyst will automatically detect this situation when you are running
2774 the frontend and backend servers on the same machine. The following
2775 changes are made to the request.
2776
2777     $c->req->address is set to the user's real IP address, as read from
2778     the HTTP X-Forwarded-For header.
2779
2780     The host value for $c->req->base and $c->req->uri is set to the real
2781     host, as read from the HTTP X-Forwarded-Host header.
2782
2783 Additionally, you may be running your backend application on an insecure
2784 connection (port 80) while your frontend proxy is running under SSL.  If there
2785 is a discrepancy in the ports, use the HTTP header C<X-Forwarded-Port> to
2786 tell Catalyst what port the frontend listens on.  This will allow all URIs to
2787 be created properly.
2788
2789 In the case of passing in:
2790
2791     X-Forwarded-Port: 443
2792
2793 All calls to C<uri_for> will result in an https link, as is expected.
2794
2795 Obviously, your web server must support these headers for this to work.
2796
2797 In a more complex server farm environment where you may have your
2798 frontend proxy server(s) on different machines, you will need to set a
2799 configuration option to tell Catalyst to read the proxied data from the
2800 headers.
2801
2802     MyApp->config(using_frontend_proxy => 1);
2803
2804 If you do not wish to use the proxy support at all, you may set:
2805
2806     MyApp->config(ignore_frontend_proxy => 1);
2807
2808 =head1 THREAD SAFETY
2809
2810 Catalyst has been tested under Apache 2's threading C<mpm_worker>,
2811 C<mpm_winnt>, and the standalone forking HTTP server on Windows. We
2812 believe the Catalyst core to be thread-safe.
2813
2814 If you plan to operate in a threaded environment, remember that all other
2815 modules you are using must also be thread-safe. Some modules, most notably
2816 L<DBD::SQLite>, are not thread-safe.
2817
2818 =head1 SUPPORT
2819
2820 IRC:
2821
2822     Join #catalyst on irc.perl.org.
2823
2824 Mailing Lists:
2825
2826     http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst
2827     http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst-dev
2828
2829 Web:
2830
2831     http://catalyst.perl.org
2832
2833 Wiki:
2834
2835     http://dev.catalyst.perl.org
2836
2837 =head1 SEE ALSO
2838
2839 =head2 L<Task::Catalyst> - All you need to start with Catalyst
2840
2841 =head2 L<Catalyst::Manual> - The Catalyst Manual
2842
2843 =head2 L<Catalyst::Component>, L<Catalyst::Controller> - Base classes for components
2844
2845 =head2 L<Catalyst::Engine> - Core engine
2846
2847 =head2 L<Catalyst::Log> - Log class.
2848
2849 =head2 L<Catalyst::Request> - Request object
2850
2851 =head2 L<Catalyst::Response> - Response object
2852
2853 =head2 L<Catalyst::Test> - The test suite.
2854
2855 =head1 PROJECT FOUNDER
2856
2857 sri: Sebastian Riedel <sri@cpan.org>
2858
2859 =head1 CONTRIBUTORS
2860
2861 abw: Andy Wardley
2862
2863 acme: Leon Brocard <leon@astray.com>
2864
2865 abraxxa: Alexander Hartmaier <abraxxa@cpan.org>
2866
2867 Andrew Bramble
2868
2869 Andrew Ford E<lt>A.Ford@ford-mason.co.ukE<gt>
2870
2871 Andrew Ruthven
2872
2873 André Walker
2874
2875 andyg: Andy Grundman <andy@hybridized.org>
2876
2877 audreyt: Audrey Tang
2878
2879 bricas: Brian Cassidy <bricas@cpan.org>
2880
2881 Caelum: Rafael Kitover <rkitover@io.com>
2882
2883 chansen: Christian Hansen
2884
2885 chicks: Christopher Hicks
2886
2887 Chisel Wright C<pause@herlpacker.co.uk>
2888
2889 Danijel Milicevic C<me@danijel.de>
2890
2891 David Kamholz E<lt>dkamholz@cpan.orgE<gt>
2892
2893 David Naughton, C<naughton@umn.edu>
2894
2895 David E. Wheeler
2896
2897 dhoss: Devin Austin <dhoss@cpan.org>
2898
2899 dkubb: Dan Kubb <dan.kubb-cpan@onautopilot.com>
2900
2901 Drew Taylor
2902
2903 dwc: Daniel Westermann-Clark <danieltwc@cpan.org>
2904
2905 esskar: Sascha Kiefer
2906
2907 fireartist: Carl Franks <cfranks@cpan.org>
2908
2909 frew: Arthur Axel "fREW" Schmidt <frioux@gmail.com>
2910
2911 gabb: Danijel Milicevic
2912
2913 Gary Ashton Jones
2914
2915 Gavin Henry C<ghenry@perl.me.uk>
2916
2917 Geoff Richards
2918
2919 groditi: Guillermo Roditi <groditi@gmail.com>
2920
2921 hobbs: Andrew Rodland <andrew@cleverdomain.org>
2922
2923 ilmari: Dagfinn Ilmari MannsÃ¥ker <ilmari@ilmari.org>
2924
2925 jcamacho: Juan Camacho
2926
2927 jester: Jesse Sheidlower C<jester@panix.com>
2928
2929 jhannah: Jay Hannah <jay@jays.net>
2930
2931 Jody Belka
2932
2933 Johan Lindstrom
2934
2935 jon: Jon Schutz <jjschutz@cpan.org>
2936
2937 Jonathan Rockway C<< <jrockway@cpan.org> >>
2938
2939 Kieren Diment C<kd@totaldatasolution.com>
2940
2941 konobi: Scott McWhirter <konobi@cpan.org>
2942
2943 marcus: Marcus Ramberg <mramberg@cpan.org>
2944
2945 miyagawa: Tatsuhiko Miyagawa <miyagawa@bulknews.net>
2946
2947 mst: Matt S. Trout <mst@shadowcatsystems.co.uk>
2948
2949 mugwump: Sam Vilain
2950
2951 naughton: David Naughton
2952
2953 ningu: David Kamholz <dkamholz@cpan.org>
2954
2955 nothingmuch: Yuval Kogman <nothingmuch@woobling.org>
2956
2957 numa: Dan Sully <daniel@cpan.org>
2958
2959 obra: Jesse Vincent
2960
2961 Octavian Rasnita
2962
2963 omega: Andreas Marienborg
2964
2965 Oleg Kostyuk <cub.uanic@gmail.com>
2966
2967 phaylon: Robert Sedlacek <phaylon@dunkelheit.at>
2968
2969 rafl: Florian Ragwitz <rafl@debian.org>
2970
2971 random: Roland Lammel <lammel@cpan.org>
2972
2973 Robert Sedlacek C<< <rs@474.at> >>
2974
2975 SpiceMan: Marcel Montes
2976
2977 sky: Arthur Bergman
2978
2979 szbalint: Balint Szilakszi <szbalint@cpan.org>
2980
2981 t0m: Tomas Doran <bobtfish@bobtfish.net>
2982
2983 Ulf Edvinsson
2984
2985 Viljo Marrandi C<vilts@yahoo.com>
2986
2987 Will Hawes C<info@whawes.co.uk>
2988
2989 willert: Sebastian Willert <willert@cpan.org>
2990
2991 wreis: Wallace Reis <wallace@reis.org.br>
2992
2993 Yuval Kogman, C<nothingmuch@woobling.org>
2994
2995 rainboxx: Matthias Dietrich, C<perl@rainboxx.de>
2996
2997 dd070: Dhaval Dhanani <dhaval070@gmail.com>
2998
2999 =head1 COPYRIGHT
3000
3001 Copyright (c) 2005, the above named PROJECT FOUNDER and CONTRIBUTORS.
3002
3003 =head1 LICENSE
3004
3005 This library is free software. You can redistribute it and/or modify it under
3006 the same terms as Perl itself.
3007
3008 =cut
3009
3010 no Moose;
3011
3012 __PACKAGE__->meta->make_immutable;
3013
3014 1;