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