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