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