lib/Catalyst.pm

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