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