lib/Catalyst.pm

   1 package Catalyst;
   2
   3 use strict;
   4 use base 'Catalyst::Component';
   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 Catalyst::Controller;
  14 use File::stat;
  15 use NEXT;
  16 use Text::SimpleTable;
  17 use Path::Class;
  18 use Time::HiRes qw/gettimeofday tv_interval/;
  19 use URI;
  20 use Scalar::Util qw/weaken/;
  21 use Tree::Simple qw/use_weak_refs/;
  22 use Tree::Simple::Visitor::FindByUID;
  23 use attributes;
  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 = 26;
  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.64';
  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, 'Catalyst::Controller';
  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 Any data C<return>ed from the action forwarded to, will be returned by the
 249 call to forward.
 250
 251     my $foodata = $c->forward('/foo');
 252     $c->forward('index');
 253     $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
 254     $c->forward('MyApp::View::TT');
 255
 256 =cut
 257
 258 sub forward { my $c = shift; $c->dispatcher->forward( $c, @_ ) }
 259
 260 =head2 $c->detach( $action [, \@arguments ] )
 261
 262 =head2 $c->detach( $class, $method, [, \@arguments ] )
 263
 264 The same as C<forward>, but doesn't return.
 265
 266 =cut
 267
 268 sub detach { my $c = shift; $c->dispatcher->detach( $c, @_ ) }
 269
 270 =head2 $c->error
 271
 272 =head2 $c->error($error, ...)
 273
 274 =head2 $c->error($arrayref)
 275
 276 Returns an arrayref containing error messages.  If Catalyst encounters an
 277 error while processing a request, it stores the error in $c->error.  This
 278 method should not be used to store non-fatal error messages.
 279
 280     my @error = @{ $c->error };
 281
 282 Add a new error.
 283
 284     $c->error('Something bad happened');
 285
 286 Clear errors.  You probably don't want to clear the errors unless you are
 287 implementing a custom error screen.
 288
 289     $c->error(0);
 290
 291 =cut
 292
 293 sub error {
 294     my $c = shift;
 295     if ( $_[0] ) {
 296         my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
 297         push @{ $c->{error} }, @$error;
 298     }
 299     elsif ( defined $_[0] ) { $c->{error} = undef }
 300     return $c->{error} || [];
 301 }
 302
 303 =head2 $c->response
 304
 305 =head2 $c->res
 306
 307 Returns the current L<Catalyst::Response> object.
 308
 309 =head2 $c->stash
 310
 311 Returns a hashref to the stash, which may be used to store data and pass
 312 it between components during a request. You can also set hash keys by
 313 passing arguments. The stash is automatically sent to the view. The
 314 stash is cleared at the end of a request; it cannot be used for
 315 persistent storage.
 316
 317     $c->stash->{foo} = $bar;
 318     $c->stash( { moose => 'majestic', qux => 0 } );
 319     $c->stash( bar => 1, gorch => 2 ); # equivalent to passing a hashref
 320
 321     # stash is automatically passed to the view for use in a template
 322     $c->forward( 'MyApp::V::TT' );
 323
 324 =cut
 325
 326 sub stash {
 327     my $c = shift;
 328     if (@_) {
 329         my $stash = @_ > 1 ? {@_} : $_[0];
 330         while ( my ( $key, $val ) = each %$stash ) {
 331             $c->{stash}->{$key} = $val;
 332         }
 333     }
 334     return $c->{stash};
 335 }
 336
 337 =head2 $c->state
 338
 339 Contains the return value of the last executed action.
 340
 341 =head2 Component Accessors
 342
 343 =head2 $c->comp($name)
 344
 345 =head2 $c->component($name)
 346
 347 Gets a component object by name. This method is no longer recommended,
 348 unless you want to get a specific component by full
 349 class. C<$c-E<gt>controller>, C<$c-E<gt>model>, and C<$c-E<gt>view>
 350 should be used instead.
 351
 352 =cut
 353
 354 sub component {
 355     my $c = shift;
 356
 357     if (@_) {
 358
 359         my $name = shift;
 360
 361         my $appclass = ref $c || $c;
 362
 363         my @names = (
 364             $name, "${appclass}::${name}",
 365             map { "${appclass}::${_}::${name}" }
 366               qw/Model M Controller C View V/
 367         );
 368
 369         foreach my $try (@names) {
 370
 371             if ( exists $c->components->{$try} ) {
 372
 373                 my $comp = $c->components->{$try};
 374                 if ( eval { $comp->can('ACCEPT_CONTEXT'); } ) {
 375                     return $comp->ACCEPT_CONTEXT($c);
 376                 }
 377                 else { return $comp }
 378             }
 379         }
 380
 381         foreach my $component ( keys %{ $c->components } ) {
 382             my $comp;
 383             $comp = $c->components->{$component} if $component =~ /$name/i;
 384             if ($comp) {
 385                 if ( ref $comp && $comp->can('ACCEPT_CONTEXT') ) {
 386                     return $comp->ACCEPT_CONTEXT($c);
 387                 }
 388                 else { return $comp }
 389             }
 390         }
 391
 392     }
 393
 394     return sort keys %{ $c->components };
 395 }
 396
 397 =head2 $c->controller($name)
 398
 399 Gets a L<Catalyst::Controller> instance by name.
 400
 401     $c->controller('Foo')->do_stuff;
 402
 403 =cut
 404
 405 sub controller {
 406     my ( $c, $name ) = @_;
 407     my $controller = $c->comp("Controller::$name");
 408     return $controller if defined $controller;
 409     return $c->comp("C::$name");
 410 }
 411
 412 =head2 $c->model($name)
 413
 414 Gets a L<Catalyst::Model> instance by name.
 415
 416     $c->model('Foo')->do_stuff;
 417
 418 =cut
 419
 420 sub model {
 421     my ( $c, $name ) = @_;
 422     my $model = $c->comp("Model::$name");
 423     return $model if defined $model;
 424     return $c->comp("M::$name");
 425 }
 426
 427 =head2 $c->view($name)
 428
 429 Gets a L<Catalyst::View> instance by name.
 430
 431     $c->view('Foo')->do_stuff;
 432
 433 =cut
 434
 435 sub view {
 436     my ( $c, $name ) = @_;
 437     my $view = $c->comp("View::$name");
 438     return $view if defined $view;
 439     return $c->comp("V::$name");
 440 }
 441
 442 =head2 Class data and helper classes
 443
 444 =head2 $c->config
 445
 446 Returns or takes a hashref containing the application's configuration.
 447
 448     __PACKAGE__->config( { db => 'dsn:SQLite:foo.db' } );
 449
 450 =head2 $c->debug
 451
 452 Overload to enable debug messages (same as -Debug option).
 453
 454 =cut
 455
 456 sub debug { 0 }
 457
 458 =head2 $c->dispatcher
 459
 460 Returns the dispatcher instance. Stringifies to class name. See
 461 L<Catalyst::Dispatcher>.
 462
 463 =head2 $c->engine
 464
 465 Returns the engine instance. Stringifies to the class name. See
 466 L<Catalyst::Engine>.
 467
 468 =head2 $c->log
 469
 470 Returns the logging object instance. Unless it is already set, Catalyst sets
 471 this up with a L<Catalyst::Log> object. To use your own log class, set the
 472 logger with the C<< __PACKAGE__->log >> method prior to calling
 473 C<< __PACKAGE__->setup >>.
 474
 475  __PACKAGE__->log( MyLogger->new );
 476  __PACKAGE__->setup;
 477
 478 And later:
 479
 480     $c->log->info( 'Now logging with my own logger!' );
 481
 482 Your log class should implement the methods described in the
 483 L<Catalyst::Log> man page.
 484
 485 =cut
 486
 487 =head2 Utility methods
 488
 489 =head2 $c->path_to(@path)
 490
 491 Merges C<@path> with C<$c-E<gt>config-E<gt>{home}> and returns a
 492 L<Path::Class> object.
 493
 494 For example:
 495
 496     $c->path_to( 'db', 'sqlite.db' );
 497
 498 =cut
 499
 500 sub path_to {
 501     my ( $c, @path ) = @_;
 502     my $path = dir( $c->config->{home}, @path );
 503     if ( -d $path ) { return $path }
 504     else { return file( $c->config->{home}, @path ) }
 505 }
 506
 507 =head2 $c->plugin( $name, $class, @args )
 508
 509 Helper method for plugins. It creates a classdata accessor/mutator and
 510 loads and instantiates the given class.
 511
 512     MyApp->plugin( 'prototype', 'HTML::Prototype' );
 513
 514     $c->prototype->define_javascript_functions;
 515
 516 =cut
 517
 518 sub plugin {
 519     my ( $class, $name, $plugin, @args ) = @_;
 520     $plugin->require;
 521
 522     if ( my $error = $UNIVERSAL::require::ERROR ) {
 523         Catalyst::Exception->throw(
 524             message => qq/Couldn't load instant plugin "$plugin", "$error"/ );
 525     }
 526
 527     eval { $plugin->import };
 528     $class->mk_classdata($name);
 529     my $obj;
 530     eval { $obj = $plugin->new(@args) };
 531
 532     if ($@) {
 533         Catalyst::Exception->throw( message =>
 534               qq/Couldn't instantiate instant plugin "$plugin", "$@"/ );
 535     }
 536
 537     $class->$name($obj);
 538     $class->log->debug(qq/Initialized instant plugin "$plugin" as "$name"/)
 539       if $class->debug;
 540 }
 541
 542 =head2 MyApp->setup
 543
 544 Initializes the dispatcher and engine, loads any plugins, and loads the
 545 model, view, and controller components. You may also specify an array
 546 of plugins to load here, if you choose to not load them in the C<use
 547 Catalyst> line.
 548
 549     MyApp->setup;
 550     MyApp->setup( qw/-Debug/ );
 551
 552 =cut
 553
 554 sub setup {
 555     my ( $class, @arguments ) = @_;
 556
 557     unless ( $class->isa('Catalyst') ) {
 558
 559         Catalyst::Exception->throw(
 560             message => qq/'$class' does not inherit from Catalyst/ );
 561     }
 562
 563     if ( $class->arguments ) {
 564         @arguments = ( @arguments, @{ $class->arguments } );
 565     }
 566
 567     # Process options
 568     my $flags = {};
 569
 570     foreach (@arguments) {
 571
 572         if (/^-Debug$/) {
 573             $flags->{log} =
 574               ( $flags->{log} ) ? 'debug,' . $flags->{log} : 'debug';
 575         }
 576         elsif (/^-(\w+)=?(.*)$/) {
 577             $flags->{ lc $1 } = $2;
 578         }
 579         else {
 580             push @{ $flags->{plugins} }, $_;
 581         }
 582     }
 583
 584     $class->setup_home( delete $flags->{home} );
 585
 586     $class->setup_log( delete $flags->{log} );
 587     $class->setup_plugins( delete $flags->{plugins} );
 588     $class->setup_dispatcher( delete $flags->{dispatcher} );
 589     $class->setup_engine( delete $flags->{engine} );
 590
 591     for my $flag ( sort keys %{$flags} ) {
 592
 593         if ( my $code = $class->can( 'setup_' . $flag ) ) {
 594             &$code( $class, delete $flags->{$flag} );
 595         }
 596         else {
 597             $class->log->warn(qq/Unknown flag "$flag"/);
 598         }
 599     }
 600
 601     $class->log->warn(
 602         <<"EOF") if ( $ENV{CATALYST_SCRIPT_GEN} && ( $ENV{CATALYST_SCRIPT_GEN} < $Catalyst::CATALYST_SCRIPT_GEN ) );
 603 You are running an old script!
 604
 605   Please update by running (this will overwrite existing files):
 606     catalyst.pl -force -scripts $class
 607
 608   or (this will not overwrite existing files):
 609     catalyst.pl -scripts $class
 610 EOF
 611
 612     if ( $class->debug ) {
 613
 614         my @plugins = ();
 615
 616         {
 617             no strict 'refs';
 618             @plugins =
 619               map { $_ . ' ' . ( $_->VERSION || '' ) }
 620               grep { /^Catalyst::Plugin/ } @{"$class\::ISA"};
 621         }
 622
 623         if (@plugins) {
 624             my $t = Text::SimpleTable->new(76);
 625             $t->row($_) for @plugins;
 626             $class->log->debug( "Loaded plugins:\n" . $t->draw );
 627         }
 628
 629         my $dispatcher = $class->dispatcher;
 630         my $engine     = $class->engine;
 631         my $home       = $class->config->{home};
 632
 633         $class->log->debug(qq/Loaded dispatcher "$dispatcher"/);
 634         $class->log->debug(qq/Loaded engine "$engine"/);
 635
 636         $home
 637           ? ( -d $home )
 638           ? $class->log->debug(qq/Found home "$home"/)
 639           : $class->log->debug(qq/Home "$home" doesn't exist/)
 640           : $class->log->debug(q/Couldn't find home/);
 641     }
 642
 643     # Call plugins setup
 644     {
 645         no warnings qw/redefine/;
 646         local *setup = sub { };
 647         $class->setup;
 648     }
 649
 650     # Initialize our data structure
 651     $class->components( {} );
 652
 653     $class->setup_components;
 654
 655     if ( $class->debug ) {
 656         my $t = Text::SimpleTable->new( [ 65, 'Class' ], [ 8, 'Type' ] );
 657         for my $comp ( sort keys %{ $class->components } ) {
 658             my $type = ref $class->components->{$comp} ? 'instance' : 'class';
 659             $t->row( $comp, $type );
 660         }
 661         $class->log->debug( "Loaded components:\n" . $t->draw )
 662           if ( keys %{ $class->components } );
 663     }
 664
 665     # Add our self to components, since we are also a component
 666     $class->components->{$class} = $class;
 667
 668     $class->setup_actions;
 669
 670     if ( $class->debug ) {
 671         my $name = $class->config->{name} || 'Application';
 672         $class->log->info("$name powered by Catalyst $Catalyst::VERSION");
 673     }
 674     $class->log->_flush() if $class->log->can('_flush');
 675 }
 676
 677 =head2 $c->uri_for( $path, [ @args ] )
 678
 679 Merges path with C<$c-E<gt>request-E<gt>base> for absolute uri's and
 680 with C<$c-E<gt>namespace> for relative uri's, then returns a
 681 normalized L<URI> object. If any args are passed, they are added at the
 682 end of the path.
 683
 684 =cut
 685
 686 sub uri_for {
 687     my ( $c, $path, @args ) = @_;
 688     my $base     = $c->request->base->clone;
 689     my $basepath = $base->path;
 690     $basepath =~ s/\/$//;
 691     $basepath .= '/';
 692     my $namespace = $c->namespace;
 693
 694     # massage namespace, empty if absolute path
 695     $namespace =~ s/^\///;
 696     $namespace .= '/' if $namespace;
 697     $path ||= '';
 698     $namespace = '' if $path =~ /^\//;
 699     $path =~ s/^\///;
 700
 701     # join args with '/', or a blank string
 702     my $args = ( scalar @args ? '/' . join( '/', @args ) : '' );
 703     $args =~ s/^\/// unless $path;
 704     my $res =
 705       URI->new_abs( URI->new_abs( "$path$args", "$basepath$namespace" ), $base )
 706       ->canonical;
 707     $res;
 708 }
 709
 710 =head2 $c->welcome_message
 711
 712 Returns the Catalyst welcome HTML page.
 713
 714 =cut
 715
 716 sub welcome_message {
 717     my $c      = shift;
 718     my $name   = $c->config->{name};
 719     my $logo   = $c->uri_for('/static/images/catalyst_logo.png');
 720     my $prefix = Catalyst::Utils::appprefix( ref $c );
 721     $c->response->content_type('text/html; charset=utf-8');
 722     return <<"EOF";
 723 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 724     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 725 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
 726     <head>
 727         <meta http-equiv="Content-Language" content="en" />
 728         <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
 729         <title>$name on Catalyst $VERSION</title>
 730         <style type="text/css">
 731             body {
 732                 color: #000;
 733                 background-color: #eee;
 734             }
 735             div#content {
 736                 width: 640px;
 737                 margin-left: auto;
 738                 margin-right: auto;
 739                 margin-top: 10px;
 740                 margin-bottom: 10px;
 741                 text-align: left;
 742                 background-color: #ccc;
 743                 border: 1px solid #aaa;
 744                 -moz-border-radius: 10px;
 745             }
 746             p, h1, h2 {
 747                 margin-left: 20px;
 748                 margin-right: 20px;
 749                 font-family: verdana, tahoma, sans-serif;
 750             }
 751             a {
 752                 font-family: verdana, tahoma, sans-serif;
 753             }
 754             :link, :visited {
 755                     text-decoration: none;
 756                     color: #b00;
 757                     border-bottom: 1px dotted #bbb;
 758             }
 759             :link:hover, :visited:hover {
 760                     color: #555;
 761             }
 762             div#topbar {
 763                 margin: 0px;
 764             }
 765             pre {
 766                 margin: 10px;
 767                 padding: 8px;
 768             }
 769             div#answers {
 770                 padding: 8px;
 771                 margin: 10px;
 772                 background-color: #fff;
 773                 border: 1px solid #aaa;
 774                 -moz-border-radius: 10px;
 775             }
 776             h1 {
 777                 font-size: 0.9em;
 778                 font-weight: normal;
 779                 text-align: center;
 780             }
 781             h2 {
 782                 font-size: 1.0em;
 783             }
 784             p {
 785                 font-size: 0.9em;
 786             }
 787             p img {
 788                 float: right;
 789                 margin-left: 10px;
 790             }
 791             span#appname {
 792                 font-weight: bold;
 793                 font-size: 1.6em;
 794             }
 795         </style>
 796     </head>
 797     <body>
 798         <div id="content">
 799             <div id="topbar">
 800                 <h1><span id="appname">$name</span> on <a href="http://catalyst.perl.org">Catalyst</a>
 801                     $VERSION</h1>
 802              </div>
 803              <div id="answers">
 804                  <p>
 805                  <img src="$logo" alt="Catalyst Logo" />
 806                  </p>
 807                  <p>Welcome to the wonderful world of Catalyst.
 808                     This <a href="http://en.wikipedia.org/wiki/MVC">MVC</a>
 809                     framework will make web development something you had
 810                     never expected it to be: Fun, rewarding, and quick.</p>
 811                  <h2>What to do now?</h2>
 812                  <p>That really depends  on what <b>you</b> want to do.
 813                     We do, however, provide you with a few starting points.</p>
 814                  <p>If you want to jump right into web development with Catalyst
 815                     you might want to check out the documentation.</p>
 816                  <pre><code>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst/lib/Catalyst/Manual/Intro.pod">Catalyst::Manual::Intro</a>
 817 perldoc <a href="http://cpansearch.perl.org/dist/Catalyst/lib/Catalyst/Manual/Tutorial.pod">Catalyst::Manual::Tutorial</a></code>
 818 perldoc <a href="http://cpansearch.perl.org/dist/Catalyst/lib/Catalyst/Manual.pod">Catalyst::Manual</a></code></pre>
 819                  <h2>What to do next?</h2>
 820                  <p>Next it's time to write an actual application. Use the
 821                     helper scripts to generate <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AController%3A%3A&amp;mode=all">controllers</a>,
 822                     <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AModel%3A%3A&amp;mode=all">models</a>, and
 823                     <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AView%3A%3A&amp;mode=all">views</a>;
 824                     they can save you a lot of work.</p>
 825                     <pre><code>script/${prefix}_create.pl -help</code></pre>
 826                     <p>Also, be sure to check out the vast and growing
 827                     collection of <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3APlugin%3A%3A&amp;mode=all">plugins for Catalyst on CPAN</a>;
 828                     you are likely to find what you need there.
 829                     </p>
 830
 831                  <h2>Need help?</h2>
 832                  <p>Catalyst has a very active community. Here are the main places to
 833                     get in touch with us.</p>
 834                  <ul>
 835                      <li>
 836                          <a href="http://dev.catalyst.perl.org">Wiki</a>
 837                      </li>
 838                      <li>
 839                          <a href="http://lists.rawmode.org/mailman/listinfo/catalyst">Mailing-List</a>
 840                      </li>
 841                      <li>
 842                          <a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
 843                      </li>
 844                  </ul>
 845                  <h2>In conclusion</h2>
 846                  <p>The Catalyst team hopes you will enjoy using Catalyst as much
 847                     as we enjoyed making it. Please contact us if you have ideas
 848                     for improvement or other feedback.</p>
 849              </div>
 850          </div>
 851     </body>
 852 </html>
 853 EOF
 854 }
 855
 856 =head1 INTERNAL METHODS
 857
 858 These methods are not meant to be used by end users.
 859
 860 =head2 $c->components
 861
 862 Returns a hash of components.
 863
 864 =head2 $c->context_class
 865
 866 Returns or sets the context class.
 867
 868 =head2 $c->counter
 869
 870 Returns a hashref containing coderefs and execution counts (needed for
 871 deep recursion detection).
 872
 873 =head2 $c->depth
 874
 875 Returns the number of actions on the current internal execution stack.
 876
 877 =head2 $c->dispatch
 878
 879 Dispatches a request to actions.
 880
 881 =cut
 882
 883 sub dispatch { my $c = shift; $c->dispatcher->dispatch( $c, @_ ) }
 884
 885 =head2 $c->dispatcher_class
 886
 887 Returns or sets the dispatcher class.
 888
 889 =head2 $c->dump_these
 890
 891 Returns a list of 2-element array references (name, structure) pairs
 892 that will be dumped on the error page in debug mode.
 893
 894 =cut
 895
 896 sub dump_these {
 897     my $c = shift;
 898     [ Request => $c->req ], [ Response => $c->res ], [ Stash => $c->stash ],;
 899 }
 900
 901 =head2 $c->engine_class
 902
 903 Returns or sets the engine class.
 904
 905 =head2 $c->execute( $class, $coderef )
 906
 907 Execute a coderef in given class and catch exceptions. Errors are available
 908 via $c->error.
 909
 910 =cut
 911
 912 sub execute {
 913     my ( $c, $class, $code ) = @_;
 914     $class = $c->component($class) || $class;
 915     $c->state(0);
 916
 917     if ( $c->debug ) {
 918         my $action = "$code";
 919         $action = "/$action" unless $action =~ /\-\>/;
 920         $c->counter->{"$code"}++;
 921
 922         if ( $c->counter->{"$code"} > $RECURSION ) {
 923             my $error = qq/Deep recursion detected in "$action"/;
 924             $c->log->error($error);
 925             $c->error($error);
 926             $c->state(0);
 927             return $c->state;
 928         }
 929
 930         # determine if the call was the result of a forward
 931         # this is done by walking up the call stack and looking for a calling
 932         # sub of Catalyst::forward before the eval
 933         my $callsub = q{};
 934         for my $index ( 1 .. 10 ) {
 935             last
 936               if ( ( caller($index) )[0] eq 'Catalyst'
 937                 && ( caller($index) )[3] eq '(eval)' );
 938
 939             if ( ( caller($index) )[3] =~ /forward$/ ) {
 940                 $callsub = ( caller($index) )[3];
 941                 $action  = "-> $action";
 942                 last;
 943             }
 944         }
 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->can('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", "COMPONENT() 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;