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