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