lib/Catalyst.pm

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