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     return URI->new_abs( URI->new_abs( "$path$args", "$basepath$namespace" ),
 678         $base )->canonical;
 679 }
 680
 681 =head2 $c->welcome_message
 682
 683 Returns the Catalyst welcome HTML page.
 684
 685 =cut
 686
 687 sub welcome_message {
 688     my $c      = shift;
 689     my $name   = $c->config->{name};
 690     my $logo   = $c->uri_for('/static/images/catalyst_logo.png');
 691     my $prefix = Catalyst::Utils::appprefix( ref $c );
 692     $c->response->content_type('text/html; charset=utf-8');
 693     return <<"EOF";
 694 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 695     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 696 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
 697     <head>
 698         <meta http-equiv="Content-Language" content="en" />
 699         <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
 700         <title>$name on Catalyst $VERSION</title>
 701         <style type="text/css">
 702             body {
 703                 color: #000;
 704                 background-color: #eee;
 705             }
 706             div#content {
 707                 width: 640px;
 708                 margin-left: auto;
 709                 margin-right: auto;
 710                 margin-top: 10px;
 711                 margin-bottom: 10px;
 712                 text-align: left;
 713                 background-color: #ccc;
 714                 border: 1px solid #aaa;
 715                 -moz-border-radius: 10px;
 716             }
 717             p, h1, h2 {
 718                 margin-left: 20px;
 719                 margin-right: 20px;
 720                 font-family: verdana, tahoma, sans-serif;
 721             }
 722             a {
 723                 font-family: verdana, tahoma, sans-serif;
 724             }
 725             :link, :visited {
 726                     text-decoration: none;
 727                     color: #b00;
 728                     border-bottom: 1px dotted #bbb;
 729             }
 730             :link:hover, :visited:hover {
 731                     color: #555;
 732             }
 733             div#topbar {
 734                 margin: 0px;
 735             }
 736             pre {
 737                 margin: 10px;
 738                 padding: 8px;
 739             }
 740             div#answers {
 741                 padding: 8px;
 742                 margin: 10px;
 743                 background-color: #fff;
 744                 border: 1px solid #aaa;
 745                 -moz-border-radius: 10px;
 746             }
 747             h1 {
 748                 font-size: 0.9em;
 749                 font-weight: normal;
 750                 text-align: center;
 751             }
 752             h2 {
 753                 font-size: 1.0em;
 754             }
 755             p {
 756                 font-size: 0.9em;
 757             }
 758             p img {
 759                 float: right;
 760                 margin-left: 10px;
 761             }
 762             span#appname {
 763                 font-weight: bold;
 764                 font-size: 1.6em;
 765             }
 766         </style>
 767     </head>
 768     <body>
 769         <div id="content">
 770             <div id="topbar">
 771                 <h1><span id="appname">$name</span> on <a href="http://catalyst.perl.org">Catalyst</a>
 772                     $VERSION</h1>
 773              </div>
 774              <div id="answers">
 775                  <p>
 776                  <img src="$logo" alt="Catalyst Logo" />
 777                  </p>
 778                  <p>Welcome to the wonderful world of Catalyst.
 779                     This <a href="http://en.wikipedia.org/wiki/MVC">MVC</a>
 780                     framework will make web development something you had
 781                     never expected it to be: Fun, rewarding and quick.</p>
 782                  <h2>What to do now?</h2>
 783                  <p>That really depends  on what <b>you</b> want to do.
 784                     We do, however, provide you with a few starting points.</p>
 785                  <p>If you want to jump right into web development with Catalyst
 786                     you might want to check out the documentation.</p>
 787                  <pre><code>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst/lib/Catalyst/Manual/Intro.pod">Catalyst::Manual::Intro</a>
 788 perldoc <a href="http://cpansearch.perl.org/dist/Catalyst/lib/Catalyst/Manual.pod">Catalyst::Manual</a></code></pre>
 789                  <h2>What to do next?</h2>
 790                  <p>Next it's time to write an actual application. Use the
 791                     helper scripts to generate <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AController%3A%3A&amp;mode=all">controllers</a>,
 792                     <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AModel%3A%3A&amp;mode=all">models</a> and
 793                     <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AView%3A%3A&amp;mode=all">views</a>,
 794                     they can save you a lot of work.</p>
 795                     <pre><code>script/${prefix}_create.pl -help</code></pre>
 796                     <p>Also, be sure to check out the vast and growing
 797                     collection of <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3APlugin%3A%3A&amp;mode=all">plugins for Catalyst on CPAN</a>,
 798                     you are likely to find what you need there.
 799                     </p>
 800
 801                  <h2>Need help?</h2>
 802                  <p>Catalyst has a very active community. Here are the main places to
 803                     get in touch with us.</p>
 804                  <ul>
 805                      <li>
 806                          <a href="http://dev.catalyst.perl.org">Wiki</a>
 807                      </li>
 808                      <li>
 809                          <a href="http://lists.rawmode.org/mailman/listinfo/catalyst">Mailing-List</a>
 810                      </li>
 811                      <li>
 812                          <a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
 813                      </li>
 814                  </ul>
 815                  <h2>In conclusion</h2>
 816                  <p>The Catalyst team hopes you will enjoy using Catalyst as much
 817                     as we enjoyed making it. Please contact us if you have ideas
 818                     for improvement or other feedback.</p>
 819              </div>
 820          </div>
 821     </body>
 822 </html>
 823 EOF
 824 }
 825
 826 =head1 INTERNAL METHODS
 827
 828 These methods are not meant to be used by end users.
 829
 830 =head2 $c->components
 831
 832 Returns a hash of components.
 833
 834 =head2 $c->context_class
 835
 836 Returns or sets the context class.
 837
 838 =head2 $c->counter
 839
 840 Returns a hashref containing coderefs and execution counts (needed for
 841 deep recursion detection).
 842
 843 =head2 $c->depth
 844
 845 Returns the number of actions on the current internal execution stack.
 846
 847 =head2 $c->dispatch
 848
 849 Dispatches a request to actions.
 850
 851 =cut
 852
 853 sub dispatch { my $c = shift; $c->dispatcher->dispatch( $c, @_ ) }
 854
 855 =head2 $c->dispatcher_class
 856
 857 Returns or sets the dispatcher class.
 858
 859 =head2 $c->dump_these
 860
 861 Returns a list of 2-element array references (name, structure) pairs
 862 that will be dumped on the error page in debug mode.
 863
 864 =cut
 865
 866 sub dump_these {
 867     my $c = shift;
 868     [ Request => $c->req ], [ Response => $c->res ], [ Stash => $c->stash ],;
 869 }
 870
 871 =head2 $c->engine_class
 872
 873 Returns or sets the engine class.
 874
 875 =head2 $c->execute( $class, $coderef )
 876
 877 Execute a coderef in given class and catch exceptions. Errors are available
 878 via $c->error.
 879
 880 =cut
 881
 882 sub execute {
 883     my ( $c, $class, $code ) = @_;
 884     $class = $c->components->{$class} || $class;
 885     $c->state(0);
 886
 887     my $callsub =
 888         ( caller(0) )[0]->isa('Catalyst::Action')
 889       ? ( caller(2) )[3]
 890       : ( caller(1) )[3];
 891
 892     my $action = '';
 893     if ( $c->debug ) {
 894         $action = "$code";
 895         $action = "/$action" unless $action =~ /\-\>/;
 896         $c->counter->{"$code"}++;
 897
 898         if ( $c->counter->{"$code"} > $RECURSION ) {
 899             my $error = qq/Deep recursion detected in "$action"/;
 900             $c->log->error($error);
 901             $c->error($error);
 902             $c->state(0);
 903             return $c->state;
 904         }
 905
 906         $action = "-> $action" if $callsub =~ /forward$/;
 907     }
 908     push( @{ $c->stack }, $code );
 909     my $elapsed = 0;
 910     my $start   = 0;
 911     $start = [gettimeofday] if $c->debug;
 912     eval { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) };
 913     $elapsed = tv_interval($start) if $c->debug;
 914
 915     if ( $c->debug ) {
 916         unless ( ( $code->name =~ /^_.*/ )
 917             && ( !$c->config->{show_internal_actions} ) )
 918         {
 919             push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
 920         }
 921     }
 922     pop( @{ $c->stack } );
 923
 924     if ( my $error = $@ ) {
 925
 926         if ( $error eq $DETACH ) { die $DETACH if $c->depth > 1 }
 927         else {
 928             unless ( ref $error ) {
 929                 chomp $error;
 930                 $error = qq/Caught exception "$error"/;
 931             }
 932             $c->error($error);
 933             $c->state(0);
 934         }
 935     }
 936     return $c->state;
 937 }
 938
 939 =head2 $c->finalize
 940
 941 Finalizes the request.
 942
 943 =cut
 944
 945 sub finalize {
 946     my $c = shift;
 947
 948     for my $error ( @{ $c->error } ) {
 949         $c->log->error($error);
 950     }
 951
 952     $c->finalize_uploads;
 953
 954     # Error
 955     if ( $#{ $c->error } >= 0 ) {
 956         $c->finalize_error;
 957     }
 958
 959     $c->finalize_headers;
 960
 961     # HEAD request
 962     if ( $c->request->method eq 'HEAD' ) {
 963         $c->response->body('');
 964     }
 965
 966     $c->finalize_body;
 967
 968     return $c->response->status;
 969 }
 970
 971 =head2 $c->finalize_body
 972
 973 Finalizes body.
 974
 975 =cut
 976
 977 sub finalize_body { my $c = shift; $c->engine->finalize_body( $c, @_ ) }
 978
 979 =head2 $c->finalize_cookies
 980
 981 Finalizes cookies.
 982
 983 =cut
 984
 985 sub finalize_cookies { my $c = shift; $c->engine->finalize_cookies( $c, @_ ) }
 986
 987 =head2 $c->finalize_error
 988
 989 Finalizes error.
 990
 991 =cut
 992
 993 sub finalize_error { my $c = shift; $c->engine->finalize_error( $c, @_ ) }
 994
 995 =head2 $c->finalize_headers
 996
 997 Finalizes headers.
 998
 999 =cut
