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