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