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