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     my $callsub =
 896         ( caller(0) )[0]->isa('Catalyst::Action')
 897       ? ( caller(2) )[3]
 898       : ( caller(1) )[3];
 899
 900     my $action = '';
 901
 902     if ( $c->debug ) {
 903         $action = "$code";
 904         $action = "/$action" unless $action =~ /\-\>/;
 905         $c->counter->{"$code"}++;
 906
 907         if ( $c->counter->{"$code"} > $RECURSION ) {
 908             my $error = qq/Deep recursion detected in "$action"/;
 909             $c->log->error($error);
 910             $c->error($error);
 911             $c->state(0);
 912             return $c->state;
 913         }
 914
 915         $action = "-> $action" if $callsub =~ /forward$/;
 916
 917         my $node = Tree::Simple->new( {
 918             action  => $action,
 919             elapsed => undef,       # to be filled in later
 920         } );
 921         $node->setUID( "$code" . $c->counter->{"$code"} );
 922
 923         unless ( ( $code->name =~ /^_.*/ )
 924             && ( !$c->config->{show_internal_actions} ) )
 925         {
 926             # is this a root-level call or a forwarded call?
 927             if ( $callsub =~ /forward$/ ) {
 928
 929                 # forward, locate the caller
 930                 if ( my $parent = $c->stack->[-1] ) {
 931                     my $visitor = Tree::Simple::Visitor::FindByUID->new;
 932                     $visitor->searchForUID(
 933                         "$parent" . $c->counter->{"$parent"} );
 934                     $c->{stats}->accept( $visitor );
 935                     if ( my $result = $visitor->getResult ) {
 936                         $result->addChild( $node );
 937                     }
 938                 }
 939                 else {
 940                     # forward with no caller may come from a plugin
 941                     $c->{stats}->addChild( $node );
 942                 }
 943             }
 944             else {
 945                 # root-level call
 946                 $c->{stats}->addChild( $node );
 947             }
 948         }
 949     }
 950
 951     push( @{ $c->stack }, $code );
 952     my $elapsed = 0;
 953     my $start   = 0;
 954     $start = [gettimeofday] if $c->debug;
 955     eval { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) };
 956     $elapsed = tv_interval($start) if $c->debug;
 957
 958     if ( $c->debug ) {
 959         unless ( ( $code->name =~ /^_.*/ )
 960             && ( !$c->config->{show_internal_actions} ) )
 961         {
 962             # FindByUID uses an internal die, so we save the existing error
 963             my $error = $@;
 964
 965             # locate the node in the tree and update the elapsed time
 966             my $visitor = Tree::Simple::Visitor::FindByUID->new;
 967             $visitor->searchForUID( "$code" . $c->counter->{"$code"} );
 968             $c->{stats}->accept( $visitor );
 969             if ( my $result = $visitor->getResult ) {
 970                 my $value = $result->getNodeValue;
 971                 $value->{elapsed} = sprintf( '%fs', $elapsed );
 972                 $result->setNodeValue( $value );
 973             }
 974
 975             # restore error
 976             $@ = $error || undef;
 977         }
 978     }
 979     my $last = ${ $c->stack }[-1];
 980     pop( @{ $c->stack } );
 981
 982     if ( my $error = $@ ) {
 983         if ( $error eq $DETACH ) { die $DETACH if $c->depth > 1 }
 984         else {
 985             unless ( ref $error ) {
 986                 chomp $error;
 987                 my $class = $last->class;
 988                 my $name  = $last->name;
 989                 $error = qq/Caught exception in $class->$name "$error"/;
 990             }
 991             $c->error($error);
 992             $c->state(0);
 993         }
 994     }
 995     return $c->state;
 996 }
 997
 998 =head2 $c->finalize
 999
