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