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