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