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