lib/Catalyst.pm

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