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 stats/
  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     my $stats_info = $c->_stats_start_execute( $code );
1094
1095     push( @{ $c->stack }, $code );
1096
1097     eval { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) };
1098
1099     $c->_stats_finish_execute( $stats_info );
1100
1101     my $last = ${ $c->stack }[-1];
1102     pop( @{ $c->stack } );
1103
1104     if ( my $error = $@ ) {
1105         if ( $error eq $DETACH ) { die $DETACH if $c->depth > 1 }
1106         else {
1107             unless ( ref $error ) {
1108                 chomp $error;
1109                 my $class = $last->class;
1110                 my $name  = $last->name;
1111                 $error = qq/Caught exception in $class->$name "$error"/;
1112             }
1113             $c->error($error);
1114             $c->state(0);
1115         }
1116     }
1117     return $c->state;
1118 }
1119
1120 sub _stats_start_execute {
1121     my ( $c, $code ) = @_;
1122
1123     return unless $c->debug;
1124
1125     my $action = "$code";
1126
1127     $action = "/$action" unless $action =~ /\-\>/;
1128     $c->counter->{"$code"}++;
1129
1130     # determine if the call was the result of a forward
1131     # this is done by walking up the call stack and looking for a calling
1132     # sub of Catalyst::forward before the eval
1133     my $callsub = q{};
1134     for my $index ( 2 .. 11 ) {
1135         last
1136         if ( ( caller($index) )[0] eq 'Catalyst'
1137             && ( caller($index) )[3] eq '(eval)' );
1138
1139         if ( ( caller($index) )[3] =~ /forward$/ ) {
1140             $callsub = ( caller($index) )[3];
1141             $action  = "-> $action";
1142             last;
1143         }
1144     }
1145
1146     my $node = Tree::Simple->new(
1147         {
1148             action  => $action,
1149             elapsed => undef,     # to be filled in later
1150             comment => "",
1151         }
1152     );
1153     $node->setUID( "$code" . $c->counter->{"$code"} );
1154
1155     unless ( ( $code->name =~ /^_.*/ )
1156         && ( !$c->config->{show_internal_actions} ) )
1157     {
1158         # is this a root-level call or a forwarded call?
1159         if ( $callsub =~ /forward$/ ) {
1160
1161             # forward, locate the caller
1162             if ( my $parent = $c->stack->[-1] ) {
1163                 my $visitor = Tree::Simple::Visitor::FindByUID->new;
1164                 $visitor->searchForUID(
1165                     "$parent" . $c->counter->{"$parent"} );
1166                 $c->stats->accept($visitor);
1167                 if ( my $result = $visitor->getResult ) {
1168                     $result->addChild($node);
1169                 }
1170             }
1171             else {
1172
1173                 # forward with no caller may come from a plugin
1174                 $c->stats->addChild($node);
1175             }
1176         }
1177         else {
1178
1179             # root-level call
1180             $c->stats->addChild($node);
1181         }
1182     }
1183
1184     my $start = [gettimeofday];
1185     my $elapsed = tv_interval($start);
1186
1187     return {
1188         code    => $code,
1189         elapsed => $elapsed,
1190         start   => $start,
1191         node    => $node,
1192       }
1193 }
1194
1195 sub _stats_finish_execute {
1196     my ( $c, $info ) = @_;
1197
1198     return unless $c->debug;
1199
1200     my ( $code, $start, $elapsed ) = @{ $info }{qw/code start elapsed/};
1201
1202     unless ( ( $code->name =~ /^_.*/ )
1203         && ( !$c->config->{show_internal_actions} ) )
1204     {
1205
1206         # FindByUID uses an internal die, so we save the existing error
1207         my $error = $@;
1208
1209         # locate the node in the tree and update the elapsed time
1210         my $visitor = Tree::Simple::Visitor::FindByUID->new;
1211         $visitor->searchForUID( "$code" . $c->counter->{"$code"} );
1212         $c->stats->accept($visitor);
1213         if ( my $result = $visitor->getResult ) {
1214             my $value = $result->getNodeValue;
1215             $value->{elapsed} = sprintf( '%fs', $elapsed );
1216             $result->setNodeValue($value);
1217         }
1218
1219         # restore error
1220         $@ = $error || undef;
1221     }
1222 }
1223
1224 =head2 $c->_localize_fields( sub { }, \%keys );
1225
1226 =cut
1227
1228 sub _localize_fields {
1229     my ( $c, $localized, $code ) = ( @_ );
1230
1231     my $request = delete $localized->{request} || {};
1232     my $response = delete $localized->{response} || {};
1233
1234     local @{ $c }{ keys %$localized } = values %$localized;
1235     local @{ $c->request }{ keys %$request } = values %$request;
1236     local @{ $c->response }{ keys %$response } = values %$response;
1237
1238     $code->();
1239 }
1240
1241 =head2 $c->finalize
1242
1243 Finalizes the request.
1244
1245 =cut
1246
1247 sub finalize {
1248     my $c = shift;
1249
1250     for my $error ( @{ $c->error } ) {
1251         $c->log->error($error);
1252     }
1253
1254     # Allow engine to handle finalize flow (for POE)
1255     if ( $c->engine->can('finalize') ) {
1256         $c->engine->finalize( $c );
1257     }
1258     else {
1259
1260         $c->finalize_uploads;
1261
1262         # Error
1263         if ( $#{ $c->error } >= 0 ) {
1264             $c->finalize_error;
1265         }
1266
1267         $c->finalize_headers;
1268
1269         # HEAD request
1270         if ( $c->request->method eq 'HEAD' ) {
1271             $c->response->body('');
1272         }
1273
1274         $c->finalize_body;
1275     }
1276
1277     return $c->response->status;
1278 }
1279
1280 =head2 $c->finalize_body
1281
1282 Finalizes body.
1283
1284 =cut
1285
1286 sub finalize_body { my $c = shift; $c->engine->finalize_body( $c, @_ ) }
1287
1288 =head2 $c->finalize_cookies
1289
1290 Finalizes cookies.
1291
1292 =cut
1293
1294 sub finalize_cookies { my $c = shift; $c->engine->finalize_cookies( $c, @_ ) }
1295
1296 =head2 $c->finalize_error
1297
1298 Finalizes error.
1299
1300 =cut
1301
1302 sub finalize_error { my $c = shift; $c->engine->finalize_error( $c, @_ ) }
1303
1304 =head2 $c->finalize_headers
1305
1306 Finalizes headers.
1307
1308 =cut
1309
1310 sub finalize_headers {
1311     my $c = shift;
1312
1313     # Check if we already finalized headers
1314     return if $c->response->{_finalized_headers};
1315
1316     # Handle redirects
1317     if ( my $location = $c->response->redirect ) {
1318         $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
1319         $c->response->header( Location => $location );
1320     }
1321
1322     # Content-Length
1323     if ( $c->response->body && !$c->response->content_length ) {
1324
1325         # get the length from a filehandle
1326         if ( blessed( $c->response->body ) && $c->response->body->can('read') )
1327         {
1328             if ( my $stat = stat $c->response->body ) {
1329                 $c->response->content_length( $stat->size );
1330             }
1331             else {
1332                 $c->log->warn('Serving filehandle without a content-length');
1333             }
1334         }
1335         else {
1336             $c->response->content_length( bytes::length( $c->response->body ) );
1337         }
1338     }
1339
1340     # Errors
1341     if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
1342         $c->response->headers->remove_header("Content-Length");
1343         $c->response->body('');
1344     }
1345
1346     $c->finalize_cookies;
1347
1348     $c->engine->finalize_headers( $c, @_ );
1349
1350     # Done
1351     $c->response->{_finalized_headers} = 1;
1352 }
1353
1354 =head2 $c->finalize_output
1355
1356 An alias for finalize_body.
1357
1358 =head2 $c->finalize_read
1359
1360 Finalizes the input after reading is complete.
1361
1362 =cut
1363
1364 sub finalize_read { my $c = shift; $c->engine->finalize_read( $c, @_ ) }
1365
1366 =head2 $c->finalize_uploads
1367
1368 Finalizes uploads. Cleans up any temporary files.
1369
1370 =cut
1371
1372 sub finalize_uploads { my $c = shift; $c->engine->finalize_uploads( $c, @_ ) }
1373
1374 =head2 $c->get_action( $action, $namespace )
1375
1376 Gets an action in a given namespace.
1377
1378 =cut
1379
1380 sub get_action { my $c = shift; $c->dispatcher->get_action(@_) }
1381
1382 =head2 $c->get_actions( $action, $namespace )
1383
1384 Gets all actions of a given name in a namespace and all parent
1385 namespaces.
1386
1387 =cut
1388
1389 sub get_actions { my $c = shift; $c->dispatcher->get_actions( $c, @_ ) }
1390
1391 =head2 $c->handle_request( $class, @arguments )
1392
1393 Called to handle each HTTP request.
1394
1395 =cut
1396
1397 sub handle_request {
1398     my ( $class, @arguments ) = @_;
1399
1400     # Always expect worst case!
1401     my $status = -1;
1402     eval {
1403         my $stats = ( $class->debug ) ? Tree::Simple->new: q{};
1404
1405         my $handler = sub {
1406             my $c = $class->prepare(@arguments);
1407             $c->stats($stats);
1408             $c->dispatch;
1409             return $c->finalize;
1410         };
1411
1412         if ( $class->debug ) {
1413             my $start = [gettimeofday];
1414             $status = &$handler;
1415             my $elapsed = tv_interval $start;
1416             $elapsed = sprintf '%f', $elapsed;
1417             my $av = sprintf '%.3f',
1418               ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
1419             my $t = Text::SimpleTable->new( [ 64, 'Action' ], [ 9, 'Time' ] );
1420
1421             $stats->traverse(
1422                 sub {
1423                     my $action = shift;
1424                     my $stat   = $action->getNodeValue;
1425                     $t->row( ( q{ } x $action->getDepth ) . $stat->{action} . $stat->{comment},
1426                         $stat->{elapsed} || '??' );
1427                 }
1428             );
1429
1430             $class->log->info(
1431                 "Request took ${elapsed}s ($av/s)\n" . $t->draw );
1432         }
1433         else { $status = &$handler }
1434
1435     };
1436
1437     if ( my $error = $@ ) {
1438         chomp $error;
1439         $class->log->error(qq/Caught exception in engine "$error"/);
1440     }
1441
1442     $COUNT++;
1443     $class->log->_flush() if $class->log->can('_flush');
1444     return $status;
1445 }
1446
1447 =head2 $c->prepare( @arguments )
1448
1449 Creates a Catalyst context from an engine-specific request (Apache, CGI,
1450 etc.).
1451
1452 =cut
1453
1454 sub prepare {
1455     my ( $class, @arguments ) = @_;
1456
1457     $class->context_class( ref $class || $class ) unless $class->context_class;
1458     my $c = $class->context_class->new(
1459         {
1460             counter => {},
1461             stack   => [],
1462             request => $class->request_class->new(
1463                 {
1464                     arguments        => [],
1465                     body_parameters  => {},
1466                     cookies          => {},
1467                     headers          => HTTP::Headers->new,
1468                     parameters       => {},
1469                     query_parameters => {},
1470                     secure           => 0,
1471                     snippets         => [],
1472                     uploads          => {}
1473                 }
1474             ),
1475             response => $class->response_class->new(
1476                 {
1477                     body    => '',
1478                     cookies => {},
1479                     headers => HTTP::Headers->new(),
1480                     status  => 200
1481                 }
1482             ),
1483             stash => {},
1484             state => 0
1485         }
1486     );
1487
1488     # For on-demand data
1489     $c->request->{_context}  = $c;
1490     $c->response->{_context} = $c;
1491     weaken( $c->request->{_context} );
1492     weaken( $c->response->{_context} );
1493
1494     if ( $c->debug ) {
1495         my $secs = time - $START || 1;
1496         my $av = sprintf '%.3f', $COUNT / $secs;
1497         $c->log->debug('**********************************');
1498         $c->log->debug("* Request $COUNT ($av/s) [$$]");
1499         $c->log->debug('**********************************');
1500         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
1501     }
1502
1503     # Allow engine to direct the prepare flow (for POE)
1504     if ( $c->engine->can('prepare') ) {
1505         $c->engine->prepare( $c, @arguments );
1506     }
1507     else {
1508         $c->prepare_request(@arguments);
1509         $c->prepare_connection;
1510         $c->prepare_query_parameters;
1511         $c->prepare_headers;
1512         $c->prepare_cookies;
1513         $c->prepare_path;
1514
1515         # On-demand parsing
1516         $c->prepare_body unless $c->config->{parse_on_demand};
1517     }
1518
1519     my $method  = $c->req->method  || '';
1520     my $path    = $c->req->path    || '';
1521     my $address = $c->req->address || '';
1522
1523     $c->log->debug(qq/"$method" request for "$path" from "$address"/)
1524       if $c->debug;
1525
1526     $c->prepare_action;
1527
1528     return $c;
1529 }
1530
1531 =head2 $c->prepare_action
1532
1533 Prepares action.
1534
1535 =cut
1536
1537 sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) }
1538
1539 =head2 $c->prepare_body
1540
1541 Prepares message body.
1542
1543 =cut
1544
1545 sub prepare_body {
1546     my $c = shift;
1547
1548     # Do we run for the first time?
1549     return if defined $c->request->{_body};
1550
1551     # Initialize on-demand data
1552     $c->engine->prepare_body( $c, @_ );
1553     $c->prepare_parameters;
1554     $c->prepare_uploads;
1555
1556     if ( $c->debug && keys %{ $c->req->body_parameters } ) {
1557         my $t = Text::SimpleTable->new( [ 37, 'Key' ], [ 36, 'Value' ] );
1558         for my $key ( sort keys %{ $c->req->body_parameters } ) {
1559             my $param = $c->req->body_parameters->{$key};
1560             my $value = defined($param) ? $param : '';
1561             $t->row( $key,
1562                 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1563         }
1564         $c->log->debug( "Body Parameters are:\n" . $t->draw );
1565     }
1566 }
1567
1568 =head2 $c->prepare_body_chunk( $chunk )
1569
1570 Prepares a chunk of data before sending it to L<HTTP::Body>.
1571
1572 =cut
1573
1574 sub prepare_body_chunk {
1575     my $c = shift;
1576     $c->engine->prepare_body_chunk( $c, @_ );
1577 }
1578
1579 =head2 $c->prepare_body_parameters
1580
1581 Prepares body parameters.
1582
1583 =cut
1584
1585 sub prepare_body_parameters {
1586     my $c = shift;
1587     $c->engine->prepare_body_parameters( $c, @_ );
1588 }
1589
1590 =head2 $c->prepare_connection
1591
1592 Prepares connection.
1593
1594 =cut
1595
1596 sub prepare_connection {
1597     my $c = shift;
1598     $c->engine->prepare_connection( $c, @_ );
1599 }
1600
1601 =head2 $c->prepare_cookies
1602
1603 Prepares cookies.
1604
1605 =cut
1606
1607 sub prepare_cookies { my $c = shift; $c->engine->prepare_cookies( $c, @_ ) }
1608
1609 =head2 $c->prepare_headers
1610
1611 Prepares headers.
1612
1613 =cut
1614
1615 sub prepare_headers { my $c = shift; $c->engine->prepare_headers( $c, @_ ) }
1616
1617 =head2 $c->prepare_parameters
1618
1619 Prepares parameters.
1620
1621 =cut
1622
1623 sub prepare_parameters {
1624     my $c = shift;
1625     $c->prepare_body_parameters;
1626     $c->engine->prepare_parameters( $c, @_ );
1627 }
1628
1629 =head2 $c->prepare_path
1630
1631 Prepares path and base.
1632
1633 =cut
1634
1635 sub prepare_path { my $c = shift; $c->engine->prepare_path( $c, @_ ) }
1636
1637 =head2 $c->prepare_query_parameters
1638
1639 Prepares query parameters.
1640
1641 =cut
1642
1643 sub prepare_query_parameters {
1644     my $c = shift;
1645
1646     $c->engine->prepare_query_parameters( $c, @_ );
1647
1648     if ( $c->debug && keys %{ $c->request->query_parameters } ) {
1649         my $t = Text::SimpleTable->new( [ 37, 'Key' ], [ 36, 'Value' ] );
1650         for my $key ( sort keys %{ $c->req->query_parameters } ) {
1651             my $param = $c->req->query_parameters->{$key};
1652             my $value = defined($param) ? $param : '';
1653             $t->row( $key,
1654                 ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
1655         }
1656         $c->log->debug( "Query Parameters are:\n" . $t->draw );
1657     }
1658 }
1659
1660 =head2 $c->prepare_read
1661
1662 Prepares the input for reading.
1663
1664 =cut
1665
1666 sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
1667
1668 =head2 $c->prepare_request
1669
1670 Prepares the engine request.
1671
1672 =cut
1673
1674 sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
1675
1676 =head2 $c->prepare_uploads
1677
1678 Prepares uploads.
1679
1680 =cut
1681
1682 sub prepare_uploads {
1683     my $c = shift;
1684
1685     $c->engine->prepare_uploads( $c, @_ );
1686
1687     if ( $c->debug && keys %{ $c->request->uploads } ) {
1688         my $t = Text::SimpleTable->new(
1689             [ 12, 'Key' ],
1690             [ 28, 'Filename' ],
1691             [ 18, 'Type' ],
1692             [ 9,  'Size' ]
1693         );
1694         for my $key ( sort keys %{ $c->request->uploads } ) {
1695             my $upload = $c->request->uploads->{$key};
1696             for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
1697                 $t->row( $key, $u->filename, $u->type, $u->size );
1698             }
1699         }
1700         $c->log->debug( "File Uploads are:\n" . $t->draw );
1701     }
1702 }
1703
1704 =head2 $c->prepare_write
1705
1706 Prepares the output for writing.
1707
1708 =cut
1709
1710 sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
1711
1712 =head2 $c->request_class
1713
1714 Returns or sets the request class.
1715
1716 =head2 $c->response_class
1717
1718 Returns or sets the response class.
1719
1720 =head2 $c->read( [$maxlength] )
1721
1722 Reads a chunk of data from the request body. This method is designed to
1723 be used in a while loop, reading C<$maxlength> bytes on every call.
1724 C<$maxlength> defaults to the size of the request if not specified.
1725
1726 You have to set C<MyApp-E<gt>config-E<gt>{parse_on_demand}> to use this
1727 directly.
1728
1729 =cut
1730
1731 sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
1732
1733 =head2 $c->run
1734
1735 Starts the engine.
1736
1737 =cut
1738
1739 sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
1740
1741 =head2 $c->set_action( $action, $code, $namespace, $attrs )
1742
1743 Sets an action in a given namespace.
1744
1745 =cut
1746
1747 sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
1748
1749 =head2 $c->setup_actions($component)
1750
1751 Sets up actions for a component.
1752
1753 =cut
1754
1755 sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
1756
1757 =head2 $c->setup_components
1758
1759 Sets up components.
1760
1761 =cut
1762
1763 sub setup_components {
1764     my $class = shift;
1765
1766     my $callback = sub {
1767         my ( $component, $context ) = @_;
1768
1769         unless ( $component->can('COMPONENT') ) {
1770             return $component;
1771         }
1772
1773         my $suffix = Catalyst::Utils::class2classsuffix($component);
1774         my $config = $class->config->{$suffix} || {};
1775
1776         my $instance;
1777
1778         eval { $instance = $component->COMPONENT( $context, $config ); };
1779
1780         if ( my $error = $@ ) {
1781
1782             chomp $error;
1783
1784             Catalyst::Exception->throw( message =>
1785                   qq/Couldn't instantiate component "$component", "$error"/ );
1786         }
1787
1788         Catalyst::Exception->throw( message =>
1789 qq/Couldn't instantiate component "$component", "COMPONENT() didn't return a object"/
1790           )
1791           unless ref $instance;
1792         return $instance;
1793     };
1794
1795     eval "package $class;\n" . q!Module::Pluggable::Fast->import(
1796             name   => '_catalyst_components',
1797             search => [
1798                 "$class\::Controller", "$class\::C",
1799                 "$class\::Model",      "$class\::M",
1800                 "$class\::View",       "$class\::V"
1801             ],
1802             callback => $callback
1803         );
1804     !;
1805
1806     if ( my $error = $@ ) {
1807
1808         chomp $error;
1809
1810         Catalyst::Exception->throw(
1811             message => qq/Couldn't load components "$error"/ );
1812     }
1813
1814     for my $component ( $class->_catalyst_components($class) ) {
1815         $class->components->{ ref $component || $component } = $component;
1816     }
1817 }
1818
1819 =head2 $c->setup_dispatcher
1820
1821 Sets up dispatcher.
1822
1823 =cut
1824
1825 sub setup_dispatcher {
1826     my ( $class, $dispatcher ) = @_;
1827
1828     if ($dispatcher) {
1829         $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
1830     }
1831
1832     if ( $ENV{CATALYST_DISPATCHER} ) {
1833         $dispatcher = 'Catalyst::Dispatcher::' . $ENV{CATALYST_DISPATCHER};
1834     }
1835
1836     if ( $ENV{ uc($class) . '_DISPATCHER' } ) {
1837         $dispatcher =
1838           'Catalyst::Dispatcher::' . $ENV{ uc($class) . '_DISPATCHER' };
1839     }
1840
1841     unless ($dispatcher) {
1842         $dispatcher = $class->dispatcher_class;
1843     }
1844
1845     $dispatcher->require;
1846
1847     if ($@) {
1848         Catalyst::Exception->throw(
1849             message => qq/Couldn't load dispatcher "$dispatcher", "$@"/ );
1850     }
1851
1852     # dispatcher instance
1853     $class->dispatcher( $dispatcher->new );
1854 }
1855
1856 =head2 $c->setup_engine
1857
1858 Sets up engine.
1859
1860 =cut
1861
1862 sub setup_engine {
1863     my ( $class, $engine ) = @_;
1864
1865     if ($engine) {
1866         $engine = 'Catalyst::Engine::' . $engine;
1867     }
1868
1869     if ( $ENV{CATALYST_ENGINE} ) {
1870         $engine = 'Catalyst::Engine::' . $ENV{CATALYST_ENGINE};
1871     }
1872
1873     if ( $ENV{ uc($class) . '_ENGINE' } ) {
1874         $engine = 'Catalyst::Engine::' . $ENV{ uc($class) . '_ENGINE' };
1875     }
1876
1877     if ( $ENV{MOD_PERL} ) {
1878
1879         # create the apache method
1880         {
1881             no strict 'refs';
1882             *{"$class\::apache"} = sub { shift->engine->apache };
1883         }
1884
1885         my ( $software, $version ) =
1886           $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
1887
1888         $version =~ s/_//g;
1889         $version =~ s/(\.[^.]+)\./$1/g;
1890
1891         if ( $software eq 'mod_perl' ) {
1892
1893             if ( !$engine ) {
1894
1895                 if ( $version >= 1.99922 ) {
1896                     $engine = 'Catalyst::Engine::Apache2::MP20';
1897                 }
1898
1899                 elsif ( $version >= 1.9901 ) {
1900                     $engine = 'Catalyst::Engine::Apache2::MP19';
1901                 }
1902
1903                 elsif ( $version >= 1.24 ) {
1904                     $engine = 'Catalyst::Engine::Apache::MP13';
1905                 }
1906
1907                 else {
1908                     Catalyst::Exception->throw( message =>
1909                           qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
1910                 }
1911
1912             }
1913
1914             # install the correct mod_perl handler
1915             if ( $version >= 1.9901 ) {
1916                 *handler = sub  : method {
1917                     shift->handle_request(@_);
1918                 };
1919             }
1920             else {
1921                 *handler = sub ($$) { shift->handle_request(@_) };
1922             }
1923
1924         }
1925
1926         elsif ( $software eq 'Zeus-Perl' ) {
1927             $engine = 'Catalyst::Engine::Zeus';
1928         }
1929
1930         else {
1931             Catalyst::Exception->throw(
1932                 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
1933         }
1934     }
1935
1936     unless ($engine) {
1937         $engine = $class->engine_class;
1938     }
1939
1940     $engine->require;
1941
1942     if ($@) {
1943         Catalyst::Exception->throw( message =>
1944 qq/Couldn't load engine "$engine" (maybe you forgot to install it?), "$@"/
1945         );
1946     }
1947
1948     # check for old engines that are no longer compatible
1949     my $old_engine;
1950     if ( $engine->isa('Catalyst::Engine::Apache')
1951         && !Catalyst::Engine::Apache->VERSION )
1952     {
1953         $old_engine = 1;
1954     }
1955
1956     elsif ( $engine->isa('Catalyst::Engine::Server::Base')
1957         && Catalyst::Engine::Server->VERSION le '0.02' )
1958     {
1959         $old_engine = 1;
1960     }
1961
1962     elsif ($engine->isa('Catalyst::Engine::HTTP::POE')
1963         && $engine->VERSION eq '0.01' )
1964     {
1965         $old_engine = 1;
1966     }
1967
1968     elsif ($engine->isa('Catalyst::Engine::Zeus')
1969         && $engine->VERSION eq '0.01' )
1970     {
1971         $old_engine = 1;
1972     }
1973
1974     if ($old_engine) {
1975         Catalyst::Exception->throw( message =>
1976               qq/Engine "$engine" is not supported by this version of Catalyst/
1977         );
1978     }
1979
1980     # engine instance
1981     $class->engine( $engine->new );
1982 }
1983
1984 =head2 $c->setup_home
1985
1986 Sets up the home directory.
1987
1988 =cut
1989
1990 sub setup_home {
1991     my ( $class, $home ) = @_;
1992
1993     if ( $ENV{CATALYST_HOME} ) {
1994         $home = $ENV{CATALYST_HOME};
1995     }
1996
1997     if ( $ENV{ uc($class) . '_HOME' } ) {
1998         $home = $ENV{ uc($class) . '_HOME' };
1999     }
2000
2001     unless ($home) {
2002         $home = Catalyst::Utils::home($class);
2003     }
2004
2005     if ($home) {
2006         $class->config->{home} ||= $home;
2007         $class->config->{root} ||= Path::Class::Dir->new($home)->subdir('root');
2008     }
2009 }
2010
2011 =head2 $c->setup_log
2012
2013 Sets up log.
2014
2015 =cut
2016
2017 sub setup_log {
2018     my ( $class, $debug ) = @_;
2019
2020     unless ( $class->log ) {
2021         $class->log( Catalyst::Log->new );
2022     }
2023
2024     my $app_flag = Catalyst::Utils::class2env($class) . '_DEBUG';
2025
2026     if (
2027           ( defined( $ENV{CATALYST_DEBUG} ) || defined( $ENV{$app_flag} ) )
2028         ? ( $ENV{CATALYST_DEBUG} || $ENV{$app_flag} )
2029         : $debug
2030       )
2031     {
2032         no strict 'refs';
2033         *{"$class\::debug"} = sub { 1 };
2034         $class->log->debug('Debug messages enabled');
2035     }
2036 }
2037
2038 =head2 $c->setup_plugins
2039
2040 Sets up plugins.
2041
2042 =cut
2043
2044 =head2 $c->registered_plugins
2045
2046 Returns a sorted list of the plugins which have either been stated in the
2047 import list or which have been added via C<< MyApp->plugin(@args); >>.
2048
2049 If passed a given plugin name, it will report a boolean value indicating
2050 whether or not that plugin is loaded.  A fully qualified name is required if
2051 the plugin name does not begin with C<Catalyst::Plugin::>.
2052
2053  if ($c->registered_plugins('Some::Plugin')) {
2054      ...
2055  }
2056
2057 =cut
2058
2059 {
2060
2061     sub registered_plugins {
2062         my $proto = shift;
2063         return sort keys %{ $proto->_plugins } unless @_;
2064         my $plugin = shift;
2065         return 1 if exists $proto->_plugins->{$plugin};
2066         return exists $proto->_plugins->{"Catalyst::Plugin::$plugin"};
2067     }
2068
2069     sub _register_plugin {
2070         my ( $proto, $plugin, $instant ) = @_;
2071         my $class = ref $proto || $proto;
2072
2073         $plugin->require;
2074
2075         if ( my $error = $@ ) {
2076             my $type = $instant ? "instant " : '';
2077             Catalyst::Exception->throw(
2078                 message => qq/Couldn't load ${type}plugin "$plugin", $error/ );
2079         }
2080
2081         $proto->_plugins->{$plugin} = 1;
2082         unless ($instant) {
2083             no strict 'refs';
2084             unshift @{"$class\::ISA"}, $plugin;
2085         }
2086         return $class;
2087     }
2088
2089     sub setup_plugins {
2090         my ( $class, $plugins ) = @_;
2091
2092         $class->_plugins( {} ) unless $class->_plugins;
2093         $plugins ||= [];
2094         for my $plugin ( reverse @$plugins ) {
2095
2096             unless ( $plugin =~ s/\A\+// ) {
2097                 $plugin = "Catalyst::Plugin::$plugin";
2098             }
2099
2100             $class->_register_plugin($plugin);
2101         }
2102     }
2103 }
2104
2105 =head2 $c->stack
2106
2107 Returns an arrayref of the internal execution stack (actions that are currently
2108 executing).
2109
2110 =head2 $c->write( $data )
2111
2112 Writes $data to the output stream. When using this method directly, you
2113 will need to manually set the C<Content-Length> header to the length of
2114 your output data, if known.
2115
2116 =cut
2117
2118 sub write {
2119     my $c = shift;
2120
2121     # Finalize headers if someone manually writes output
2122     $c->finalize_headers;
2123
2124     return $c->engine->write( $c, @_ );
2125 }
2126
2127 =head2 version
2128
2129 Returns the Catalyst version number. Mostly useful for "powered by"
2130 messages in template systems.
2131
2132 =cut
2133
2134 sub version { return $Catalyst::VERSION }
2135
2136 =head1 INTERNAL ACTIONS
2137
2138 Catalyst uses internal actions like C<_DISPATCH>, C<_BEGIN>, C<_AUTO>,
2139 C<_ACTION>, and C<_END>. These are by default not shown in the private
2140 action table, but you can make them visible with a config parameter.
2141
2142     MyApp->config->{show_internal_actions} = 1;
2143
2144 =head1 CASE SENSITIVITY
2145
2146 By default Catalyst is not case sensitive, so C<MyApp::C::FOO::Bar> is
2147 mapped to C</foo/bar>. You can activate case sensitivity with a config
2148 parameter.
2149
2150     MyApp->config->{case_sensitive} = 1;
2151
2152 This causes C<MyApp::C::Foo::Bar> to map to C</Foo/Bar>.
2153
2154 =head1 ON-DEMAND PARSER
2155
2156 The request body is usually parsed at the beginning of a request,
2157 but if you want to handle input yourself or speed things up a bit,
2158 you can enable on-demand parsing with a config parameter.
2159
2160     MyApp->config->{parse_on_demand} = 1;
2161
2162 =head1 PROXY SUPPORT
2163
2164 Many production servers operate using the common double-server approach,
2165 with a lightweight frontend web server passing requests to a larger
2166 backend server. An application running on the backend server must deal
2167 with two problems: the remote user always appears to be C<127.0.0.1> and
2168 the server's hostname will appear to be C<localhost> regardless of the
2169 virtual host that the user connected through.
2170
2171 Catalyst will automatically detect this situation when you are running
2172 the frontend and backend servers on the same machine. The following
2173 changes are made to the request.
2174
2175     $c->req->address is set to the user's real IP address, as read from
2176     the HTTP X-Forwarded-For header.
2177
2178     The host value for $c->req->base and $c->req->uri is set to the real
2179     host, as read from the HTTP X-Forwarded-Host header.
2180
2181 Obviously, your web server must support these headers for this to work.
2182
2183 In a more complex server farm environment where you may have your
2184 frontend proxy server(s) on different machines, you will need to set a
2185 configuration option to tell Catalyst to read the proxied data from the
2186 headers.
2187
2188     MyApp->config->{using_frontend_proxy} = 1;
2189
2190 If you do not wish to use the proxy support at all, you may set:
2191
2192     MyApp->config->{ignore_frontend_proxy} = 1;
2193
2194 =head1 THREAD SAFETY
2195
2196 Catalyst has been tested under Apache 2's threading mpm_worker, mpm_winnt,
2197 and the standalone forking HTTP server on Windows. We believe the Catalyst
2198 core to be thread-safe.
2199
2200 If you plan to operate in a threaded environment, remember that all other
2201 modules you are using must also be thread-safe. Some modules, most notably
2202 L<DBD::SQLite>, are not thread-safe.
2203
2204 =head1 SUPPORT
2205
2206 IRC:
2207
2208     Join #catalyst on irc.perl.org.
2209
2210 Mailing Lists:
2211
2212     http://lists.rawmode.org/mailman/listinfo/catalyst
2213     http://lists.rawmode.org/mailman/listinfo/catalyst-dev
2214
2215 Web:
2216
2217     http://catalyst.perl.org
2218
2219 Wiki:
2220
2221     http://dev.catalyst.perl.org
2222
2223 =head1 SEE ALSO
2224
2225 =head2 L<Task::Catalyst> - All you need to start with Catalyst
2226
2227 =head2 L<Catalyst::Manual> - The Catalyst Manual
2228
2229 =head2 L<Catalyst::Component>, L<Catalyst::Base> - Base classes for components
2230
2231 =head2 L<Catalyst::Engine> - Core engine
2232
2233 =head2 L<Catalyst::Log> - Log class.
2234
2235 =head2 L<Catalyst::Request> - Request object
2236
2237 =head2 L<Catalyst::Response> - Response object
2238
2239 =head2 L<Catalyst::Test> - The test suite.
2240
2241 =head1 CREDITS
2242
2243 Andy Grundman
2244
2245 Andy Wardley
2246
2247 Andreas Marienborg
2248
2249 Andrew Bramble
2250
2251 Andrew Ford
2252
2253 Andrew Ruthven
2254
2255 Arthur Bergman
2256
2257 Autrijus Tang
2258
2259 Brian Cassidy
2260
2261 Carl Franks
2262
2263 Christian Hansen
2264
2265 Christopher Hicks
2266
2267 Dan Sully
2268
2269 Danijel Milicevic
2270
2271 David Kamholz
2272
2273 David Naughton
2274
2275 Drew Taylor
2276
2277 Gary Ashton Jones
2278
2279 Geoff Richards
2280
2281 Jesse Sheidlower
2282
2283 Jesse Vincent
2284
2285 Jody Belka
2286
2287 Johan Lindstrom
2288
2289 Juan Camacho
2290
2291 Leon Brocard
2292
2293 Marcus Ramberg
2294
2295 Matt S Trout
2296
2297 Robert Sedlacek
2298
2299 Sam Vilain
2300
2301 Sascha Kiefer
2302
2303 Tatsuhiko Miyagawa
2304
2305 Ulf Edvinsson
2306
2307 Yuval Kogman
2308
2309 =head1 AUTHOR
2310
2311 Sebastian Riedel, C<sri@oook.de>
2312
2313 =head1 LICENSE
2314
2315 This library is free software, you can redistribute it and/or modify it under
2316 the same terms as Perl itself.
2317
2318 =cut
2319
2320 1;