1000
1001 sub finalize_headers {
1002     my $c = shift;
1003
1004     # Check if we already finalized headers
1005     return if $c->response->{_finalized_headers};
1006
1007     # Handle redirects
1008     if ( my $location = $c->response->redirect ) {
1009         $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
1010         $c->response->header( Location => $location );
1011     }
1012
1013     # Content-Length
1014     if ( $c->response->body && !$c->response->content_length ) {
1015         $c->response->content_length( bytes::length( $c->response->body ) );
1016     }
1017
1018     # Errors
1019     if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
1020         $c->response->headers->remove_header("Content-Length");
1021         $c->response->body('');
1022     }
1023
1024     $c->finalize_cookies;
1025
1026     $c->engine->finalize_headers( $c, @_ );
1027
1028     # Done
1029     $c->response->{_finalized_headers} = 1;
1030 }
1031
1032 =head2 $c->finalize_output
1033
1034 An alias for finalize_body.
1035
1036 =head2 $c->finalize_read
1037
1038 Finalizes the input after reading is complete.
1039
1040 =cut
1041
1042 sub finalize_read { my $c = shift; $c->engine->finalize_read( $c, @_ ) }
1043
1044 =head2 $c->finalize_uploads
1045
1046 Finalizes uploads. Cleans up any temporary files.
1047
1048 =cut
1049
1050 sub finalize_uploads { my $c = shift; $c->engine->finalize_uploads( $c, @_ ) }
1051
1052 =head2 $c->get_action( $action, $namespace )
1053
1054 Gets an action in a given namespace.
1055
1056 =cut
1057
1058 sub get_action { my $c = shift; $c->dispatcher->get_action(@_) }
1059
1060 =head2 $c->get_actions( $action, $namespace )
1061
1062 Gets all actions of a given name in a namespace and all parent
1063 namespaces.
1064
1065 =cut
1066
1067 sub get_actions { my $c = shift; $c->dispatcher->get_actions( $c, @_ ) }
1068
1069 =head2 handle_request( $class, @arguments )
1070
1071 Called to handle each HTTP request.
1072
1073 =cut
1074
1075 sub handle_request {
1076     my ( $class, @arguments ) = @_;
1077
1078     # Always expect worst case!
1079     my $status = -1;
1080     eval {
1081         my @stats = ();
1082
1083         my $handler = sub {
1084             my $c = $class->prepare(@arguments);
1085             $c->{stats} = \@stats;
1086             $c->dispatch;
1087             return $c->finalize;
1088         };
1089
1090         if ( $class->debug ) {
1091             my $start = [gettimeofday];
1092             $status = &$handler;
1093             my $elapsed = tv_interval $start;
1094             $elapsed = sprintf '%f', $elapsed;
1095             my $av = sprintf '%.3f',
1096               ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
1097             my $t = Text::SimpleTable->new( [ 64, 'Action' ], [ 9, 'Time' ] );
1098
1099             for my $stat (@stats) { $t->row( $stat->[0], $stat->[1] ) }
1100             $class->log->info(
1101                 "Request took ${elapsed}s ($av/s)\n" . $t->draw );
1102         }
1103         else { $status = &$handler }
1104
1105     };
1106
1107     if ( my $error = $@ ) {
1108         chomp $error;
1109         $class->log->error(qq/Caught exception in engine "$error"/);
1110     }
1111
1112     $COUNT++;
1113     $class->log->_flush() if $class->log->can('_flush');
1114     return $status;
1115 }
1116
1117 =head2 $c->prepare( @arguments )
1118
1119 Creates a Catalyst context from an engine-specific request (Apache, CGI,
1120 etc.).
1121
1122 =cut
1123
1124 sub prepare {
1125     my ( $class, @arguments ) = @_;
1126
1127     $class->context_class( ref $class || $class ) unless $class->context_class;
1128     my $c = $class->context_class->new(
1129         {
1130             counter => {},
1131             stack   => [],
1132             request => $class->request_class->new(
1133                 {
1134                     arguments        => [],
1135                     body_parameters  => {},
1136                     cookies          => {},
1137                     headers          => HTTP::Headers->new,
1138                     parameters       => {},
1139                     query_parameters => {},
1140                     secure           => 0,
1141                     snippets         => [],
1142                     uploads          => {}
1143                 }
1144             ),
1145             response => $class->response_class->new(
1146                 {
1147                     body    => '',
1148                     cookies => {},
1149                     headers => HTTP::Headers->new(),
1150                     status  => 200
1151                 }
1152             ),
1153             stash => {},
1154             state => 0
1155         }
1156     );
1157
1158     # For on-demand data
1159     $c->request->{_context}  = $c;
1160     $c->response->{_context} = $c;
1161     weaken( $c->request->{_context} );
1162     weaken( $c->response->{_context} );
1163
1164     if ( $c->debug ) {
1165         my $secs = time - $START || 1;
1166         my $av = sprintf '%.3f', $COUNT / $secs;
1167         $c->log->debug('**********************************');
1168         $c->log->debug("* Request $COUNT ($av/s) [$$]");
1169         $c->log->debug('**********************************');
1170         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
1171     }
1172
1173     $c->prepare_request(@arguments);
1174     $c->prepare_connection;
1175     $c->prepare_query_parameters;
1176     $c->prepare_headers;
1177     $c->prepare_cookies;
1178     $c->prepare_path;
1179
1180     # On-demand parsing
1181     $c->prepare_body unless $c->config->{parse_on_demand};
1182
1183     my $method  = $c->req->method  || '';
1184     my $path    = $c->req->path    || '';
1185     my $address = $c->req->address || '';
1186
1187     $c->log->debug(qq/"$method" request for "$path" from "$address"/)
1188       if $c->debug;
1189
1190     $c->prepare_action;
1191
1192     return $c;
1193 }
1194
1195 =head2 $c->prepare_action
1196
1197 Prepares action.
1198
1199 =cut
1200
1201 sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
1202
1203 =head2 $c->prepare_body
1204
1205 Prepares message body.
1206
1207 =cut
1208
1209 sub prepare_body {
1210     my $c = shift;
1211
1212     # Do we run for the first time?
1213     return if defined $c->request->{_body};
1214
1215     # Initialize on-demand data
1216     $c->engine->prepare_body( $c, @_ );
1217     $c->prepare_parameters;
1218     $c->prepare_uploads;
1219
1220     if ( $c->debug && keys %{ $c->req->body_parameters } ) {
1221         my $t = Text::SimpleTable->new( [ 37, 'Key' ], [ 36, 'Value' ] );
1222         for my $key ( sort keys %{ $c->req->body_parameters } ) {
1223             my $param = $c->req->body_parameters->{$key};
1224             my $value = defined($param) ? $param : '';
1225             $t->row( $key,
1226                 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1227         }
1228         $c->log->debug( "Body Parameters are:\n" . $t->draw );
1229     }
1230 }
1231
1232 =head2 $c->prepare_body_chunk( $chunk )
1233
1234 Prepares a chunk of data before sending it to L<HTTP::Body>.
1235
1236 =cut
1237
1238 sub prepare_body_chunk {
1239     my $c = shift;
1240     $c->engine->prepare_body_chunk( $c, @_ );
1241 }
1242
1243 =head2 $c->prepare_body_parameters
1244
1245 Prepares body parameters.
1246
1247 =cut
1248
1249 sub prepare_body_parameters {
1250     my $c = shift;
1251     $c->engine->prepare_body_parameters( $c, @_ );
1252 }
1253
1254 =head2 $c->prepare_connection
1255
1256 Prepares connection.
1257
1258 =cut
1259
1260 sub prepare_connection {
1261     my $c = shift;
1262     $c->engine->prepare_connection( $c, @_ );
1263 }
1264
1265 =head2 $c->prepare_cookies
1266
1267 Prepares cookies.
1268
1269 =cut
1270
1271 sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
1272
1273 =head2 $c->prepare_headers
1274
1275 Prepares headers.
1276
1277 =cut
1278
1279 sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
1280
1281 =head2 $c->prepare_parameters
1282
1283 Prepares parameters.
1284
1285 =cut
1286
1287 sub prepare_parameters {
1288     my $c = shift;
1289     $c->prepare_body_parameters;
1290     $c->engine->prepare_parameters( $c, @_ );
1291 }
1292
1293 =head2 $c->prepare_path
1294
1295 Prepares path and base.
1296
1297 =cut
1298
1299 sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
1300
1301 =head2 $c->prepare_query_parameters
1302
1303 Prepares query parameters.
1304
1305 =cut
1306
1307 sub prepare_query_parameters {
1308     my $c = shift;
1309
1310     $c->engine->prepare_query_parameters( $c, @_ );
1311
1312     if ( $c->debug && keys %{ $c->request->query_parameters } ) {
1313         my $t = Text::SimpleTable->new( [ 37, 'Key' ], [ 36, 'Value' ] );
1314         for my $key ( sort keys %{ $c->req->query_parameters } ) {
1315             my $param = $c->req->query_parameters->{$key};
1316             my $value = defined($param) ? $param : '';
1317             $t->row( $key,
1318                 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1319         }
1320         $c->log->debug( "Query Parameters are:\n" . $t->draw );
1321     }
1322 }
1323
1324 =head2 $c->prepare_read
1325
1326 Prepares the input for reading.
1327
1328 =cut
1329
1330 sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
1331
1332 =head2 $c->prepare_request
1333
1334 Prepares the engine request.
1335
1336 =cut
1337
1338 sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
1339
1340 =head2 $c->prepare_uploads
1341
1342 Prepares uploads.
1343
1344 =cut
1345
1346 sub prepare_uploads {
1347     my $c = shift;
1348
1349     $c->engine->prepare_uploads( $c, @_ );
1350
1351     if ( $c->debug && keys %{ $c->request->uploads } ) {
1352         my $t = Text::SimpleTable->new(
1353             [ 12, 'Key' ],
1354             [ 28, 'Filename' ],
1355             [ 18, 'Type' ],
1356             [ 9,  'Size' ]
1357         );
1358         for my $key ( sort keys %{ $c->request->uploads } ) {
1359             my $upload = $c->request->uploads->{$key};
1360             for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
1361                 $t->row( $key, $u->filename, $u->type, $u->size );
1362             }
1363         }
1364         $c->log->debug( "File Uploads are:\n" . $t->draw );
1365     }
1366 }
1367
1368 =head2 $c->prepare_write
1369
1370 Prepares the output for writing.
1371
1372 =cut
1373
1374 sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
1375
1376 =head2 $c->request_class
1377
1378 Returns or sets the request class.
1379
1380 =head2 $c->response_class
1381
1382 Returns or sets the response class.
1383
1384 =head2 $c->read( [$maxlength] )
1385
1386 Reads a chunk of data from the request body. This method is designed to
1387 be used in a while loop, reading C<$maxlength> bytes on every call.
1388 C<$maxlength> defaults to the size of the request if not specified.
1389
1390 You have to set C<MyApp-E<gt>config-E<gt>{parse_on_demand}> to use this
1391 directly.
1392
1393 =cut
1394
1395 sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
1396
1397 =head2 $c->run
1398
1399 Starts the engine.
1400
1401 =cut
1402
1403 sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
1404
1405 =head2 $c->set_action( $action, $code, $namespace, $attrs )
1406
1407 Sets an action in a given namespace.
1408
1409 =cut
1410
1411 sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
1412
1413 =head2 $c->setup_actions($component)
1414
1415 Sets up actions for a component.
1416
1417 =cut
1418
1419 sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
1420
1421 =head2 $c->setup_components
1422
1423 Sets up components.
1424
1425 =cut
1426
1427 sub setup_components {
1428     my $class = shift;
1429
1430     my $callback = sub {
1431         my ( $component, $context ) = @_;
1432
1433         unless ( $component->isa('Catalyst::Component') ) {
1434             return $component;
1435         }
1436
1437         my $suffix = Catalyst::Utils::class2classsuffix($component);
1438         my $config = $class->config->{$suffix} || {};
1439
1440         my $instance;
1441
1442         eval { $instance = $component->new( $context, $config ); };
1443
1444         if ( my $error = $@ ) {
1445
1446             chomp $error;
1447
1448             Catalyst::Exception->throw( message =>
1449                   qq/Couldn't instantiate component "$component", "$error"/ );
1450         }
1451
1452         Catalyst::Exception->throw( message =>
1453 qq/Couldn't instantiate component "$component", "new() didn't return a object"/
1454           )
1455           unless ref $instance;
1456         return $instance;
1457     };
1458
1459     eval "package $class;\n" . q!Module::Pluggable::Fast->import(
1460             name   => '_catalyst_components',
1461             search => [
1462                 "$class\::Controller", "$class\::C",
1463                 "$class\::Model",      "$class\::M",
1464                 "$class\::View",       "$class\::V"
1465             ],
1466             callback => $callback
1467         );
1468     !;
1469
1470     if ( my $error = $@ ) {
1471
1472         chomp $error;
1473
1474         Catalyst::Exception->throw(
1475             message => qq/Couldn't load components "$error"/ );
1476     }
1477
1478     for my $component ( $class->_catalyst_components($class) ) {
1479         $class->components->{ ref $component || $component } = $component;
1480     }
1481 }
1482
1483 =head2 $c->setup_dispatcher
1484
1485 Sets up dispatcher.
1486
1487 =cut
1488
1489 sub setup_dispatcher {
1490     my ( $class, $dispatcher ) = @_;
1491
1492     if ($dispatcher) {
1493         $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
1494     }
1495
1496     if ( $ENV{CATALYST_DISPATCHER} ) {
1497         $dispatcher = 'Catalyst::Dispatcher::' . $ENV{CATALYST_DISPATCHER};
1498     }
1499
1500     if ( $ENV{ uc($class) . '_DISPATCHER' } ) {
1501         $dispatcher =
1502           'Catalyst::Dispatcher::' . $ENV{ uc($class) . '_DISPATCHER' };
1503     }
1504
1505     unless ($dispatcher) {
1506         $dispatcher = $class->dispatcher_class;
1507     }
1508
1509     $dispatcher->require;
1510
1511     if ($@) {
1512         Catalyst::Exception->throw(
1513             message => qq/Couldn't load dispatcher "$dispatcher", "$@"/ );
1514     }
1515
1516     # dispatcher instance
1517     $class->dispatcher( $dispatcher->new );
1518 }
1519
1520 =head2 $c->setup_engine
1521
1522 Sets up engine.
1523
1524 =cut
1525
1526 sub setup_engine {
1527     my ( $class, $engine ) = @_;
1528
1529     if ($engine) {
1530         $engine = 'Catalyst::Engine::' . $engine;
1531     }
1532
1533     if ( $ENV{CATALYST_ENGINE} ) {
1534         $engine = 'Catalyst::Engine::' . $ENV{CATALYST_ENGINE};
1535     }
1536
1537     if ( $ENV{ uc($class) . '_ENGINE' } ) {
1538         $engine = 'Catalyst::Engine::' . $ENV{ uc($class) . '_ENGINE' };
1539     }
1540
1541     if ( !$engine && $ENV{MOD_PERL} ) {
1542
1543         # create the apache method
1544         {
1545             no strict 'refs';
1546             *{"$class\::apache"} = sub { shift->engine->apache };
1547         }
1548
1549         my ( $software, $version ) =
1550           $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
1551
1552         $version =~ s/_//g;
1553         $version =~ s/(\.[^.]+)\./$1/g;
1554
1555         if ( $software eq 'mod_perl' ) {
1556
1557             if ( $version >= 1.99922 ) {
1558                 $engine = 'Catalyst::Engine::Apache2::MP20';
1559             }
1560
1561             elsif ( $version >= 1.9901 ) {
1562                 $engine = 'Catalyst::Engine::Apache2::MP19';
1563             }
1564
1565             elsif ( $version >= 1.24 ) {
1566                 $engine = 'Catalyst::Engine::Apache::MP13';
1567             }
1568
1569             else {
1570                 Catalyst::Exception->throw( message =>
1571                       qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
1572             }
1573
1574             # install the correct mod_perl handler
1575             if ( $version >= 1.9901 ) {
1576                 *handler = sub  : method {
1577                     shift->handle_request(@_);
1578                 };
1579             }
1580             else {
1581                 *handler = sub ($$) { shift->handle_request(@_) };
1582             }
1583
1584         }
1585
1586         elsif ( $software eq 'Zeus-Perl' ) {
1587             $engine = 'Catalyst::Engine::Zeus';
1588         }
1589
1590         else {
1591             Catalyst::Exception->throw(
1592                 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
1593         }
1594     }
1595
1596     unless ($engine) {
1597         $engine = $class->engine_class;
1598     }
1599
1600     $engine->require;
1601
1602     if ($@) {
1603         Catalyst::Exception->throw( message =>
1604 qq/Couldn't load engine "$engine" (maybe you forgot to install it?), "$@"/
1605         );
1606     }
1607
1608     # check for old engines that are no longer compatible
1609     my $old_engine;
1610     if ( $engine->isa('Catalyst::Engine::Apache')
1611         && !Catalyst::Engine::Apache->VERSION )
1612     {
1613         $old_engine = 1;
1614     }
1615
1616     elsif ( $engine->isa('Catalyst::Engine::Server::Base')
1617         && Catalyst::Engine::Server->VERSION le '0.02' )
1618     {
1619         $old_engine = 1;
1620     }
1621
1622     elsif ($engine->isa('Catalyst::Engine::HTTP::POE')
1623         && $engine->VERSION eq '0.01' )
1624     {
1625         $old_engine = 1;
1626     }
1627
1628     elsif ($engine->isa('Catalyst::Engine::Zeus')
1629         && $engine->VERSION eq '0.01' )
1630     {
1631         $old_engine = 1;
1632     }
1633
1634     if ($old_engine) {
1635         Catalyst::Exception->throw( message =>
1636               qq/Engine "$engine" is not supported by this version of Catalyst/
1637         );
1638     }
1639
1640     # engine instance
1641     $class->engine( $engine->new );
1642 }
1643
1644 =head2 $c->setup_home
1645
1646 Sets up the home directory.
1647
1648 =cut
1649
1650 sub setup_home {
1651     my ( $class, $home ) = @_;
1652
1653     if ( $ENV{CATALYST_HOME} ) {
1654         $home = $ENV{CATALYST_HOME};
1655     }
1656
1657     if ( $ENV{ uc($class) . '_HOME' } ) {
1658         $home = $ENV{ uc($class) . '_HOME' };
1659     }
1660
1661     unless ($home) {
1662         $home = Catalyst::Utils::home($class);
1663     }
1664
1665     if ($home) {
1666         $class->config->{home} ||= $home;
1667         $class->config->{root} ||= dir($home)->subdir('root');
1668     }
1669 }
1670
1671 =head2 $c->setup_log
1672
1673 Sets up log.
1674
1675 =cut
1676
1677 sub setup_log {
1678     my ( $class, $debug ) = @_;
1679
1680     unless ( $class->log ) {
1681         $class->log( Catalyst::Log->new );
1682     }
1683
1684     my $app_flag = Catalyst::Utils::class2env($class) . '_DEBUG';
1685
1686     if (
1687           ( defined( $ENV{CATALYST_DEBUG} ) || defined( $ENV{$app_flag} ) )
1688         ? ( $ENV{CATALYST_DEBUG} || $ENV{$app_flag} )
1689         : $debug
1690       )
1691     {
1692         no strict 'refs';
1693         *{"$class\::debug"} = sub { 1 };
1694         $class->log->debug('Debug messages enabled');
1695     }
1696 }
1697
1698 =head2 $c->setup_plugins
1699
1700 Sets up plugins.
1701
1702 =cut
1703
1704 sub setup_plugins {
1705     my ( $class, $plugins ) = @_;
1706
1707     $plugins ||= [];
1708     for my $plugin ( reverse @$plugins ) {
1709
1710         $plugin = "Catalyst::Plugin::$plugin";
1711
1712         $plugin->require;
1713
1714         if ($@) {
1715             Catalyst::Exception->throw(
1716                 message => qq/Couldn't load plugin "$plugin", "$@"/ );
1717         }
1718
1719         {
1720             no strict 'refs';
1721             unshift @{"$class\::ISA"}, $plugin;
1722         }
1723     }
1724 }
1725
1726 =head2 $c->stack
1727
1728 Returns the stack.
1729
1730 =head2 $c->write( $data )
1731
1732 Writes $data to the output stream. When using this method directly, you
1733 will need to manually set the C<Content-Length> header to the length of
1734 your output data, if known.
1735
1736 =cut
1737
1738 sub write {
1739     my $c = shift;
1740
1741     # Finalize headers if someone manually writes output
1742     $c->finalize_headers;
1743
1744     return $c->engine->write( $c, @_ );
1745 }
1746
1747 =head2 version
1748
1749 Returns the Catalyst version number. Mostly useful for "powered by"
1750 messages in template systems.
1751
1752 =cut
1753
1754 sub version { return $Catalyst::VERSION }
1755
1756 =head1 INTERNAL ACTIONS
1757
1758 Catalyst uses internal actions like C<_DISPATCH>, C<_BEGIN>, C<_AUTO>,
1759 C<_ACTION>, and C<_END>. These are by default not shown in the private
1760 action table, but you can make them visible with a config parameter.
1761
1762     MyApp->config->{show_internal_actions} = 1;
1763
1764 =head1 CASE SENSITIVITY
1765
1766 By default Catalyst is not case sensitive, so C<MyApp::C::FOO::Bar> is
1767 mapped to C</foo/bar>. You can activate case sensitivity with a config
1768 parameter.
1769
1770     MyApp->config->{case_sensitive} = 1;
1771
1772 This causes C<MyApp::C::Foo::Bar> to map to C</Foo/Bar>.
1773
1774 =head1 ON-DEMAND PARSER
1775
1776 The request body is usually parsed at the beginning of a request,
1777 but if you want to handle input yourself or speed things up a bit,
1778 you can enable on-demand parsing with a config parameter.
1779
1780     MyApp->config->{parse_on_demand} = 1;
1781
1782 =head1 PROXY SUPPORT
1783
1784 Many production servers operate using the common double-server approach,
1785 with a lightweight frontend web server passing requests to a larger
1786 backend server. An application running on the backend server must deal
1787 with two problems: the remote user always appears to be C<127.0.0.1> and
1788 the server's hostname will appear to be C<localhost> regardless of the
1789 virtual host that the user connected through.
1790
1791 Catalyst will automatically detect this situation when you are running
1792 the frontend and backend servers on the same machine. The following
1793 changes are made to the request.
1794
1795     $c->req->address is set to the user's real IP address, as read from
1796     the HTTP X-Forwarded-For header.
1797
1798     The host value for $c->req->base and $c->req->uri is set to the real
1799     host, as read from the HTTP X-Forwarded-Host header.
1800
1801 Obviously, your web server must support these headers for this to work.
1802
1803 In a more complex server farm environment where you may have your
1804 frontend proxy server(s) on different machines, you will need to set a
1805 configuration option to tell Catalyst to read the proxied data from the
1806 headers.
1807
1808     MyApp->config->{using_frontend_proxy} = 1;
1809
1810 If you do not wish to use the proxy support at all, you may set:
1811
1812     MyApp->config->{ignore_frontend_proxy} = 1;
1813
1814 =head1 THREAD SAFETY
1815
1816 Catalyst has been tested under Apache 2's threading mpm_worker, mpm_winnt,
1817 and the standalone forking HTTP server on Windows. We believe the Catalyst
1818 core to be thread-safe.
1819
1820 If you plan to operate in a threaded environment, remember that all other
1821 modules you are using must also be thread-safe. Some modules, most notably
1822 L<DBD::SQLite>, are not thread-safe.
1823
1824 =head1 SUPPORT
1825
1826 IRC:
1827
1828     Join #catalyst on irc.perl.org.
1829
1830 Mailing Lists:
1831
1832     http://lists.rawmode.org/mailman/listinfo/catalyst
1833     http://lists.rawmode.org/mailman/listinfo/catalyst-dev
1834
1835 Web:
1836
1837     http://catalyst.perl.org
1838
1839 Wiki:
1840
1841     http://dev.catalyst.perl.org
1842
1843 =head1 SEE ALSO
1844
1845 =head2 L<Catalyst::Manual> - The Catalyst Manual
1846
1847 =head2 L<Catalyst::Component>, L<Catalyst::Base> - Base classes for components
1848
1849 =head2 L<Catalyst::Engine> - Core engine
1850
1851 =head2 L<Catalyst::Log> - Log class.
1852
1853 =head2 L<Catalyst::Request> - Request object
1854
1855 =head2 L<Catalyst::Response> - Response object
1856
1857 =head2 L<Catalyst::Test> - The test suite.
1858
1859 =head1 CREDITS
1860
1861 Andy Grundman
1862
1863 Andy Wardley
1864
1865 Andreas Marienborg
1866
1867 Andrew Bramble
1868
1869 Andrew Ford
1870
1871 Andrew Ruthven
1872
1873 Arthur Bergman
1874
1875 Autrijus Tang
1876
1877 Brian Cassidy
1878
1879 Christian Hansen
1880
1881 Christopher Hicks
1882
1883 Dan Sully
1884
1885 Danijel Milicevic
1886
1887 David Kamholz
1888
1889 David Naughton
1890
1891 Drew Taylor
1892
1893 Gary Ashton Jones
1894
1895 Geoff Richards
1896
1897 Jesse Sheidlower
1898
1899 Jesse Vincent
1900
1901 Jody Belka
1902
1903 Johan Lindstrom
1904
1905 Juan Camacho
1906
1907 Leon Brocard
1908
1909 Marcus Ramberg
1910
1911 Matt S Trout
1912
1913 Robert Sedlacek
1914
1915 Sam Vilain
1916
1917 Sascha Kiefer
1918
1919 Tatsuhiko Miyagawa
1920
1921 Ulf Edvinsson
1922
1923 Yuval Kogman
1924
1925 =head1 AUTHOR
1926
1927 Sebastian Riedel, C<sri@oook.de>
1928
1929 =head1 LICENSE
1930
1931 This library is free software, you can redistribute it and/or modify it under
1932 the same terms as Perl itself.
1933
1934 =cut
1935
1936 1;