lib/Catalyst.pm

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