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