lib/Catalyst.pm

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