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