lib/Catalyst.pm

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