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