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