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