lib/Catalyst.pm

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