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.54';
  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 "package $class;\n" . q!Module::Pluggable::Fast->import(
1508             name   => '_catalyst_components',
1509             search => [
1510                 "$class\::Controller", "$class\::C",
1511                 "$class\::Model",      "$class\::M",
1512                 "$class\::View",       "$class\::V"
1513             ],
1514             callback => $callback
1515         );
1516     !;
1517
1518     if ( my $error = $@ ) {
1519
1520         chomp $error;
1521
1522         Catalyst::Exception->throw(
1523             message => qq/Couldn't load components "$error"/ );
1524     }
1525
1526     for my $component ( $class->_catalyst_components($class) ) {
1527         $class->components->{ ref $component || $component } = $component;
1528     }
1529 }
1530
1531 =item $c->setup_dispatcher
1532
1533 Sets up dispatcher.
1534
1535 =cut
1536
1537 sub setup_dispatcher {
1538     my ( $class, $dispatcher ) = @_;
1539
1540     if ($dispatcher) {
1541         $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
1542     }
1543
1544     if ( $ENV{CATALYST_DISPATCHER} ) {
1545         $dispatcher = 'Catalyst::Dispatcher::' . $ENV{CATALYST_DISPATCHER};
1546     }
1547
1548     if ( $ENV{ uc($class) . '_DISPATCHER' } ) {
1549         $dispatcher =
1550           'Catalyst::Dispatcher::' . $ENV{ uc($class) . '_DISPATCHER' };
1551     }
1552
1553     unless ($dispatcher) {
1554         $dispatcher = $class->dispatcher_class;
1555     }
1556
1557     $dispatcher->require;
1558
1559     if ($@) {
1560         Catalyst::Exception->throw(
1561             message => qq/Couldn't load dispatcher "$dispatcher", "$@"/ );
1562     }
1563
1564     # dispatcher instance
1565     $class->dispatcher( $dispatcher->new );
1566 }
1567
1568 =item $c->setup_engine
1569
1570 Sets up engine.
1571
1572 =cut
1573
1574 sub setup_engine {
1575     my ( $class, $engine ) = @_;
1576
1577     if ($engine) {
1578         $engine = 'Catalyst::Engine::' . $engine;
1579     }
1580
1581     if ( $ENV{CATALYST_ENGINE} ) {
1582         $engine = 'Catalyst::Engine::' . $ENV{CATALYST_ENGINE};
1583     }
1584
1585     if ( $ENV{ uc($class) . '_ENGINE' } ) {
1586         $engine = 'Catalyst::Engine::' . $ENV{ uc($class) . '_ENGINE' };
1587     }
1588
1589     if ( !$engine && $ENV{MOD_PERL} ) {
1590
1591         # create the apache method
1592         {
1593             no strict 'refs';
1594             *{"$class\::apache"} = sub { shift->engine->apache };
1595         }
1596
1597         my ( $software, $version ) =
1598           $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
1599
1600         $version =~ s/_//g;
1601         $version =~ s/(\.[^.]+)\./$1/g;
1602
1603         if ( $software eq 'mod_perl' ) {
1604
1605             if ( $version >= 1.99922 ) {
1606                 $engine = 'Catalyst::Engine::Apache2::MP20';
1607             }
1608
1609             elsif ( $version >= 1.9901 ) {
1610                 $engine = 'Catalyst::Engine::Apache2::MP19';
1611             }
1612
1613             elsif ( $version >= 1.24 ) {
1614                 $engine = 'Catalyst::Engine::Apache::MP13';
1615             }
1616
1617             else {
1618                 Catalyst::Exception->throw( message =>
1619                       qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
1620             }
1621
1622             # install the correct mod_perl handler
1623             if ( $version >= 1.9901 ) {
1624                 *handler = sub  : method {
1625                     shift->handle_request(@_);
1626                 };
1627             }
1628             else {
1629                 *handler = sub ($$) { shift->handle_request(@_) };
1630             }
1631
1632         }
1633
1634         elsif ( $software eq 'Zeus-Perl' ) {
1635             $engine = 'Catalyst::Engine::Zeus';
1636         }
1637
1638         else {
1639             Catalyst::Exception->throw(
1640                 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
1641         }
1642     }
1643
1644     unless ($engine) {
1645         $engine = $class->engine_class;
1646     }
1647
1648     $engine->require;
1649
1650     if ($@) {
1651         Catalyst::Exception->throw( message =>
1652 qq/Couldn't load engine "$engine" (maybe you forgot to install it?), "$@"/
1653         );
1654     }
1655
1656     # check for old engines that are no longer compatible
1657     my $old_engine;
1658     if ( $engine->isa('Catalyst::Engine::Apache')
1659         && !Catalyst::Engine::Apache->VERSION )
1660     {
1661         $old_engine = 1;
1662     }
1663
1664     elsif ( $engine->isa('Catalyst::Engine::Server::Base')
1665         && Catalyst::Engine::Server->VERSION le '0.02' )
1666     {
1667         $old_engine = 1;
1668     }
1669
1670     elsif ($engine->isa('Catalyst::Engine::HTTP::POE')
1671         && $engine->VERSION eq '0.01' )
1672     {
1673         $old_engine = 1;
1674     }
1675
1676     elsif ($engine->isa('Catalyst::Engine::Zeus')
1677         && $engine->VERSION eq '0.01' )
1678     {
1679         $old_engine = 1;
1680     }
1681
1682     if ($old_engine) {
1683         Catalyst::Exception->throw( message =>
1684               qq/Engine "$engine" is not supported by this version of Catalyst/
1685         );
1686     }
1687
1688     # engine instance
1689     $class->engine( $engine->new );
1690 }
1691
1692 =item $c->setup_home
1693
1694 Sets up the home directory.
1695
1696 =cut
1697
1698 sub setup_home {
1699     my ( $class, $home ) = @_;
1700
1701     if ( $ENV{CATALYST_HOME} ) {
1702         $home = $ENV{CATALYST_HOME};
1703     }
1704
1705     if ( $ENV{ uc($class) . '_HOME' } ) {
1706         $home = $ENV{ uc($class) . '_HOME' };
1707     }
1708
1709     unless ($home) {
1710         $home = Catalyst::Utils::home($class);
1711     }
1712
1713     if ($home) {
1714         $class->config->{home} ||= $home;
1715         $class->config->{root} ||= dir($home)->subdir('root');
1716     }
1717 }
1718
1719 =item $c->setup_log
1720
1721 Sets up log.
1722
1723 =cut
1724
1725 sub setup_log {
1726     my ( $class, $debug ) = @_;
1727
1728     unless ( $class->log ) {
1729         $class->log( Catalyst::Log->new );
1730     }
1731
1732     my $app_flag = Catalyst::Utils::class2env($class) . '_DEBUG';
1733
1734     if (
1735           ( defined( $ENV{CATALYST_DEBUG} ) || defined( $ENV{$app_flag} ) )
1736         ? ( $ENV{CATALYST_DEBUG} || $ENV{$app_flag} )
1737         : $debug
1738       )
1739     {
1740         no strict 'refs';
1741         *{"$class\::debug"} = sub { 1 };
1742         $class->log->debug('Debug messages enabled');
1743     }
1744 }
1745
1746 =item $c->setup_plugins
1747
1748 Sets up plugins.
1749
1750 =cut
1751
1752 sub setup_plugins {
1753     my ( $class, $plugins ) = @_;
1754
1755     $plugins ||= [];
1756     for my $plugin ( reverse @$plugins ) {
1757
1758         $plugin = "Catalyst::Plugin::$plugin";
1759
1760         $plugin->require;
1761
1762         if ($@) {
1763             Catalyst::Exception->throw(
1764                 message => qq/Couldn't load plugin "$plugin", "$@"/ );
1765         }
1766
1767         {
1768             no strict 'refs';
1769             unshift @{"$class\::ISA"}, $plugin;
1770         }
1771     }
1772 }
1773
1774 =item $c->stack
1775
1776 Returns the stack.
1777
1778 =item $c->write( $data )
1779
1780 Writes $data to the output stream. When using this method directly, you
1781 will need to manually set the C<Content-Length> header to the length of
1782 your output data, if known.
1783
1784 Also note that any headers created after the write can  no longer be added, and
1785 this includes cookies.
1786
1787 =cut
1788
1789 sub write {
1790     my $c = shift;
1791
1792     # Finalize headers if someone manually writes output
1793     $c->finalize_headers;
1794
1795     return $c->engine->write( $c, @_ );
1796 }
1797
1798 =item version
1799
1800 Returns the Catalyst version number. Mostly useful for "powered by"
1801 messages in template systems.
1802
1803 =cut
1804
1805 sub version { return $Catalyst::VERSION }
1806
1807 =back
1808
1809 =head1 INTERNAL ACTIONS
1810
1811 Catalyst uses internal actions like C<_DISPATCH>, C<_BEGIN>, C<_AUTO>,
1812 C<_ACTION>, and C<_END>. These are by default not shown in the private
1813 action table, but you can make them visible with a config parameter.
1814
1815     MyApp->config->{show_internal_actions} = 1;
1816
1817 =head1 CASE SENSITIVITY
1818
1819 By default Catalyst is not case sensitive, so C<MyApp::C::FOO::Bar> is
1820 mapped to C</foo/bar>. You can activate case sensitivity with a config
1821 parameter.
1822
1823     MyApp->config->{case_sensitive} = 1;
1824
1825 This causes C<MyApp::C::Foo::Bar> to map to C</Foo/Bar>.
1826
1827 =head1 ON-DEMAND PARSER
1828
1829 The request body is usually parsed at the beginning of a request,
1830 but if you want to handle input yourself or speed things up a bit,
1831 you can enable on-demand parsing with a config parameter.
1832
1833     MyApp->config->{parse_on_demand} = 1;
1834
1835 =head1 PROXY SUPPORT
1836
1837 Many production servers operate using the common double-server approach,
1838 with a lightweight frontend web server passing requests to a larger
1839 backend server. An application running on the backend server must deal
1840 with two problems: the remote user always appears to be C<127.0.0.1> and
1841 the server's hostname will appear to be C<localhost> regardless of the
1842 virtual host that the user connected through.
1843
1844 Catalyst will automatically detect this situation when you are running
1845 the frontend and backend servers on the same machine. The following
1846 changes are made to the request.
1847
1848     $c->req->address is set to the user's real IP address, as read from
1849     the HTTP X-Forwarded-For header.
1850
1851     The host value for $c->req->base and $c->req->uri is set to the real
1852     host, as read from the HTTP X-Forwarded-Host header.
1853
1854 Obviously, your web server must support these headers for this to work.
1855
1856 In a more complex server farm environment where you may have your
1857 frontend proxy server(s) on different machines, you will need to set a
1858 configuration option to tell Catalyst to read the proxied data from the
1859 headers.
1860
1861     MyApp->config->{using_frontend_proxy} = 1;
1862
1863 If you do not wish to use the proxy support at all, you may set:
1864
1865     MyApp->config->{ignore_frontend_proxy} = 1;
1866
1867 =head1 THREAD SAFETY
1868
1869 Catalyst has been tested under Apache 2's threading mpm_worker, mpm_winnt,
1870 and the standalone forking HTTP server on Windows. We believe the Catalyst
1871 core to be thread-safe.
1872
1873 If you plan to operate in a threaded environment, remember that all other
1874 modules you are using must also be thread-safe. Some modules, most notably
1875 L<DBD::SQLite>, are not thread-safe.
1876
1877 =head1 SUPPORT
1878
1879 IRC:
1880
1881     Join #catalyst on irc.perl.org.
1882
1883 Mailing Lists:
1884
1885     http://lists.rawmode.org/mailman/listinfo/catalyst
1886     http://lists.rawmode.org/mailman/listinfo/catalyst-dev
1887
1888 Web:
1889
1890     http://catalyst.perl.org
1891
1892 Wiki:
1893
1894     http://dev.catalyst.perl.org
1895
1896 =head1 SEE ALSO
1897
1898 =over 4
1899
1900 =item L<Catalyst::Manual> - The Catalyst Manual
1901
1902 =item L<Catalyst::Component>, L<Catalyst::Base> - Base classes for components
1903
1904 =item L<Catalyst::Engine> - Core engine
1905
1906 =item L<Catalyst::Log> - Log class.
1907
1908 =item L<Catalyst::Request> - Request object
1909
1910 =item L<Catalyst::Response> - Response object
1911
1912 =item L<Catalyst::Test> - The test suite.
1913
1914 =back
1915
1916 =head1 CREDITS
1917
1918 Andy Grundman
1919
1920 Andy Wardley
1921
1922 Andreas Marienborg
1923
1924 Andrew Bramble
1925
1926 Andrew Ford
1927
1928 Andrew Ruthven
1929
1930 Arthur Bergman
1931
1932 Autrijus Tang
1933
1934 Brian Cassidy
1935
1936 Christian Hansen
1937
1938 Christopher Hicks
1939
1940 Dan Sully
1941
1942 Danijel Milicevic
1943
1944 David Kamholz
1945
1946 David Naughton
1947
1948 Gary Ashton Jones
1949
1950 Geoff Richards
1951
1952 Jesse Sheidlower
1953
1954 Jesse Vincent
1955
1956 Jody Belka
1957
1958 Johan Lindstrom
1959
1960 Juan Camacho
1961
1962 Leon Brocard
1963
1964 Marcus Ramberg
1965
1966 Matt S Trout
1967
1968 Robert Sedlacek
1969
1970 Sam Vilain
1971
1972 Sascha Kiefer
1973
1974 Tatsuhiko Miyagawa
1975
1976 Ulf Edvinsson
1977
1978 Yuval Kogman
1979
1980 =head1 AUTHOR
1981
1982 Sebastian Riedel, C<sri@oook.de>
1983
1984 =head1 LICENSE
1985
1986 This library is free software, you can redistribute it and/or modify it under
1987 the same terms as Perl itself.
1988
1989 =cut
1990
1991 1;