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