1000 Finalizes the request.
1001
1002 =cut
1003
1004 sub finalize {
1005     my $c = shift;
1006
1007     for my $error ( @{ $c->error } ) {
1008         $c->log->error($error);
1009     }
1010
1011     $c->finalize_uploads;
1012
1013     # Error
1014     if ( $#{ $c->error } >= 0 ) {
1015         $c->finalize_error;
1016     }
1017
1018     $c->finalize_headers;
1019
1020     # HEAD request
1021     if ( $c->request->method eq 'HEAD' ) {
1022         $c->response->body('');
1023     }
1024
1025     $c->finalize_body;
1026
1027     return $c->response->status;
1028 }
1029
1030 =head2 $c->finalize_body
1031
1032 Finalizes body.
1033
1034 =cut
1035
1036 sub finalize_body { my $c = shift; $c->engine->finalize_body( $c, @_ ) }
1037
1038 =head2 $c->finalize_cookies
1039
1040 Finalizes cookies.
1041
1042 =cut
1043
1044 sub finalize_cookies { my $c = shift; $c->engine->finalize_cookies( $c, @_ ) }
1045
1046 =head2 $c->finalize_error
1047
1048 Finalizes error.
1049
1050 =cut
1051
1052 sub finalize_error { my $c = shift; $c->engine->finalize_error( $c, @_ ) }
1053
1054 =head2 $c->finalize_headers
1055
1056 Finalizes headers.
1057
1058 =cut
1059
1060 sub finalize_headers {
1061     my $c = shift;
1062
1063     # Check if we already finalized headers
1064     return if $c->response->{_finalized_headers};
1065
1066     # Handle redirects
1067     if ( my $location = $c->response->redirect ) {
1068         $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
1069         $c->response->header( Location => $location );
1070     }
1071
1072     # Content-Length
1073     if ( $c->response->body && !$c->response->content_length ) {
1074
1075         # get the length from a filehandle
1076         if ( ref $c->response->body && $c->response->body->can('read') ) {
1077             if ( my $stat = stat $c->response->body ) {
1078                 $c->response->content_length( $stat->size );
1079             }
1080             else {
1081                 $c->log->warn('Serving filehandle without a content-length');
1082             }
1083         }
1084         else {
1085             $c->response->content_length( bytes::length( $c->response->body ) );
1086         }
1087     }
1088
1089     # Errors
1090     if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
1091         $c->response->headers->remove_header("Content-Length");
1092         $c->response->body('');
1093     }
1094
1095     $c->finalize_cookies;
1096
1097     $c->engine->finalize_headers( $c, @_ );
1098
1099     # Done
1100     $c->response->{_finalized_headers} = 1;
1101 }
1102
1103 =head2 $c->finalize_output
1104
1105 An alias for finalize_body.
1106
1107 =head2 $c->finalize_read
1108
1109 Finalizes the input after reading is complete.
1110
1111 =cut
1112
1113 sub finalize_read { my $c = shift; $c->engine->finalize_read( $c, @_ ) }
1114
1115 =head2 $c->finalize_uploads
1116
1117 Finalizes uploads. Cleans up any temporary files.
1118
1119 =cut
1120
1121 sub finalize_uploads { my $c = shift; $c->engine->finalize_uploads( $c, @_ ) }
1122
1123 =head2 $c->get_action( $action, $namespace )
1124
1125 Gets an action in a given namespace.
1126
1127 =cut
1128
1129 sub get_action { my $c = shift; $c->dispatcher->get_action(@_) }
1130
1131 =head2 $c->get_actions( $action, $namespace )
1132
1133 Gets all actions of a given name in a namespace and all parent
1134 namespaces.
1135
1136 =cut
1137
1138 sub get_actions { my $c = shift; $c->dispatcher->get_actions( $c, @_ ) }
1139
1140 =head2 handle_request( $class, @arguments )
1141
1142 Called to handle each HTTP request.
1143
1144 =cut
1145
1146 sub handle_request {
1147     my ( $class, @arguments ) = @_;
1148
1149     # Always expect worst case!
1150     my $status = -1;
1151     eval {
1152         my $stats = ( $class->debug ) ? Tree::Simple->new : q{};
1153
1154         my $handler = sub {
1155             my $c = $class->prepare(@arguments);
1156             $c->{stats} = $stats;
1157             $c->dispatch;
1158             return $c->finalize;
1159         };
1160
1161         if ( $class->debug ) {
1162             my $start = [gettimeofday];
1163             $status = &$handler;
1164             my $elapsed = tv_interval $start;
1165             $elapsed = sprintf '%f', $elapsed;
1166             my $av = sprintf '%.3f',
1167               ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
1168             my $t = Text::SimpleTable->new( [ 64, 'Action' ], [ 9, 'Time' ] );
1169
1170             $stats->traverse( sub {
1171                 my $action = shift;
1172                 my $stat = $action->getNodeValue;
1173                 $t->row(
1174                     ( q{ } x $action->getDepth ) . $stat->{action},
1175                     $stat->{elapsed} || '??'
1176                 );
1177             } );
1178
1179             $class->log->info(
1180                 "Request took ${elapsed}s ($av/s)\n" . $t->draw );
1181         }
1182         else { $status = &$handler }
1183
1184     };
1185
1186     if ( my $error = $@ ) {
1187         chomp $error;
1188         $class->log->error(qq/Caught exception in engine "$error"/);
1189     }
1190
1191     $COUNT++;
1192     $class->log->_flush() if $class->log->can('_flush');
1193     return $status;
1194 }
1195
1196 =head2 $c->prepare( @arguments )
1197
1198 Creates a Catalyst context from an engine-specific request (Apache, CGI,
1199 etc.).
1200
1201 =cut
1202
1203 sub prepare {
1204     my ( $class, @arguments ) = @_;
1205
1206     $class->context_class( ref $class || $class ) unless $class->context_class;
1207     my $c = $class->context_class->new(
1208         {
1209             counter => {},
1210             stack   => [],
1211             request => $class->request_class->new(
1212                 {
1213                     arguments        => [],
1214                     body_parameters  => {},
1215                     cookies          => {},
1216                     headers          => HTTP::Headers->new,
1217                     parameters       => {},
1218                     query_parameters => {},
1219                     secure           => 0,
1220                     snippets         => [],
1221                     uploads          => {}
1222                 }
1223             ),
1224             response => $class->response_class->new(
1225                 {
1226                     body    => '',
1227                     cookies => {},
1228                     headers => HTTP::Headers->new(),
1229                     status  => 200
1230                 }
1231             ),
1232             stash => {},
1233             state => 0
1234         }
1235     );
1236
1237     # For on-demand data
1238     $c->request->{_context}  = $c;
1239     $c->response->{_context} = $c;
1240     weaken( $c->request->{_context} );
1241     weaken( $c->response->{_context} );
1242
1243     if ( $c->debug ) {
1244         my $secs = time - $START || 1;
1245         my $av = sprintf '%.3f', $COUNT / $secs;
1246         $c->log->debug('**********************************');
1247         $c->log->debug("* Request $COUNT ($av/s) [$$]");
1248         $c->log->debug('**********************************');
1249         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
1250     }
1251
1252     $c->prepare_request(@arguments);
1253     $c->prepare_connection;
1254     $c->prepare_query_parameters;
1255     $c->prepare_headers;
1256     $c->prepare_cookies;
1257     $c->prepare_path;
1258
1259     # On-demand parsing
1260     $c->prepare_body unless $c->config->{parse_on_demand};
1261
1262     my $method  = $c->req->method  || '';
1263     my $path    = $c->req->path    || '';
1264     my $address = $c->req->address || '';
1265
1266     $c->log->debug(qq/"$method" request for "$path" from "$address"/)
1267       if $c->debug;
1268
1269     $c->prepare_action;
1270
1271     return $c;
1272 }
1273
1274 =head2 $c->prepare_action
1275
1276 Prepares action.
1277
1278 =cut
1279
1280 sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
1281
1282 =head2 $c->prepare_body
1283
1284 Prepares message body.
1285
1286 =cut
1287
1288 sub prepare_body {
1289     my $c = shift;
1290
1291     # Do we run for the first time?
1292     return if defined $c->request->{_body};
1293
1294     # Initialize on-demand data
1295     $c->engine->prepare_body( $c, @_ );
1296     $c->prepare_parameters;
1297     $c->prepare_uploads;
1298
1299     if ( $c->debug && keys %{ $c->req->body_parameters } ) {
1300         my $t = Text::SimpleTable->new( [ 37, 'Key' ], [ 36, 'Value' ] );
1301         for my $key ( sort keys %{ $c->req->body_parameters } ) {
1302             my $param = $c->req->body_parameters->{$key};
1303             my $value = defined($param) ? $param : '';
1304             $t->row( $key,
1305                 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1306         }
1307         $c->log->debug( "Body Parameters are:\n" . $t->draw );
1308     }
1309 }
1310
1311 =head2 $c->prepare_body_chunk( $chunk )
1312
1313 Prepares a chunk of data before sending it to L<HTTP::Body>.
1314
1315 =cut
1316
1317 sub prepare_body_chunk {
1318     my $c = shift;
1319     $c->engine->prepare_body_chunk( $c, @_ );
1320 }
1321
1322 =head2 $c->prepare_body_parameters
1323
1324 Prepares body parameters.
1325
1326 =cut
1327
1328 sub prepare_body_parameters {
1329     my $c = shift;
1330     $c->engine->prepare_body_parameters( $c, @_ );
1331 }
1332
1333 =head2 $c->prepare_connection
1334
1335 Prepares connection.
1336
1337 =cut
1338
1339 sub prepare_connection {
1340     my $c = shift;
1341     $c->engine->prepare_connection( $c, @_ );
1342 }
1343
1344 =head2 $c->prepare_cookies
1345
1346 Prepares cookies.
1347
1348 =cut
1349
1350 sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
1351
1352 =head2 $c->prepare_headers
1353
1354 Prepares headers.
1355
1356 =cut
1357
1358 sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
1359
1360 =head2 $c->prepare_parameters
1361
1362 Prepares parameters.
1363
1364 =cut
1365
1366 sub prepare_parameters {
1367     my $c = shift;
1368     $c->prepare_body_parameters;
1369     $c->engine->prepare_parameters( $c, @_ );
1370 }
1371
1372 =head2 $c->prepare_path
1373
1374 Prepares path and base.
1375
1376 =cut
1377
1378 sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
1379
1380 =head2 $c->prepare_query_parameters
1381
1382 Prepares query parameters.
1383
1384 =cut
1385
1386 sub prepare_query_parameters {
1387     my $c = shift;
1388
1389     $c->engine->prepare_query_parameters( $c, @_ );
1390
1391     if ( $c->debug && keys %{ $c->request->query_parameters } ) {
1392         my $t = Text::SimpleTable->new( [ 37, 'Key' ], [ 36, 'Value' ] );
1393         for my $key ( sort keys %{ $c->req->query_parameters } ) {
1394             my $param = $c->req->query_parameters->{$key};
1395             my $value = defined($param) ? $param : '';
1396             $t->row( $key,
1397                 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1398         }
1399         $c->log->debug( "Query Parameters are:\n" . $t->draw );
1400     }
1401 }
1402
1403 =head2 $c->prepare_read
1404
1405 Prepares the input for reading.
1406
1407 =cut
1408
1409 sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
1410
1411 =head2 $c->prepare_request
1412
1413 Prepares the engine request.
1414
1415 =cut
1416
1417 sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
1418
1419 =head2 $c->prepare_uploads
1420
1421 Prepares uploads.
1422
1423 =cut
1424
1425 sub prepare_uploads {
1426     my $c = shift;
1427
1428     $c->engine->prepare_uploads( $c, @_ );
1429
1430     if ( $c->debug && keys %{ $c->request->uploads } ) {
1431         my $t = Text::SimpleTable->new(
1432             [ 12, 'Key' ],
1433             [ 28, 'Filename' ],
1434             [ 18, 'Type' ],
1435             [ 9,  'Size' ]
1436         );
1437         for my $key ( sort keys %{ $c->request->uploads } ) {
1438             my $upload = $c->request->uploads->{$key};
1439             for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
1440                 $t->row( $key, $u->filename, $u->type, $u->size );
1441             }
1442         }
1443         $c->log->debug( "File Uploads are:\n" . $t->draw );
1444     }
1445 }
1446
1447 =head2 $c->prepare_write
1448
1449 Prepares the output for writing.
1450
1451 =cut
1452
1453 sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
1454
1455 =head2 $c->request_class
1456
1457 Returns or sets the request class.
1458
1459 =head2 $c->response_class
1460
1461 Returns or sets the response class.
1462
1463 =head2 $c->read( [$maxlength] )
1464
1465 Reads a chunk of data from the request body. This method is designed to
1466 be used in a while loop, reading C<$maxlength> bytes on every call.
1467 C<$maxlength> defaults to the size of the request if not specified.
1468
1469 You have to set C<MyApp-E<gt>config-E<gt>{parse_on_demand}> to use this
1470 directly.
1471
1472 =cut
1473
1474 sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
1475
1476 =head2 $c->run
1477
1478 Starts the engine.
1479
1480 =cut
1481
1482 sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
1483
1484 =head2 $c->set_action( $action, $code, $namespace, $attrs )
1485
1486 Sets an action in a given namespace.
1487
1488 =cut
1489
1490 sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
1491
1492 =head2 $c->setup_actions($component)
1493
1494 Sets up actions for a component.
1495
1496 =cut
1497
1498 sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
1499
1500 =head2 $c->setup_components
1501
1502 Sets up components.
1503
1504 =cut
1505
1506 sub setup_components {
1507     my $class = shift;
1508
1509     my $callback = sub {
1510         my ( $component, $context ) = @_;
1511
1512         unless ( $component->isa('Catalyst::Component') ) {
1513             return $component;
1514         }
1515
1516         my $suffix = Catalyst::Utils::class2classsuffix($component);
1517         my $config = $class->config->{$suffix} || {};
1518
1519         my $instance;
1520
1521         eval { $instance = $component->new( $context, $config ); };
1522
1523         if ( my $error = $@ ) {
1524
1525             chomp $error;
1526
1527             Catalyst::Exception->throw( message =>
1528                   qq/Couldn't instantiate component "$component", "$error"/ );
1529         }
1530
1531         Catalyst::Exception->throw( message =>
1532 qq/Couldn't instantiate component "$component", "new() didn't return a object"/
1533           )
1534           unless ref $instance;
1535         return $instance;
1536     };
1537
1538     eval "package $class;\n" . q!Module::Pluggable::Fast->import(
1539             name   => '_catalyst_components',
1540             search => [
1541                 "$class\::Controller", "$class\::C",
1542                 "$class\::Model",      "$class\::M",
1543                 "$class\::View",       "$class\::V"
1544             ],
1545             callback => $callback
1546         );
1547     !;
1548
1549     if ( my $error = $@ ) {
1550
1551         chomp $error;
1552
1553         Catalyst::Exception->throw(
1554             message => qq/Couldn't load components "$error"/ );
1555     }
1556
1557     for my $component ( $class->_catalyst_components($class) ) {
1558         $class->components->{ ref $component || $component } = $component;
1559     }
1560 }
1561
1562 =head2 $c->setup_dispatcher
1563
1564 Sets up dispatcher.
1565
1566 =cut
1567
1568 sub setup_dispatcher {
1569     my ( $class, $dispatcher ) = @_;
1570
1571     if ($dispatcher) {
1572         $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
1573     }
1574
1575     if ( $ENV{CATALYST_DISPATCHER} ) {
1576         $dispatcher = 'Catalyst::Dispatcher::' . $ENV{CATALYST_DISPATCHER};
1577     }
1578
1579     if ( $ENV{ uc($class) . '_DISPATCHER' } ) {
1580         $dispatcher =
1581           'Catalyst::Dispatcher::' . $ENV{ uc($class) . '_DISPATCHER' };
1582     }
1583
1584     unless ($dispatcher) {
1585         $dispatcher = $class->dispatcher_class;
1586     }
1587
1588     $dispatcher->require;
1589
1590     if ($@) {
1591         Catalyst::Exception->throw(
1592             message => qq/Couldn't load dispatcher "$dispatcher", "$@"/ );
1593     }
1594
1595     # dispatcher instance
1596     $class->dispatcher( $dispatcher->new );
1597 }
1598
1599 =head2 $c->setup_engine
1600
1601 Sets up engine.
1602
1603 =cut
1604
1605 sub setup_engine {
1606     my ( $class, $engine ) = @_;
1607
1608     if ($engine) {
1609         $engine = 'Catalyst::Engine::' . $engine;
1610     }
1611
1612     if ( $ENV{CATALYST_ENGINE} ) {
1613         $engine = 'Catalyst::Engine::' . $ENV{CATALYST_ENGINE};
1614     }
1615
1616     if ( $ENV{ uc($class) . '_ENGINE' } ) {
1617         $engine = 'Catalyst::Engine::' . $ENV{ uc($class) . '_ENGINE' };
1618     }
1619
1620     if ( $ENV{MOD_PERL} ) {
1621
1622         # create the apache method
1623         {
1624             no strict 'refs';
1625             *{"$class\::apache"} = sub { shift->engine->apache };
1626         }
1627
1628         my ( $software, $version ) =
1629           $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
1630
1631         $version =~ s/_//g;
1632         $version =~ s/(\.[^.]+)\./$1/g;
1633
1634         if ( $software eq 'mod_perl' ) {
1635
1636             if ( !$engine ) {
1637
1638                 if ( $version >= 1.99922 ) {
1639                     $engine = 'Catalyst::Engine::Apache2::MP20';
1640                 }
1641
1642                 elsif ( $version >= 1.9901 ) {
1643                     $engine = 'Catalyst::Engine::Apache2::MP19';
1644                 }
1645
1646                 elsif ( $version >= 1.24 ) {
1647                     $engine = 'Catalyst::Engine::Apache::MP13';
1648                 }
1649
1650                 else {
1651                     Catalyst::Exception->throw( message =>
1652                           qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
1653                 }
1654
1655             }
1656
1657             # install the correct mod_perl handler
1658             if ( $version >= 1.9901 ) {
1659                 *handler = sub  : method {
1660                     shift->handle_request(@_);
1661                 };
1662             }
1663             else {
1664                 *handler = sub ($$) { shift->handle_request(@_) };
1665             }
1666
1667         }
1668
1669         elsif ( $software eq 'Zeus-Perl' ) {
1670             $engine = 'Catalyst::Engine::Zeus';
1671         }
1672
1673         else {
1674             Catalyst::Exception->throw(
1675                 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
1676         }
1677     }
1678
1679     unless ($engine) {
1680         $engine = $class->engine_class;
1681     }
1682
1683     $engine->require;
1684
1685     if ($@) {
1686         Catalyst::Exception->throw( message =>
1687 qq/Couldn't load engine "$engine" (maybe you forgot to install it?), "$@"/
1688         );
1689     }
1690
1691     # check for old engines that are no longer compatible
1692     my $old_engine;
1693     if ( $engine->isa('Catalyst::Engine::Apache')
1694         && !Catalyst::Engine::Apache->VERSION )
1695     {
1696         $old_engine = 1;
1697     }
1698
1699     elsif ( $engine->isa('Catalyst::Engine::Server::Base')
1700         && Catalyst::Engine::Server->VERSION le '0.02' )
1701     {
1702         $old_engine = 1;
1703     }
1704
1705     elsif ($engine->isa('Catalyst::Engine::HTTP::POE')
1706         && $engine->VERSION eq '0.01' )
1707     {
1708         $old_engine = 1;
1709     }
1710
1711     elsif ($engine->isa('Catalyst::Engine::Zeus')
1712         && $engine->VERSION eq '0.01' )
1713     {
1714         $old_engine = 1;
1715     }
1716
1717     if ($old_engine) {
1718         Catalyst::Exception->throw( message =>
1719               qq/Engine "$engine" is not supported by this version of Catalyst/
1720         );
1721     }
1722
1723     # engine instance
1724     $class->engine( $engine->new );
1725 }
1726
1727 =head2 $c->setup_home
1728
1729 Sets up the home directory.
1730
1731 =cut
1732
1733 sub setup_home {
1734     my ( $class, $home ) = @_;
1735
1736     if ( $ENV{CATALYST_HOME} ) {
1737         $home = $ENV{CATALYST_HOME};
1738     }
1739
1740     if ( $ENV{ uc($class) . '_HOME' } ) {
1741         $home = $ENV{ uc($class) . '_HOME' };
1742     }
1743
1744     unless ($home) {
1745         $home = Catalyst::Utils::home($class);
1746     }
1747
1748     if ($home) {
1749         $class->config->{home} ||= $home;
1750         $class->config->{root} ||= dir($home)->subdir('root');
1751     }
1752 }
1753
1754 =head2 $c->setup_log
1755
1756 Sets up log.
1757
1758 =cut
1759
1760 sub setup_log {
1761     my ( $class, $debug ) = @_;
1762
1763     unless ( $class->log ) {
1764         $class->log( Catalyst::Log->new );
1765     }
1766
1767     my $app_flag = Catalyst::Utils::class2env($class) . '_DEBUG';
1768
1769     if (
1770           ( defined( $ENV{CATALYST_DEBUG} ) || defined( $ENV{$app_flag} ) )
1771         ? ( $ENV{CATALYST_DEBUG} || $ENV{$app_flag} )
1772         : $debug
1773       )
1774     {
1775         no strict 'refs';
1776         *{"$class\::debug"} = sub { 1 };
1777         $class->log->debug('Debug messages enabled');
1778     }
1779 }
1780
1781 =head2 $c->setup_plugins
1782
1783 Sets up plugins.
1784
1785 =cut
1786
1787 sub setup_plugins {
1788     my ( $class, $plugins ) = @_;
1789
1790     $plugins ||= [];
1791     for my $plugin ( reverse @$plugins ) {
1792
1793         $plugin = "Catalyst::Plugin::$plugin";
1794
1795         $plugin->require;
1796
1797         if ($@) {
1798             Catalyst::Exception->throw(
1799                 message => qq/Couldn't load plugin "$plugin", "$@"/ );
1800         }
1801
1802         {
1803             no strict 'refs';
1804             unshift @{"$class\::ISA"}, $plugin;
1805         }
1806     }
1807 }
1808
1809 =head2 $c->stack
1810
1811 Returns the stack.
1812
1813 =head2 $c->write( $data )
1814
1815 Writes $data to the output stream. When using this method directly, you
1816 will need to manually set the C<Content-Length> header to the length of
1817 your output data, if known.
1818
1819 =cut
1820
1821 sub write {
1822     my $c = shift;
1823
1824     # Finalize headers if someone manually writes output
1825     $c->finalize_headers;
1826
1827     return $c->engine->write( $c, @_ );
1828 }
1829
1830 =head2 version
1831
1832 Returns the Catalyst version number. Mostly useful for "powered by"
1833 messages in template systems.
1834
1835 =cut
1836
1837 sub version { return $Catalyst::VERSION }
1838
1839 =head1 INTERNAL ACTIONS
1840
1841 Catalyst uses internal actions like C<_DISPATCH>, C<_BEGIN>, C<_AUTO>,
1842 C<_ACTION>, and C<_END>. These are by default not shown in the private
1843 action table, but you can make them visible with a config parameter.
1844
1845     MyApp->config->{show_internal_actions} = 1;
1846
1847 =head1 CASE SENSITIVITY
1848
1849 By default Catalyst is not case sensitive, so C<MyApp::C::FOO::Bar> is
1850 mapped to C</foo/bar>. You can activate case sensitivity with a config
1851 parameter.
1852
1853     MyApp->config->{case_sensitive} = 1;
1854
1855 This causes C<MyApp::C::Foo::Bar> to map to C</Foo/Bar>.
1856
1857 =head1 ON-DEMAND PARSER
1858
1859 The request body is usually parsed at the beginning of a request,
1860 but if you want to handle input yourself or speed things up a bit,
1861 you can enable on-demand parsing with a config parameter.
1862
1863     MyApp->config->{parse_on_demand} = 1;
1864
1865 =head1 PROXY SUPPORT
1866
1867 Many production servers operate using the common double-server approach,
1868 with a lightweight frontend web server passing requests to a larger
1869 backend server. An application running on the backend server must deal
1870 with two problems: the remote user always appears to be C<127.0.0.1> and
1871 the server's hostname will appear to be C<localhost> regardless of the
1872 virtual host that the user connected through.
1873
1874 Catalyst will automatically detect this situation when you are running
1875 the frontend and backend servers on the same machine. The following
1876 changes are made to the request.
1877
1878     $c->req->address is set to the user's real IP address, as read from
1879     the HTTP X-Forwarded-For header.
1880
1881     The host value for $c->req->base and $c->req->uri is set to the real
1882     host, as read from the HTTP X-Forwarded-Host header.
1883
1884 Obviously, your web server must support these headers for this to work.
1885
1886 In a more complex server farm environment where you may have your
1887 frontend proxy server(s) on different machines, you will need to set a
1888 configuration option to tell Catalyst to read the proxied data from the
1889 headers.
1890
1891     MyApp->config->{using_frontend_proxy} = 1;
1892
1893 If you do not wish to use the proxy support at all, you may set:
1894
1895     MyApp->config->{ignore_frontend_proxy} = 1;
1896
1897 =head1 THREAD SAFETY
1898
1899 Catalyst has been tested under Apache 2's threading mpm_worker, mpm_winnt,
1900 and the standalone forking HTTP server on Windows. We believe the Catalyst
1901 core to be thread-safe.
1902
1903 If you plan to operate in a threaded environment, remember that all other
1904 modules you are using must also be thread-safe. Some modules, most notably
1905 L<DBD::SQLite>, are not thread-safe.
1906
1907 =head1 SUPPORT
1908
1909 IRC:
1910
1911     Join #catalyst on irc.perl.org.
1912
1913 Mailing Lists:
1914
1915     http://lists.rawmode.org/mailman/listinfo/catalyst
1916     http://lists.rawmode.org/mailman/listinfo/catalyst-dev
1917
1918 Web:
1919
1920     http://catalyst.perl.org
1921
1922 Wiki:
1923
1924     http://dev.catalyst.perl.org
1925
1926 =head1 SEE ALSO
1927
1928 =head2 L<Task::Catalyst> - All you need to start with Catalyst
1929
1930 =head2 L<Catalyst::Manual> - The Catalyst Manual
1931
1932 =head2 L<Catalyst::Component>, L<Catalyst::Base> - Base classes for components
1933
1934 =head2 L<Catalyst::Engine> - Core engine
1935
1936 =head2 L<Catalyst::Log> - Log class.
1937
1938 =head2 L<Catalyst::Request> - Request object
1939
1940 =head2 L<Catalyst::Response> - Response object
1941
1942 =head2 L<Catalyst::Test> - The test suite.
1943
1944 =head1 CREDITS
1945
1946 Andy Grundman
1947
1948 Andy Wardley
1949
1950 Andreas Marienborg
1951
1952 Andrew Bramble
1953
1954 Andrew Ford
1955
1956 Andrew Ruthven
1957
1958 Arthur Bergman
1959
1960 Autrijus Tang
1961
1962 Brian Cassidy
1963
1964 Christian Hansen
1965
1966 Christopher Hicks
1967
1968 Dan Sully
1969
1970 Danijel Milicevic
1971
1972 David Kamholz
1973
1974 David Naughton
1975
1976 Drew Taylor
1977
1978 Gary Ashton Jones
1979
1980 Geoff Richards
1981
1982 Jesse Sheidlower
1983
1984 Jesse Vincent
1985
1986 Jody Belka
1987
1988 Johan Lindstrom
1989
1990 Juan Camacho
1991
1992 Leon Brocard
1993
1994 Marcus Ramberg
1995
1996 Matt S Trout
1997
1998 Robert Sedlacek
1999
2000 Sam Vilain
2001
2002 Sascha Kiefer
2003
2004 Tatsuhiko Miyagawa
2005
2006 Ulf Edvinsson
2007
2008 Yuval Kogman
2009
2010 =head1 AUTHOR
2011
2012 Sebastian Riedel, C<sri@oook.de>
2013
2014 =head1 LICENSE
2015
2016 This library is free software, you can redistribute it and/or modify it under
2017 the same terms as Perl itself.
2018
2019 =cut
2020
2021 1;