lib/Catalyst.pm

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