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