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