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