lib/Catalyst.pm

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