prepare for _02...
[catagits/Catalyst-Runtime.git] / lib / Catalyst.pm
1 package Catalyst;
2
3 use strict;
4 use base 'Catalyst::Base';
5 use bytes;
6 use UNIVERSAL::require;
7 use Catalyst::Exception;
8 use Catalyst::Log;
9 use Catalyst::Request;
10 use Catalyst::Request::Upload;
11 use Catalyst::Response;
12 use Catalyst::Utils;
13 use NEXT;
14 use Text::ASCIITable;
15 use Path::Class;
16 use Time::HiRes qw/gettimeofday tv_interval/;
17 use URI;
18 use Scalar::Util qw/weaken/;
19
20 __PACKAGE__->mk_accessors(
21     qw/counter depth request response state action namespace/
22 );
23
24 # Laziness++
25 *comp = \&component;
26 *req  = \&request;
27 *res  = \&response;
28
29 # For backwards compatibility
30 *finalize_output = \&finalize_body;
31
32 # For statistics
33 our $COUNT     = 1;
34 our $START     = time;
35 our $RECURSION = 1000;
36 our $DETACH    = "catalyst_detach\n";
37
38 require Module::Pluggable::Fast;
39
40 # Helper script generation
41 our $CATALYST_SCRIPT_GEN = 8;
42
43 __PACKAGE__->mk_classdata($_)
44   for qw/components arguments dispatcher engine log/;
45
46 our $VERSION = '5.49_02';
47
48 sub import {
49     my ( $class, @arguments ) = @_;
50
51     # We have to limit $class to Catalyst to avoid pushing Catalyst upon every
52     # callers @ISA.
53     return unless $class eq 'Catalyst';
54
55     my $caller = caller(0);
56
57     unless ( $caller->isa('Catalyst') ) {
58         no strict 'refs';
59         push @{"$caller\::ISA"}, $class;
60     }
61
62     $caller->arguments( [@arguments] );
63     $caller->setup_home;
64 }
65
66 =head1 NAME
67
68 Catalyst - The Elegant MVC Web Application Framework
69
70 =head1 SYNOPSIS
71
72     # use the helper to start a new application
73     catalyst.pl MyApp
74     cd MyApp
75
76     # add models, views, controllers
77     script/myapp_create.pl model Something
78     script/myapp_create.pl view Stuff
79     script/myapp_create.pl controller Yada
80
81     # built in testserver
82     script/myapp_server.pl
83
84     # command line interface
85     script/myapp_test.pl /yada
86
87
88     use Catalyst;
89
90     use Catalyst qw/My::Module My::OtherModule/;
91
92     use Catalyst '-Debug';
93
94     use Catalyst qw/-Debug -Engine=CGI/;
95
96     sub default : Private { $_[1]->res->output('Hello') } );
97
98     sub index : Path('/index.html') {
99         my ( $self, $c ) = @_;
100         $c->res->output('Hello');
101         $c->forward('foo');
102     }
103
104     sub product : Regex('^product[_]*(\d*).html$') {
105         my ( $self, $c ) = @_;
106         $c->stash->{template} = 'product.tt';
107         $c->stash->{product} = $c->req->snippets->[0];
108     }
109
110 See also L<Catalyst::Manual::Intro>
111
112 =head1 DESCRIPTION
113
114 The key concept of Catalyst is DRY (Don't Repeat Yourself).
115
116 See L<Catalyst::Manual> for more documentation.
117
118 Catalyst plugins can be loaded by naming them as arguments to the "use Catalyst" statement.
119 Omit the C<Catalyst::Plugin::> prefix from the plugin name,
120 so C<Catalyst::Plugin::My::Module> becomes C<My::Module>.
121
122     use Catalyst 'My::Module';
123
124 Special flags like -Debug and -Engine can also be specified as arguments when
125 Catalyst is loaded:
126
127     use Catalyst qw/-Debug My::Module/;
128
129 The position of plugins and flags in the chain is important, because they are
130 loaded in exactly the order that they appear.
131
132 The following flags are supported:
133
134 =over 4
135
136 =item -Debug
137
138 enables debug output, i.e.:
139
140     use Catalyst '-Debug';
141
142 this is equivalent to:
143
144     use Catalyst;
145     sub debug { 1 }
146
147 =item -Dispatcher
148
149 Force Catalyst to use a specific dispatcher.
150
151 =item -Engine
152
153 Force Catalyst to use a specific engine.
154 Omit the C<Catalyst::Engine::> prefix of the engine name, i.e.:
155
156     use Catalyst '-Engine=CGI';
157
158 =item -Home
159
160 Force Catalyst to use a specific home directory.
161
162 =item -Log
163
164 Specify log level.
165
166 =back
167
168 =head1 METHODS
169
170 =over 4
171
172 =item $c->action
173
174 Accessor for the current action
175
176 =item $c->comp($name)
177
178 =item $c->component($name)
179
180 Get a component object by name.
181
182     $c->comp('MyApp::Model::MyModel')->do_stuff;
183
184 =cut
185
186 sub component {
187     my $c = shift;
188
189     if (@_) {
190
191         my $name = shift;
192
193         my $appclass = ref $c || $c;
194
195         my @names = (
196             $name, "${appclass}::${name}",
197             map { "${appclass}::${_}::${name}" } qw/M V C/
198         );
199
200         foreach my $try (@names) {
201
202             if ( exists $c->components->{$try} ) {
203
204                 return $c->components->{$try};
205             }
206         }
207
208         foreach my $component ( keys %{ $c->components } ) {
209
210             return $c->components->{$component} if $component =~ /$name/i;
211         }
212
213     }
214
215     return sort keys %{ $c->components };
216 }
217
218 =item config
219
220 Returns a hashref containing your applications settings.
221
222 =item debug
223
224 Overload to enable debug messages.
225
226 =cut
227
228 sub debug { 0 }
229
230 =item $c->detach( $command [, \@arguments ] )
231
232 Like C<forward> but doesn't return.
233
234 =cut
235
236 sub detach { my $c = shift; $c->dispatcher->detach( $c, @_ ) }
237
238 =item $c->dispatcher
239
240 Contains the dispatcher instance.
241 Stringifies to class.
242
243 =item $c->forward( $command [, \@arguments ] )
244
245 Forward processing to a private action or a method from a class.
246 If you define a class without method it will default to process().
247 also takes an optional arrayref containing arguments to be passed
248 to the new function. $c->req->args will be reset upon returning 
249 from the function.
250
251     $c->forward('/foo');
252     $c->forward('index');
253     $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
254     $c->forward('MyApp::View::TT');
255
256 =cut
257
258 sub forward { my $c = shift; $c->dispatcher->forward( $c, @_ ) }
259
260 =item $c->namespace
261
262 Accessor to the namespace of the current action
263
264 =item $c->path_to(@path)
265
266 Merges C<@path> with $c->config->{home} and returns a L<Path::Class> object.
267
268 For example:
269
270     $c->path_to( 'db', 'sqlite.db' );
271
272 =cut
273
274 sub path_to {
275     my ( $c, @path ) = @_;
276     my $path = dir( $c->config->{home}, @path );
277     if ( -d $path ) { return $path }
278     else { return file( $c->config->{home}, @path ) }
279 }
280
281 =item $c->setup
282
283 Setup.
284
285     $c->setup;
286
287 =cut
288
289 sub setup {
290     my ( $class, @arguments ) = @_;
291
292     unless ( $class->isa('Catalyst') ) {
293
294         Catalyst::Exception->throw(
295             message => qq/'$class' does not inherit from Catalyst/ );
296     }
297
298     if ( $class->arguments ) {
299         @arguments = ( @arguments, @{ $class->arguments } );
300     }
301
302     # Process options
303     my $flags = {};
304
305     foreach (@arguments) {
306
307         if (/^-Debug$/) {
308             $flags->{log} =
309               ( $flags->{log} ) ? 'debug,' . $flags->{log} : 'debug';
310         }
311         elsif (/^-(\w+)=?(.*)$/) {
312             $flags->{ lc $1 } = $2;
313         }
314         else {
315             push @{ $flags->{plugins} }, $_;
316         }
317     }
318
319     $class->setup_log( delete $flags->{log} );
320     $class->setup_plugins( delete $flags->{plugins} );
321     $class->setup_dispatcher( delete $flags->{dispatcher} );
322     $class->setup_engine( delete $flags->{engine} );
323     $class->setup_home( delete $flags->{home} );
324
325     for my $flag ( sort keys %{$flags} ) {
326
327         if ( my $code = $class->can( 'setup_' . $flag ) ) {
328             &$code( $class, delete $flags->{$flag} );
329         }
330         else {
331             $class->log->warn(qq/Unknown flag "$flag"/);
332         }
333     }
334
335     $class->log->warn( "You are running an old helper script! "
336           . "Please update your scripts by regenerating the "
337           . "application and copying over the new scripts." )
338       if ( $ENV{CATALYST_SCRIPT_GEN}
339         && ( $ENV{CATALYST_SCRIPT_GEN} < $Catalyst::CATALYST_SCRIPT_GEN ) );
340
341     if ( $class->debug ) {
342
343         my @plugins = ();
344
345         {
346             no strict 'refs';
347             @plugins = grep { /^Catalyst::Plugin/ } @{"$class\::ISA"};
348         }
349
350         if (@plugins) {
351             my $t = Text::ASCIITable->new;
352             $t->setOptions( 'hide_HeadRow',  1 );
353             $t->setOptions( 'hide_HeadLine', 1 );
354             $t->setCols('Class');
355             $t->setColWidth( 'Class', 75, 1 );
356             $t->addRow($_) for @plugins;
357             $class->log->debug( "Loaded plugins:\n" . $t->draw );
358         }
359
360         my $dispatcher = $class->dispatcher;
361         my $engine     = $class->engine;
362         my $home       = $class->config->{home};
363
364         $class->log->debug(qq/Loaded dispatcher "$dispatcher"/);
365         $class->log->debug(qq/Loaded engine "$engine"/);
366
367         $home
368           ? ( -d $home )
369           ? $class->log->debug(qq/Found home "$home"/)
370           : $class->log->debug(qq/Home "$home" doesn't exist/)
371           : $class->log->debug(q/Couldn't find home/);
372     }
373
374     # Call plugins setup
375     {
376         no warnings qw/redefine/;
377         local *setup = sub { };
378         $class->setup;
379     }
380
381     # Initialize our data structure
382     $class->components( {} );
383
384     $class->setup_components;
385
386     if ( $class->debug ) {
387         my $t = Text::ASCIITable->new;
388         $t->setOptions( 'hide_HeadRow',  1 );
389         $t->setOptions( 'hide_HeadLine', 1 );
390         $t->setCols('Class');
391         $t->setColWidth( 'Class', 75, 1 );
392         $t->addRow($_) for sort keys %{ $class->components };
393         $class->log->debug( "Loaded components:\n" . $t->draw )
394           if ( @{ $t->{tbl_rows} } );
395     }
396
397     # Add our self to components, since we are also a component
398     $class->components->{$class} = $class;
399
400     $class->setup_actions;
401
402     if ( $class->debug ) {
403         my $name = $class->config->{name} || 'Application';
404         $class->log->info("$name powered by Catalyst $Catalyst::VERSION");
405     }
406     $class->log->_flush() if $class->log->can('_flush');
407 }
408
409 =item $c->uri_for($path,[@args])
410
411 Merges path with $c->request->base for absolute uri's and with
412 $c->request->match for relative uri's, then returns a normalized
413 L<URI> object. If any args are passed, they are added at the end
414 of the path.
415
416 =cut
417
418 sub uri_for {
419     my ( $c, $path, @args ) = @_;
420     my $base     = $c->request->base->clone;
421     my $basepath = $base->path;
422     $basepath =~ s/\/$//;
423     $basepath .= '/';
424     my $match = $c->request->match;
425
426     # massage match, empty if absolute path
427     $match =~ s/^\///;
428     $match .= '/' if $match;
429     $match = '' if $path =~ /^\//;
430     $path =~ s/^\///;
431
432     # join args with '/', or a blank string
433     my $args = ( scalar @args ? '/' . join( '/', @args ) : '' );
434     return URI->new_abs( URI->new_abs( "$path$args", "$basepath$match" ),
435         $base )->canonical;
436 }
437
438 =item $c->error
439
440 =item $c->error($error, ...)
441
442 =item $c->error($arrayref)
443
444 Returns an arrayref containing error messages.
445
446     my @error = @{ $c->error };
447
448 Add a new error.
449
450     $c->error('Something bad happened');
451
452 Clean errors.
453
454     $c->error(0);
455
456 =cut
457
458 sub error {
459     my $c = shift;
460     if ( $_[0] ) {
461         my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
462         push @{ $c->{error} }, @$error;
463     }
464     elsif ( defined $_[0] ) { $c->{error} = undef }
465     return $c->{error} || [];
466 }
467
468 =item $c->engine
469
470 Contains the engine instance.
471 Stringifies to the class.
472
473 =item $c->log
474
475 Contains the logging object.  Unless it is already set Catalyst sets this up with a
476 C<Catalyst::Log> object.  To use your own log class:
477
478     $c->log( MyLogger->new );
479     $c->log->info("now logging with my own logger!");
480
481 Your log class should implement the methods described in the C<Catalyst::Log>
482 man page.
483
484 =item $c->plugin( $name, $class, @args )
485
486 Instant plugins for Catalyst.
487 Classdata accessor/mutator will be created, class loaded and instantiated.
488
489     MyApp->plugin( 'prototype', 'HTML::Prototype' );
490
491     $c->prototype->define_javascript_functions;
492
493 =cut
494
495 sub plugin {
496     my ( $class, $name, $plugin, @args ) = @_;
497     $plugin->require;
498
499     if ( my $error = $UNIVERSAL::require::ERROR ) {
500         Catalyst::Exception->throw(
501             message => qq/Couldn't load instant plugin "$plugin", "$error"/ );
502     }
503
504     eval { $plugin->import };
505     $class->mk_classdata($name);
506     my $obj;
507     eval { $obj = $plugin->new(@args) };
508
509     if ($@) {
510         Catalyst::Exception->throw( message =>
511               qq/Couldn't instantiate instant plugin "$plugin", "$@"/ );
512     }
513
514     $class->$name($obj);
515     $class->log->debug(qq/Initialized instant plugin "$plugin" as "$name"/)
516       if $class->debug;
517 }
518
519 =item $c->request
520
521 =item $c->req
522
523 Returns a C<Catalyst::Request> object.
524
525     my $req = $c->req;
526
527 =item $c->response
528
529 =item $c->res
530
531 Returns a C<Catalyst::Response> object.
532
533     my $res = $c->res;
534
535 =item $c->state
536
537 Contains the return value of the last executed action.
538
539 =item $c->stash
540
541 Returns a hashref containing all your data.
542
543     print $c->stash->{foo};
544
545 Keys may be set in the stash by assigning to the hash reference, or by passing
546 either a single hash reference or a list of key/value pairs as arguments.
547
548 For example:
549
550     $c->stash->{foo} ||= 'yada';
551     $c->stash( { moose => 'majestic', qux => 0 } );
552     $c->stash( bar => 1, gorch => 2 );
553
554 =cut
555
556 sub stash {
557     my $c = shift;
558     if (@_) {
559         my $stash = @_ > 1 ? {@_} : $_[0];
560         while ( my ( $key, $val ) = each %$stash ) {
561             $c->{stash}->{$key} = $val;
562         }
563     }
564     return $c->{stash};
565 }
566
567 =item $c->welcome_message
568
569 Returns the Catalyst welcome HTML page.
570
571 =cut
572
573 sub welcome_message {
574     my $c      = shift;
575     my $name   = $c->config->{name};
576     my $logo   = $c->uri_for('/static/images/catalyst_logo.png');
577     my $prefix = Catalyst::Utils::appprefix( ref $c );
578     return <<"EOF";
579 <html>
580     <head>
581         <title>$name on Catalyst $VERSION</title>
582         <style type="text/css">
583             body {
584                 text-align: center;
585                 padding-left: 50%;
586                 color: #000;
587                 background-color: #eee;
588             }
589             div#content {
590                 width: 640px;
591                 margin-left: -320px;
592                 margin-top: 10px;
593                 margin-bottom: 10px;
594                 text-align: left;
595                 background-color: #ccc;
596                 border: 1px solid #aaa;
597                 -moz-border-radius: 10px;
598             }
599             p, h1, h2 {
600                 margin-left: 20px;
601                 margin-right: 20px;
602                 font-family: verdana, tahoma, sans-serif;
603             }
604             a {
605                 font-family: verdana, tahoma, sans-serif;
606             }
607             :link, :visited {
608                     text-decoration: none;
609                     color: #b00;
610                     border-bottom: 1px dotted #bbb;
611             }
612             :link:hover, :visited:hover {
613                     color: #555;
614             }
615             div#topbar {
616                 margin: 0px;
617             }
618             pre {
619                 margin: 10px;
620                 padding: 8px;
621             }
622             div#answers {
623                 padding: 8px;
624                 margin: 10px;
625                 background-color: #fff;
626                 border: 1px solid #aaa;
627                 -moz-border-radius: 10px;
628             }
629             h1 {
630                 font-size: 0.9em;
631                 font-weight: normal;
632                 text-align: center;
633             }
634             h2 {
635                 font-size: 1.0em;
636             }
637             p {
638                 font-size: 0.9em;
639             }
640             p img {
641                 float: right;
642                 margin-left: 10px;
643             }
644             b#appname {
645                 font-size: 1.6em;
646             }
647         </style>
648     </head>
649     <body>
650         <div id="content">
651             <div id="topbar">
652                 <h1><b id="appname">$name</b> on <a href="http://catalyst.perl.org">Catalyst</a>
653                     $VERSION</h1>
654              </div>
655              <div id="answers">
656                  <p>
657                  <img src="$logo"/>
658                  </p>
659                  <p>Welcome to the wonderful world of Catalyst.
660                     This <a href="http://en.wikipedia.org/wiki/MVC">MVC</a>
661                     framework will make web development something you had
662                     never expected it to be: Fun, rewarding and quick.</p>
663                  <h2>What to do now?</h2>
664                  <p>That really depends  on what <b>you</b> want to do.
665                     We do, however, provide you with a few starting points.</p>
666                  <p>If you want to jump right into web development with Catalyst
667                     you might want to check out the documentation.</p>
668                  <pre><code>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst/lib/Catalyst/Manual/Intro.pod">Catalyst::Manual::Intro</a>
669 perldoc <a href="http://cpansearch.perl.org/dist/Catalyst/lib/Catalyst/Manual.pod">Catalyst::Manual</a></code></pre>
670                  <h2>What to do next?</h2>
671                  <p>Next it's time to write an actual application. Use the
672                     helper scripts to generate <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AController%3A%3A&mode=all">controllers</a>,
673                     <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AModel%3A%3A&mode=all">models</a> and
674                     <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AView%3A%3A&mode=all">views</a>,
675                     they can save you a lot of work.</p>
676                     <pre><code>script/${prefix}_create.pl -help</code></pre>
677                     <p>Also, be sure to check out the vast and growing
678                     collection of <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3APlugin%3A%3A&mode=all">plugins for Catalyst on CPAN</a>,
679                     you are likely to find what you need there.
680                     </p>
681
682                  <h2>Need help?</h2>
683                  <p>Catalyst has a very active community. Here are the main places to
684                     get in touch with us.</p>
685                  <ul>
686                      <li>
687                          <a href="http://dev.catalyst.perl.org">Wiki</a>
688                      </li>
689                      <li>
690                          <a href="http://lists.rawmode.org/mailman/listinfo/catalyst">Mailing-List</a>
691                      </li>
692                      <li>
693                          <a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
694                      </li>
695                  </ul>
696                  <h2>In conclusion</h2>
697                  <p>The Catalyst team hopes you will enjoy using Catalyst as much 
698                     as we enjoyed making it. Please contact us if you have ideas
699                     for improvement or other feedback.</p>
700              </div>
701          </div>
702     </body>
703 </html>
704 EOF
705 }
706
707 =back
708
709 =head1 INTERNAL METHODS
710
711 =over 4
712
713 =item $c->benchmark($coderef)
714
715 Takes a coderef with arguments and returns elapsed time as float.
716
717     my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
718     $c->log->info( sprintf "Processing took %f seconds", $elapsed );
719
720 =cut
721
722 sub benchmark {
723     my $c       = shift;
724     my $code    = shift;
725     my $time    = [gettimeofday];
726     my @return  = &$code(@_);
727     my $elapsed = tv_interval $time;
728     return wantarray ? ( $elapsed, @return ) : $elapsed;
729 }
730
731 =item $c->components
732
733 Contains the components.
734
735 =item $c->counter
736
737 Returns a hashref containing coderefs and execution counts.
738 (Needed for deep recursion detection) 
739
740 =item $c->depth
741
742 Returns the actual forward depth.
743
744 =item $c->dispatch
745
746 Dispatch request to actions.
747
748 =cut
749
750 sub dispatch { my $c = shift; $c->dispatcher->dispatch( $c, @_ ) }
751
752 =item $c->execute($class, $coderef)
753
754 Execute a coderef in given class and catch exceptions.
755 Errors are available via $c->error.
756
757 =cut
758
759 sub execute {
760     my ( $c, $class, $code ) = @_;
761     $class = $c->components->{$class} || $class;
762     $c->state(0);
763     my $callsub = ( caller(1) )[3];
764
765     my $action = '';
766     if ( $c->debug ) {
767         $action = "$code";
768         $action = "/$action" unless $action =~ /\-\>/;
769         $c->counter->{"$code"}++;
770
771         if ( $c->counter->{"$code"} > $RECURSION ) {
772             my $error = qq/Deep recursion detected in "$action"/;
773             $c->log->error($error);
774             $c->error($error);
775             $c->state(0);
776             return $c->state;
777         }
778
779         $action = "-> $action" if $callsub =~ /forward$/;
780     }
781     $c->{depth}++;
782     eval {
783         if ( $c->debug )
784         {
785             my ( $elapsed, @state ) =
786               $c->benchmark( $code, $class, $c, @{ $c->req->args } );
787             push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
788             $c->state(@state);
789         }
790         else {
791             $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 );
792         }
793     };
794     $c->{depth}--;
795
796     if ( my $error = $@ ) {
797
798         if ( $error eq $DETACH ) { die $DETACH if $c->{depth} > 1 }
799         else {
800             unless ( ref $error ) {
801                 chomp $error;
802                 $error = qq/Caught exception "$error"/;
803             }
804
805             $c->log->error($error);
806             $c->error($error);
807             $c->state(0);
808         }
809     }
810     return $c->state;
811 }
812
813 =item $c->finalize
814
815 Finalize request.
816
817 =cut
818
819 sub finalize {
820     my $c = shift;
821
822     $c->finalize_uploads;
823
824     # Error
825     if ( $#{ $c->error } >= 0 ) {
826         $c->finalize_error;
827     }
828
829     $c->finalize_headers;
830
831     # HEAD request
832     if ( $c->request->method eq 'HEAD' ) {
833         $c->response->body('');
834     }
835
836     $c->finalize_body;
837
838     return $c->response->status;
839 }
840
841 =item $c->finalize_body
842
843 Finalize body.
844
845 =cut
846
847 sub finalize_body { my $c = shift; $c->engine->finalize_body( $c, @_ ) }
848
849 =item $c->finalize_cookies
850
851 Finalize cookies.
852
853 =cut
854
855 sub finalize_cookies { my $c = shift; $c->engine->finalize_cookies( $c, @_ ) }
856
857 =item $c->finalize_error
858
859 Finalize error.
860
861 =cut
862
863 sub finalize_error { my $c = shift; $c->engine->finalize_error( $c, @_ ) }
864
865 =item $c->finalize_headers
866
867 Finalize headers.
868
869 =cut
870
871 sub finalize_headers {
872     my $c = shift;
873
874     # Check if we already finalized headers
875     return if $c->response->{_finalized_headers};
876
877     # Handle redirects
878     if ( my $location = $c->response->redirect ) {
879         $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
880         $c->response->header( Location => $location );
881     }
882
883     # Content-Length
884     if ( $c->response->body && !$c->response->content_length ) {
885         $c->response->content_length( bytes::length( $c->response->body ) );
886     }
887
888     # Errors
889     if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
890         $c->response->headers->remove_header("Content-Length");
891         $c->response->body('');
892     }
893
894     $c->finalize_cookies;
895
896     $c->engine->finalize_headers( $c, @_ );
897
898     # Done
899     $c->response->{_finalized_headers} = 1;
900 }
901
902 =item $c->finalize_output
903
904 An alias for finalize_body.
905
906 =item $c->finalize_read
907
908 Finalize the input after reading is complete.
909
910 =cut
911
912 sub finalize_read { my $c = shift; $c->engine->finalize_read( $c, @_ ) }
913
914 =item $c->finalize_uploads
915
916 Finalize uploads.  Cleans up any temporary files.
917
918 =cut
919
920 sub finalize_uploads { my $c = shift; $c->engine->finalize_uploads( $c, @_ ) }
921
922 =item $c->get_action( $action, $namespace, $inherit )
923
924 Get an action in a given namespace.
925
926 =cut
927
928 sub get_action { my $c = shift; $c->dispatcher->get_action( $c, @_ ) }
929
930 =item handle_request( $class, @arguments )
931
932 Handles the request.
933
934 =cut
935
936 sub handle_request {
937     my ( $class, @arguments ) = @_;
938
939     # Always expect worst case!
940     my $status = -1;
941     eval {
942         my @stats = ();
943
944         my $handler = sub {
945             my $c = $class->prepare(@arguments);
946             $c->{stats} = \@stats;
947             $c->dispatch;
948             return $c->finalize;
949         };
950
951         if ( $class->debug ) {
952             my $elapsed;
953             ( $elapsed, $status ) = $class->benchmark($handler);
954             $elapsed = sprintf '%f', $elapsed;
955             my $av = sprintf '%.3f',
956               ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
957             my $t = Text::ASCIITable->new;
958             $t->setCols( 'Action', 'Time' );
959             $t->setColWidth( 'Action', 64, 1 );
960             $t->setColWidth( 'Time',   9,  1 );
961
962             for my $stat (@stats) { $t->addRow( $stat->[0], $stat->[1] ) }
963             $class->log->info(
964                 "Request took ${elapsed}s ($av/s)\n" . $t->draw );
965         }
966         else { $status = &$handler }
967
968     };
969
970     if ( my $error = $@ ) {
971         chomp $error;
972         $class->log->error(qq/Caught exception in engine "$error"/);
973     }
974
975     $COUNT++;
976     $class->log->_flush() if $class->log->can('_flush');
977     return $status;
978 }
979
980 =item $c->prepare(@arguments)
981
982 Turns the engine-specific request( Apache, CGI ... )
983 into a Catalyst context .
984
985 =cut
986
987 sub prepare {
988     my ( $class, @arguments ) = @_;
989
990     my $c = bless {
991         counter => {},
992         depth   => 0,
993         request => Catalyst::Request->new(
994             {
995                 arguments        => [],
996                 body_parameters  => {},
997                 cookies          => {},
998                 headers          => HTTP::Headers->new,
999                 parameters       => {},
1000                 query_parameters => {},
1001                 secure           => 0,
1002                 snippets         => [],
1003                 uploads          => {}
1004             }
1005         ),
1006         response => Catalyst::Response->new(
1007             {
1008                 body    => '',
1009                 cookies => {},
1010                 headers => HTTP::Headers->new(),
1011                 status  => 200
1012             }
1013         ),
1014         stash => {},
1015         state => 0
1016     }, $class;
1017
1018     # For on-demand data
1019     $c->request->{_context}  = $c;
1020     $c->response->{_context} = $c;
1021     weaken( $c->request->{_context} );
1022     weaken( $c->response->{_context} );
1023
1024     if ( $c->debug ) {
1025         my $secs = time - $START || 1;
1026         my $av = sprintf '%.3f', $COUNT / $secs;
1027         $c->log->debug('**********************************');
1028         $c->log->debug("* Request $COUNT ($av/s) [$$]");
1029         $c->log->debug('**********************************');
1030         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
1031     }
1032
1033     $c->prepare_request(@arguments);
1034     $c->prepare_connection;
1035     $c->prepare_query_parameters;
1036     $c->prepare_headers;
1037     $c->prepare_cookies;
1038     $c->prepare_path;
1039
1040     # On-demand parsing
1041     $c->prepare_body unless $c->config->{parse_on_demand};
1042
1043     $c->prepare_action;
1044     my $method  = $c->req->method  || '';
1045     my $path    = $c->req->path    || '';
1046     my $address = $c->req->address || '';
1047
1048     $c->log->debug(qq/"$method" request for "$path" from $address/)
1049       if $c->debug;
1050
1051     return $c;
1052 }
1053
1054 =item $c->prepare_action
1055
1056 Prepare action.
1057
1058 =cut
1059
1060 sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
1061
1062 =item $c->prepare_body
1063
1064 Prepare message body.
1065
1066 =cut
1067
1068 sub prepare_body {
1069     my $c = shift;
1070
1071     # Do we run for the first time?
1072     return if defined $c->request->{_body};
1073
1074     # Initialize on-demand data
1075     $c->engine->prepare_body( $c, @_ );
1076     $c->prepare_parameters;
1077     $c->prepare_uploads;
1078
1079     if ( $c->debug && keys %{ $c->req->body_parameters } ) {
1080         my $t = Text::ASCIITable->new;
1081         $t->setCols( 'Key', 'Value' );
1082         $t->setColWidth( 'Key',   37, 1 );
1083         $t->setColWidth( 'Value', 36, 1 );
1084         $t->alignCol( 'Value', 'right' );
1085         for my $key ( sort keys %{ $c->req->body_parameters } ) {
1086             my $param = $c->req->body_parameters->{$key};
1087             my $value = defined($param) ? $param : '';
1088             $t->addRow( $key,
1089                 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1090         }
1091         $c->log->debug( "Body Parameters are:\n" . $t->draw );
1092     }
1093 }
1094
1095 =item $c->prepare_body_chunk( $chunk )
1096
1097 Prepare a chunk of data before sending it to HTTP::Body.
1098
1099 =cut
1100
1101 sub prepare_body_chunk {
1102     my $c = shift;
1103     $c->engine->prepare_body_chunk( $c, @_ );
1104 }
1105
1106 =item $c->prepare_body_parameters
1107
1108 Prepare body parameters.
1109
1110 =cut
1111
1112 sub prepare_body_parameters {
1113     my $c = shift;
1114     $c->engine->prepare_body_parameters( $c, @_ );
1115 }
1116
1117 =item $c->prepare_connection
1118
1119 Prepare connection.
1120
1121 =cut
1122
1123 sub prepare_connection {
1124     my $c = shift;
1125     $c->engine->prepare_connection( $c, @_ );
1126 }
1127
1128 =item $c->prepare_cookies
1129
1130 Prepare cookies.
1131
1132 =cut
1133
1134 sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
1135
1136 =item $c->prepare_headers
1137
1138 Prepare headers.
1139
1140 =cut
1141
1142 sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
1143
1144 =item $c->prepare_parameters
1145
1146 Prepare parameters.
1147
1148 =cut
1149
1150 sub prepare_parameters {
1151     my $c = shift;
1152     $c->prepare_body_parameters;
1153     $c->engine->prepare_parameters( $c, @_ );
1154 }
1155
1156 =item $c->prepare_path
1157
1158 Prepare path and base.
1159
1160 =cut
1161
1162 sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
1163
1164 =item $c->prepare_query_parameters
1165
1166 Prepare query parameters.
1167
1168 =cut
1169
1170 sub prepare_query_parameters {
1171     my $c = shift;
1172
1173     $c->engine->prepare_query_parameters( $c, @_ );
1174
1175     if ( $c->debug && keys %{ $c->request->query_parameters } ) {
1176         my $t = Text::ASCIITable->new;
1177         $t->setCols( 'Key', 'Value' );
1178         $t->setColWidth( 'Key',   37, 1 );
1179         $t->setColWidth( 'Value', 36, 1 );
1180         $t->alignCol( 'Value', 'right' );
1181         for my $key ( sort keys %{ $c->req->query_parameters } ) {
1182             my $param = $c->req->query_parameters->{$key};
1183             my $value = defined($param) ? $param : '';
1184             $t->addRow( $key,
1185                 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1186         }
1187         $c->log->debug( "Query Parameters are:\n" . $t->draw );
1188     }
1189 }
1190
1191 =item $c->prepare_read
1192
1193 Prepare the input for reading.
1194
1195 =cut
1196
1197 sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
1198
1199 =item $c->prepare_request
1200
1201 Prepare the engine request.
1202
1203 =cut
1204
1205 sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
1206
1207 =item $c->prepare_uploads
1208
1209 Prepare uploads.
1210
1211 =cut
1212
1213 sub prepare_uploads {
1214     my $c = shift;
1215
1216     $c->engine->prepare_uploads( $c, @_ );
1217
1218     if ( $c->debug && keys %{ $c->request->uploads } ) {
1219         my $t = Text::ASCIITable->new;
1220         $t->setCols( 'Key', 'Filename', 'Type', 'Size' );
1221         $t->setColWidth( 'Key',      12, 1 );
1222         $t->setColWidth( 'Filename', 28, 1 );
1223         $t->setColWidth( 'Type',     18, 1 );
1224         $t->setColWidth( 'Size',     9,  1 );
1225         $t->alignCol( 'Size', 'left' );
1226         for my $key ( sort keys %{ $c->request->uploads } ) {
1227             my $upload = $c->request->uploads->{$key};
1228             for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
1229                 $t->addRow( $key, $u->filename, $u->type, $u->size );
1230             }
1231         }
1232         $c->log->debug( "File Uploads are:\n" . $t->draw );
1233     }
1234 }
1235
1236 =item $c->prepare_write
1237
1238 Prepare the output for writing.
1239
1240 =cut
1241
1242 sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
1243
1244 =item $c->read( [$maxlength] )
1245
1246 Read a chunk of data from the request body.  This method is designed to be
1247 used in a while loop, reading $maxlength bytes on every call.  $maxlength
1248 defaults to the size of the request if not specified.
1249
1250 You have to set MyApp->config->{parse_on_demand} to use this directly.
1251
1252 =cut
1253
1254 sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
1255
1256 =item $c->run
1257
1258 Starts the engine.
1259
1260 =cut
1261
1262 sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
1263
1264 =item $c->set_action( $action, $code, $namespace, $attrs )
1265
1266 Set an action in a given namespace.
1267
1268 =cut
1269
1270 sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
1271
1272 =item $c->setup_actions($component)
1273
1274 Setup actions for a component.
1275
1276 =cut
1277
1278 sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
1279
1280 =item $c->setup_components
1281
1282 Setup components.
1283
1284 =cut
1285
1286 sub setup_components {
1287     my $class = shift;
1288
1289     my $callback = sub {
1290         my ( $component, $context ) = @_;
1291
1292         unless ( $component->isa('Catalyst::Base') ) {
1293             return $component;
1294         }
1295
1296         my $suffix = Catalyst::Utils::class2classsuffix($component);
1297         my $config = $class->config->{$suffix} || {};
1298
1299         my $instance;
1300
1301         eval { $instance = $component->new( $context, $config ); };
1302
1303         if ( my $error = $@ ) {
1304
1305             chomp $error;
1306
1307             Catalyst::Exception->throw( message =>
1308                   qq/Couldn't instantiate component "$component", "$error"/ );
1309         }
1310
1311         Catalyst::Exception->throw( message =>
1312 qq/Couldn't instantiate component "$component", "new() didn't return a object"/
1313           )
1314           unless ref $instance;
1315         return $instance;
1316     };
1317
1318     eval {
1319         Module::Pluggable::Fast->import(
1320             name   => '_catalyst_components',
1321             search => [
1322                 "$class\::Controller", "$class\::C",
1323                 "$class\::Model",      "$class\::M",
1324                 "$class\::View",       "$class\::V"
1325             ],
1326             callback => $callback
1327         );
1328     };
1329
1330     if ( my $error = $@ ) {
1331
1332         chomp $error;
1333
1334         Catalyst::Exception->throw(
1335             message => qq/Couldn't load components "$error"/ );
1336     }
1337
1338     for my $component ( $class->_catalyst_components($class) ) {
1339         $class->components->{ ref $component || $component } = $component;
1340     }
1341 }
1342
1343 =item $c->setup_dispatcher
1344
1345 =cut
1346
1347 sub setup_dispatcher {
1348     my ( $class, $dispatcher ) = @_;
1349
1350     if ($dispatcher) {
1351         $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
1352     }
1353
1354     if ( $ENV{CATALYST_DISPATCHER} ) {
1355         $dispatcher = 'Catalyst::Dispatcher::' . $ENV{CATALYST_DISPATCHER};
1356     }
1357
1358     if ( $ENV{ uc($class) . '_DISPATCHER' } ) {
1359         $dispatcher =
1360           'Catalyst::Dispatcher::' . $ENV{ uc($class) . '_DISPATCHER' };
1361     }
1362
1363     unless ($dispatcher) {
1364         $dispatcher = 'Catalyst::Dispatcher';
1365     }
1366
1367     $dispatcher->require;
1368
1369     if ($@) {
1370         Catalyst::Exception->throw(
1371             message => qq/Couldn't load dispatcher "$dispatcher", "$@"/ );
1372     }
1373
1374     # dispatcher instance
1375     $class->dispatcher( $dispatcher->new );
1376 }
1377
1378 =item $c->setup_engine
1379
1380 =cut
1381
1382 sub setup_engine {
1383     my ( $class, $engine ) = @_;
1384
1385     if ($engine) {
1386         $engine = 'Catalyst::Engine::' . $engine;
1387     }
1388
1389     if ( $ENV{CATALYST_ENGINE} ) {
1390         $engine = 'Catalyst::Engine::' . $ENV{CATALYST_ENGINE};
1391     }
1392
1393     if ( $ENV{ uc($class) . '_ENGINE' } ) {
1394         $engine = 'Catalyst::Engine::' . $ENV{ uc($class) . '_ENGINE' };
1395     }
1396
1397     if ( !$engine && $ENV{MOD_PERL} ) {
1398
1399         # create the apache method
1400         {
1401             no strict 'refs';
1402             *{"$class\::apache"} = sub { shift->engine->apache };
1403         }
1404
1405         my ( $software, $version ) =
1406           $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
1407
1408         $version =~ s/_//g;
1409         $version =~ s/(\.[^.]+)\./$1/g;
1410
1411         if ( $software eq 'mod_perl' ) {
1412
1413             if ( $version >= 1.99922 ) {
1414                 $engine = 'Catalyst::Engine::Apache2::MP20';
1415             }
1416
1417             elsif ( $version >= 1.9901 ) {
1418                 $engine = 'Catalyst::Engine::Apache2::MP19';
1419             }
1420
1421             elsif ( $version >= 1.24 ) {
1422                 $engine = 'Catalyst::Engine::Apache::MP13';
1423             }
1424
1425             else {
1426                 Catalyst::Exception->throw( message =>
1427                       qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
1428             }
1429
1430             # install the correct mod_perl handler
1431             if ( $version >= 1.9901 ) {
1432                 *handler = sub  : method {
1433                     shift->handle_request(@_);
1434                 };
1435             }
1436             else {
1437                 *handler = sub ($$) { shift->handle_request(@_) };
1438             }
1439
1440         }
1441
1442         elsif ( $software eq 'Zeus-Perl' ) {
1443             $engine = 'Catalyst::Engine::Zeus';
1444         }
1445
1446         else {
1447             Catalyst::Exception->throw(
1448                 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
1449         }
1450     }
1451
1452     unless ($engine) {
1453         $engine = 'Catalyst::Engine::CGI';
1454     }
1455
1456     $engine->require;
1457
1458     if ($@) {
1459         Catalyst::Exception->throw( message =>
1460 qq/Couldn't load engine "$engine" (maybe you forgot to install it?), "$@"/
1461         );
1462     }
1463
1464     # engine instance
1465     $class->engine( $engine->new );
1466 }
1467
1468 =item $c->setup_home
1469
1470 =cut
1471
1472 sub setup_home {
1473     my ( $class, $home ) = @_;
1474
1475     if ( $ENV{CATALYST_HOME} ) {
1476         $home = $ENV{CATALYST_HOME};
1477     }
1478
1479     if ( $ENV{ uc($class) . '_HOME' } ) {
1480         $home = $ENV{ uc($class) . '_HOME' };
1481     }
1482
1483     unless ($home) {
1484         $home = Catalyst::Utils::home($class);
1485     }
1486
1487     if ($home) {
1488         $class->config->{home} ||= $home;
1489         $class->config->{root} ||= dir($home)->subdir('root');
1490     }
1491 }
1492
1493 =item $c->setup_log
1494
1495 =cut
1496
1497 sub setup_log {
1498     my ( $class, $debug ) = @_;
1499
1500     unless ( $class->log ) {
1501         $class->log( Catalyst::Log->new );
1502     }
1503
1504     if ( $ENV{CATALYST_DEBUG} || $ENV{ uc($class) . '_DEBUG' } || $debug ) {
1505         no strict 'refs';
1506         *{"$class\::debug"} = sub { 1 };
1507         $class->log->debug('Debug messages enabled');
1508     }
1509 }
1510
1511 =item $c->setup_plugins
1512
1513 =cut
1514
1515 sub setup_plugins {
1516     my ( $class, $plugins ) = @_;
1517
1518     $plugins ||= [];
1519     for my $plugin ( reverse @$plugins ) {
1520
1521         $plugin = "Catalyst::Plugin::$plugin";
1522
1523         $plugin->require;
1524
1525         if ($@) {
1526             Catalyst::Exception->throw(
1527                 message => qq/Couldn't load plugin "$plugin", "$@"/ );
1528         }
1529
1530         {
1531             no strict 'refs';
1532             unshift @{"$class\::ISA"}, $plugin;
1533         }
1534     }
1535 }
1536
1537 =item $c->write( $data )
1538
1539 Writes $data to the output stream.  When using this method directly, you will
1540 need to manually set the Content-Length header to the length of your output
1541 data, if known.
1542
1543 =cut
1544
1545 sub write {
1546     my $c = shift;
1547
1548     # Finalize headers if someone manually writes output
1549     $c->finalize_headers;
1550
1551     return $c->engine->write( $c, @_ );
1552 }
1553
1554 =item version
1555
1556 Returns the Catalyst version number. mostly useful for powered by messages
1557 in template systems.
1558
1559 =cut
1560
1561 sub version { return $Catalyst::VERSION }
1562
1563 =back
1564
1565 =head1 CASE SENSITIVITY
1566
1567 By default Catalyst is not case sensitive, so C<MyApp::C::FOO::Bar> becomes
1568 C</foo/bar>.
1569
1570 But you can activate case sensitivity with a config parameter.
1571
1572     MyApp->config->{case_sensitive} = 1;
1573
1574 So C<MyApp::C::Foo::Bar> becomes C</Foo/Bar>.
1575
1576 =head1 ON-DEMAND PARSER
1577
1578 The request body is usually parsed at the beginning of a request,
1579 but if you want to handle input yourself or speed things up a bit
1580 you can enable on-demand parsing with a config parameter.
1581
1582     MyApp->config->{parse_on_demand} = 1;
1583     
1584 =head1 PROXY SUPPORT
1585
1586 Many production servers operate using the common double-server approach, with
1587 a lightweight frontend web server passing requests to a larger backend
1588 server.  An application running on the backend server must deal with two
1589 problems: the remote user always appears to be '127.0.0.1' and the server's
1590 hostname will appear to be 'localhost' regardless of the virtual host the
1591 user connected through.
1592
1593 Catalyst will automatically detect this situation when you are running both
1594 the frontend and backend servers on the same machine.  The following changes
1595 are made to the request.
1596
1597     $c->req->address is set to the user's real IP address, as read from the
1598     HTTP_X_FORWARDED_FOR header.
1599     
1600     The host value for $c->req->base and $c->req->uri is set to the real host,
1601     as read from the HTTP_X_FORWARDED_HOST header.
1602
1603 Obviously, your web server must support these 2 headers for this to work.
1604
1605 In a more complex server farm environment where you may have your frontend
1606 proxy server(s) on different machines, you will need to set a configuration
1607 option to tell Catalyst to read the proxied data from the headers.
1608
1609     MyApp->config->{using_frontend_proxy} = 1;
1610     
1611 If you do not wish to use the proxy support at all, you may set:
1612
1613     MyApp->config->{ignore_frontend_proxy} = 1;
1614
1615 =head1 THREAD SAFETY
1616
1617 Catalyst has been tested under Apache 2's threading mpm_worker, mpm_winnt,
1618 and the standalone forking HTTP server on Windows.  We believe the Catalyst
1619 core to be thread-safe.
1620
1621 If you plan to operate in a threaded environment, remember that all other
1622 modules you are using must also be thread-safe.  Some modules, most notably
1623 DBD::SQLite, are not thread-safe.
1624
1625 =head1 SUPPORT
1626
1627 IRC:
1628
1629     Join #catalyst on irc.perl.org.
1630
1631 Mailing-Lists:
1632
1633     http://lists.rawmode.org/mailman/listinfo/catalyst
1634     http://lists.rawmode.org/mailman/listinfo/catalyst-dev
1635
1636 Web:
1637
1638     http://catalyst.perl.org
1639
1640 =head1 SEE ALSO
1641
1642 =over 4
1643
1644 =item L<Catalyst::Manual> - The Catalyst Manual
1645
1646 =item L<Catalyst::Engine> - Core Engine
1647
1648 =item L<Catalyst::Log> - The Log Class.
1649
1650 =item L<Catalyst::Request> - The Request Object
1651
1652 =item L<Catalyst::Response> - The Response Object
1653
1654 =item L<Catalyst::Test> - The test suite.
1655
1656 =back
1657
1658 =head1 CREDITS
1659
1660 Andy Grundman
1661
1662 Andy Wardley
1663
1664 Andreas Marienborg
1665
1666 Andrew Bramble
1667
1668 Andrew Ford
1669
1670 Andrew Ruthven
1671
1672 Arthur Bergman
1673
1674 Autrijus Tang
1675
1676 Christian Hansen
1677
1678 Christopher Hicks
1679
1680 Dan Sully
1681
1682 Danijel Milicevic
1683
1684 David Naughton
1685
1686 Gary Ashton Jones
1687
1688 Geoff Richards
1689
1690 Jesse Sheidlower
1691
1692 Jesse Vincent
1693
1694 Jody Belka
1695
1696 Johan Lindstrom
1697
1698 Juan Camacho
1699
1700 Leon Brocard
1701
1702 Marcus Ramberg
1703
1704 Matt S Trout
1705
1706 Robert Sedlacek
1707
1708 Tatsuhiko Miyagawa
1709
1710 Ulf Edvinsson
1711
1712 Yuval Kogman
1713
1714 =head1 AUTHOR
1715
1716 Sebastian Riedel, C<sri@oook.de>
1717
1718 =head1 LICENSE
1719
1720 This library is free software, you can redistribute it and/or modify it under
1721 the same terms as Perl itself.
1722
1723 =cut
1724
1725 1;