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