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