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