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