lib/Catalyst.pm

   1 package Catalyst;
   2
   3 use Moose;
   4 use Moose::Meta::Class ();
   5 extends 'Catalyst::Component';
   6 with qw/
   7     MooseX::Emulate::Class::Accessor::Fast
   8     Catalyst::Config
   9     Catalyst::ClassData
  10 /;
  11 use Moose::Util qw/find_meta/;
  12 use B::Hooks::EndOfScope ();
  13 use Catalyst::Exception;
  14 use Catalyst::Log;
  15 use Catalyst::Utils;
  16 use Catalyst::Controller;
  17 use Catalyst::Context;
  18 use Catalyst::Exception::Detach;
  19 use Catalyst::Exception::Go;
  20 use Devel::InnerPackage ();
  21 use Module::Pluggable::Object ();
  22 use Text::SimpleTable ();
  23 use Path::Class::Dir ();
  24 use Path::Class::File ();
  25 use Tree::Simple::Visitor::FindByUID;
  26 use Class::C3::Adopt::NEXT;
  27 use attributes;
  28 use utf8;
  29 use Carp qw/croak carp shortmess/;
  30
  31 BEGIN { require 5.008004; }
  32
  33 sub comp { shift->component(@_) }
  34
  35 #I imagine that very few of these really need to be class variables. if any.
  36 #maybe we should just make them attributes with a default?
  37 __PACKAGE__->mk_classdata($_)
  38   for qw/components arguments dispatcher engine log dispatcher_class
  39   engine_class context_class request_class response_class stats_class
  40   setup_finished/;
  41
  42 __PACKAGE__->context_class('Catalyst::Context');
  43 __PACKAGE__->dispatcher_class('Catalyst::Dispatcher');
  44 __PACKAGE__->engine_class('Catalyst::Engine::CGI');
  45 __PACKAGE__->request_class('Catalyst::Request');
  46 __PACKAGE__->response_class('Catalyst::Response');
  47 __PACKAGE__->stats_class('Catalyst::Stats');
  48
  49 # Remember to update this in Catalyst::Runtime as well!
  50
  51 our $VERSION = '5.80013';
  52
  53 {
  54     my $dev_version = $VERSION =~ /_\d{2}$/;
  55     *_IS_DEVELOPMENT_VERSION = sub () { $dev_version };
  56 }
  57
  58 $VERSION = eval $VERSION;
  59
  60 our $COUNT     = 1;
  61 our $START     = time;
  62 our $DETACH    = Catalyst::Exception::Detach->new;
  63 our $GO        = Catalyst::Exception::Go->new;
  64
  65 sub import {
  66     my ( $class, @arguments ) = @_;
  67
  68     # We have to limit $class to Catalyst to avoid pushing Catalyst upon every
  69     # callers @ISA.
  70     return unless $class eq 'Catalyst';
  71
  72     my $caller = caller();
  73     return if $caller eq 'main';
  74
  75     # Kill Adopt::NEXT warnings if we're a non-RC version
  76     unless (_IS_DEVELOPMENT_VERSION()) {
  77         Class::C3::Adopt::NEXT->unimport(qr/^Catalyst::/);
  78     }
  79
  80     my $meta = Moose::Meta::Class->initialize($caller);
  81     # Make the caller inherit from Catalyst
  82     unless ( $caller->isa('Catalyst') ) {
  83         $meta->superclasses($meta->superclasses, 'Catalyst');
  84     }
  85     # Avoid possible C3 issues if 'Moose::Object' is already on RHS of MyApp
  86     $meta->superclasses(grep { $_ ne 'Moose::Object' } $meta->superclasses);
  87
  88     unless( $meta->has_method('meta') ){
  89         $meta->add_method(meta => sub { Moose::Meta::Class->initialize("${caller}") } );
  90     }
  91
  92     $caller->arguments( [@arguments] );
  93     $caller->setup_home;
  94 }
  95
  96 sub _application { $_[0] }
  97
  98 =head1 NAME
  99
 100 Catalyst - The Elegant MVC Web Application Framework
 101
 102 =head1 SYNOPSIS
 103
 104 See the L<Catalyst::Manual> distribution for comprehensive
 105 documentation and tutorials.
 106
 107     # Install Catalyst::Devel for helpers and other development tools
 108     # use the helper to create a new application
 109     catalyst.pl MyApp
 110
 111     # add models, views, controllers
 112     script/myapp_create.pl model MyDatabase DBIC::Schema create=static dbi:SQLite:/path/to/db
 113     script/myapp_create.pl view MyTemplate TT
 114     script/myapp_create.pl controller Search
 115
 116     # built in testserver -- use -r to restart automatically on changes
 117     # --help to see all available options
 118     script/myapp_server.pl
 119
 120     # command line testing interface
 121     script/myapp_test.pl /yada
 122
 123     ### in lib/MyApp.pm
 124     use Catalyst qw/-Debug/; # include plugins here as well
 125
 126     ### In lib/MyApp/Controller/Root.pm (autocreated)
 127     sub foo : Global { # called for /foo, /foo/1, /foo/1/2, etc.
 128         my ( $self, $c, @args ) = @_; # args are qw/1 2/ for /foo/1/2
 129         $c->stash->{template} = 'foo.tt'; # set the template
 130         # lookup something from db -- stash vars are passed to TT
 131         $c->stash->{data} =
 132           $c->model('Database::Foo')->search( { country => $args[0] } );
 133         if ( $c->req->params->{bar} ) { # access GET or POST parameters
 134             $c->forward( 'bar' ); # process another action
 135             # do something else after forward returns
 136         }
 137     }
 138
 139     # The foo.tt TT template can use the stash data from the database
 140     [% WHILE (item = data.next) %]
 141         [% item.foo %]
 142     [% END %]
 143
 144     # called for /bar/of/soap, /bar/of/soap/10, etc.
 145     sub bar : Path('/bar/of/soap') { ... }
 146
 147     # called for all actions, from the top-most controller downwards
 148     sub auto : Private {
 149         my ( $self, $c ) = @_;
 150         if ( !$c->user_exists ) { # Catalyst::Plugin::Authentication
 151             $c->res->redirect( '/login' ); # require login
 152             return 0; # abort request and go immediately to end()
 153         }
 154         return 1; # success; carry on to next action
 155     }
 156
 157     # called after all actions are finished
 158     sub end : Private {
 159         my ( $self, $c ) = @_;
 160         if ( scalar @{ $c->error } ) { ... } # handle errors
 161         return if $c->res->body; # already have a response
 162         $c->forward( 'MyApp::View::TT' ); # render template
 163     }
 164
 165     ### in MyApp/Controller/Foo.pm
 166     # called for /foo/bar
 167     sub bar : Local { ... }
 168
 169     # called for /blargle
 170     sub blargle : Global { ... }
 171
 172     # an index action matches /foo, but not /foo/1, etc.
 173     sub index : Private { ... }
 174
 175     ### in MyApp/Controller/Foo/Bar.pm
 176     # called for /foo/bar/baz
 177     sub baz : Local { ... }
 178
 179     # first Root auto is called, then Foo auto, then this
 180     sub auto : Private { ... }
 181
 182     # powerful regular expression paths are also possible
 183     sub details : Regex('^product/(\w+)/details$') {
 184         my ( $self, $c ) = @_;
 185         # extract the (\w+) from the URI
 186         my $product = $c->req->captures->[0];
 187     }
 188
 189 See L<Catalyst::Manual::Intro> for additional information.
 190
 191 =head1 DESCRIPTION
 192
 193 Catalyst is a modern framework for making web applications without the
 194 pain usually associated with this process. This document is a reference
 195 to the main Catalyst application. If you are a new user, we suggest you
 196 start with L<Catalyst::Manual::Tutorial> or L<Catalyst::Manual::Intro>.
 197
 198 See L<Catalyst::Manual> for more documentation.
 199
 200 Catalyst plugins can be loaded by naming them as arguments to the "use
 201 Catalyst" statement. Omit the C<Catalyst::Plugin::> prefix from the
 202 plugin name, i.e., C<Catalyst::Plugin::My::Module> becomes
 203 C<My::Module>.
 204
 205     use Catalyst qw/My::Module/;
 206
 207 If your plugin starts with a name other than C<Catalyst::Plugin::>, you can
 208 fully qualify the name by using a unary plus:
 209
 210     use Catalyst qw/
 211         My::Module
 212         +Fully::Qualified::Plugin::Name
 213     /;
 214
 215 Special flags like C<-Debug> and C<-Engine> can also be specified as
 216 arguments when Catalyst is loaded:
 217
 218     use Catalyst qw/-Debug My::Module/;
 219
 220 The position of plugins and flags in the chain is important, because
 221 they are loaded in the order in which they appear.
 222
 223 The following flags are supported:
 224
 225 =head2 -Debug
 226
 227 Enables debug output. You can also force this setting from the system
 228 environment with CATALYST_DEBUG or <MYAPP>_DEBUG. The environment
 229 settings override the application, with <MYAPP>_DEBUG having the highest
 230 priority.
 231
 232 =head2 -Engine
 233
 234 Forces Catalyst to use a specific engine. Omit the
 235 C<Catalyst::Engine::> prefix of the engine name, i.e.:
 236
 237     use Catalyst qw/-Engine=CGI/;
 238
 239 =head2 -Home
 240
 241 Forces Catalyst to use a specific home directory, e.g.:
 242
 243     use Catalyst qw[-Home=/usr/mst];
 244
 245 This can also be done in the shell environment by setting either the
 246 C<CATALYST_HOME> environment variable or C<MYAPP_HOME>; where C<MYAPP>
 247 is replaced with the uppercased name of your application, any "::" in
 248 the name will be replaced with underscores, e.g. MyApp::Web should use
 249 MYAPP_WEB_HOME. If both variables are set, the MYAPP_HOME one will be used.
 250
 251 =head2 -Log
 252
 253     use Catalyst '-Log=warn,fatal,error';
 254
 255 Specifies a comma-delimited list of log levels.
 256
 257 =head2 -Stats
 258
 259 Enables statistics collection and reporting. You can also force this setting
 260 from the system environment with CATALYST_STATS or <MYAPP>_STATS. The
 261 environment settings override the application, with <MYAPP>_STATS having the
 262 highest priority.
 263
 264 e.g.
 265
 266    use Catalyst qw/-Stats=1/
 267
 268 =head1 METHODS
 269
 270 =cut
 271
 272 =head2 $c->controller($name)
 273
 274 Gets a L<Catalyst::Controller> instance by name.
 275
 276     $c->controller('Foo')->do_stuff;
 277
 278 If the name is omitted, will return the controller for the dispatched
 279 action.
 280
 281 If you want to search for controllers, pass in a regexp as the argument.
 282
 283     # find all controllers that start with Foo
 284     my @foo_controllers = $c->controller(qr{^Foo});
 285
 286
 287 =cut
 288
 289 sub controller {
 290     my ( $c, $name, @args ) = @_;
 291
 292     if( $name ) {
 293         my @result = $c->_comp_search_prefixes( $name, qw/Controller C/ );
 294         return map { $c->_filter_component( $_, @args ) } @result if ref $name;
 295         return $c->_filter_component( $result[ 0 ], @args );
 296     }
 297
 298     return $c->component( $c->action->class );
 299 }
 300
 301 =head2 $c->view($name)
 302
 303 Gets a L<Catalyst::View> instance by name.
 304
 305 =cut
 306
 307 sub view {
 308     my ( $c, $name, @args ) = @_;
 309
 310     if( $name ) {
 311         my @result = $c->_comp_search_prefixes( $name, qw/View V/ );
 312         return map { $c->_filter_component( $_, @args ) } @result if ref $name;
 313         return $c->_filter_component( $result[ 0 ], @args );
 314     }
 315
 316     return $c->view( $c->config->{default_view} )
 317       if $c->config->{default_view};
 318     my( $comp, $rest ) = $c->_comp_search_prefixes( undef, qw/View V/);
 319
 320     if( $rest ) {
 321         $c->log->warn( 'Calling $c->view() will return a random view unless you specify one of:' );
 322         $c->log->warn( '* $c->config(default_view => "the name of the default view to use")' );
 323         $c->log->warn( '* $c->stash->{current_view} # the name of the view to use for this request' );
 324         $c->log->warn( '* $c->stash->{current_view_instance} # the instance of the view to use for this request' );
 325         $c->log->warn( 'NB: in version 5.81, the "random" behavior will not work at all.' );
 326     }
 327
 328     return $c->_filter_component( $comp );
 329 }
 330
 331 =head2 $c->model($name)
 332
 333 Gets a L<Catalyst::Model> instance by name.
 334
 335 =cut
 336
 337 sub model {
 338     my ( $c, $name, @args ) = @_;
 339     if( $name ) {
 340         my @result = $c->_comp_search_prefixes( $name, qw/Model M/ );
 341         return map { $c->_filter_component( $_, @args ) } @result if ref $name;
 342         return $c->_filter_component( $result[ 0 ], @args );
 343     }
 344
 345     return $c->model( $c->config->{default_model} )
 346       if $c->config->{default_model};
 347
 348     my( $comp, $rest ) = $c->_comp_search_prefixes( undef, qw/Model M/);
 349
 350     if( $rest ) {
 351         $c->log->warn( Carp::shortmess('Calling $c->model() will return a random model unless you specify one of:') );
 352         $c->log->warn( '* $c->config(default_model => "the name of the default model to use")' );
 353         $c->log->warn( '* $c->stash->{current_model} # the name of the model to use for this request' );
 354         $c->log->warn( '* $c->stash->{current_model_instance} # the instance of the model to use for this request' );
 355         $c->log->warn( 'NB: in version 5.81, the "random" behavior will not work at all.' );
 356     }
 357
 358     return $c->_filter_component( $comp );
 359 }
 360
 361
 362 sub _comp_search_prefixes {
 363     my $c = shift;
 364     return map $c->components->{ $_ }, $c->_comp_names_search_prefixes(@_);
 365 }
 366
 367 # search components given a name and some prefixes
 368 sub _comp_names_search_prefixes {
 369     my ( $c, $name, @prefixes ) = @_;
 370     my $appclass = ref $c || $c;
 371     my $filter   = "^${appclass}::(" . join( '|', @prefixes ) . ')::';
 372     $filter = qr/$filter/; # Compile regex now rather than once per loop
 373
 374     # map the original component name to the sub part that we will search against
 375     my %eligible = map { my $n = $_; $n =~ s{^$appclass\::[^:]+::}{}; $_ => $n; }
 376         grep { /$filter/ } keys %{ $c->components };
 377
 378     # undef for a name will return all
 379     return keys %eligible if !defined $name;
 380
 381     my $query  = ref $name ? $name : qr/^$name$/i;
 382     my @result = grep { $eligible{$_} =~ m{$query} } keys %eligible;
 383
 384     return @result if @result;
 385
 386     # if we were given a regexp to search against, we're done.
 387     return if ref $name;
 388
 389     # skip regexp fallback if configured
 390     return
 391         if $appclass->config->{disable_component_resolution_regex_fallback};
 392
 393     # regexp fallback
 394     $query  = qr/$name/i;
 395     @result = grep { $eligible{ $_ } =~ m{$query} } keys %eligible;
 396
 397     # no results? try against full names
 398     if( !@result ) {
 399         @result = grep { m{$query} } keys %eligible;
 400     }
 401
 402     # don't warn if we didn't find any results, it just might not exist
 403     if( @result ) {
 404         # Disgusting hack to work out correct method name
 405         my $warn_for = lc $prefixes[0];
 406         my $msg = "Used regexp fallback for \$c->${warn_for}('${name}'), which found '" .
 407            (join '", "', @result) . "'. Relying on regexp fallback behavior for " .
 408            "component resolution is unreliable and unsafe.";
 409         my $short = $result[0];
 410         # remove the component namespace prefix
 411         $short =~ s/.*?(Model|Controller|View):://;
 412         my $shortmess = Carp::shortmess('');
 413         if ($shortmess =~ m#Catalyst/Plugin#) {
 414            $msg .= " You probably need to set '$short' instead of '${name}' in this " .
 415               "plugin's config";
 416         } elsif ($shortmess =~ m#Catalyst/lib/(View|Controller)#) {
 417            $msg .= " You probably need to set '$short' instead of '${name}' in this " .
 418               "component's config";
 419         } else {
 420            $msg .= " You probably meant \$c->${warn_for}('$short') instead of \$c->${warn_for}('${name}'), " .
 421               "but if you really wanted to search, pass in a regexp as the argument " .
 422               "like so: \$c->${warn_for}(qr/${name}/)";
 423         }
 424         $c->log->warn( "${msg}$shortmess" );
 425     }
 426
 427     return @result;
 428 }
 429
 430 # Find possible names for a prefix
 431 sub _comp_names {
 432     my ( $c, @prefixes ) = @_;
 433     my $appclass = ref $c || $c;
 434
 435     my $filter = "^${appclass}::(" . join( '|', @prefixes ) . ')::';
 436
 437     my @names = map { s{$filter}{}; $_; }
 438         $c->_comp_names_search_prefixes( undef, @prefixes );
 439
 440     return @names;
 441 }
 442
 443 # Filter a component before returning by calling ACCEPT_CONTEXT if available
 444 sub _filter_component {
 445     my ( $c, $comp, @args ) = @_;
 446
 447     if ( eval { $comp->can('ACCEPT_CONTEXT'); } ) {
 448         return $comp->ACCEPT_CONTEXT( $c, @args );
 449     }
 450
 451     return $comp;
 452 }
 453
 454 =head2 COMPONENT ACCESSORS
 455
 456 =head2 $c->controllers
 457
 458 Returns the available names which can be passed to $c->controller
 459
 460 =cut
 461
 462 sub controllers {
 463     my ( $c ) = @_;
 464     return $c->_comp_names(qw/Controller C/);
 465 }
 466
 467 =head2 $c->models
 468
 469 Returns the available names which can be passed to $c->model
 470
 471 =cut
 472
 473 sub models {
 474     my ( $c ) = @_;
 475     return $c->_comp_names(qw/Model M/);
 476 }
 477
 478
 479 =head2 $c->views
 480
 481 Returns the available names which can be passed to $c->view
 482
 483 =cut
 484
 485 sub views {
 486     my ( $c ) = @_;
 487     return $c->_comp_names(qw/View V/);
 488 }
 489
 490 =head2 $c->comp($name)
 491
 492 =head2 $c->component($name)
 493
 494 Gets a component object by name. This method is not recommended,
 495 unless you want to get a specific component by full
 496 class. C<< $c->controller >>, C<< $c->model >>, and C<< $c->view >>
 497 should be used instead.
 498
 499 If C<$name> is a regexp, a list of components matched against the full
 500 component name will be returned.
 501
 502 If Catalyst can't find a component by name, it will fallback to regex
 503 matching by default. To disable this behaviour set
 504 disable_component_resolution_regex_fallback to a true value.
 505
 506     __PACKAGE__->config( disable_component_resolution_regex_fallback => 1 );
 507
 508 =cut
 509
 510 sub component {
 511     my ( $c, $name, @args ) = @_;
 512
 513     if( $name ) {
 514         my $comps = $c->components;
 515
 516         if( !ref $name ) {
 517             # is it the exact name?
 518             return $c->_filter_component( $comps->{ $name }, @args )
 519                        if exists $comps->{ $name };
 520
 521             # perhaps we just omitted "MyApp"?
 522             my $composed = ( ref $c || $c ) . "::${name}";
 523             return $c->_filter_component( $comps->{ $composed }, @args )
 524                        if exists $comps->{ $composed };
 525
 526             # search all of the models, views and controllers
 527             my( $comp ) = $c->_comp_search_prefixes( $name, qw/Model M Controller C View V/ );
 528             return $c->_filter_component( $comp, @args ) if $comp;
 529         }
 530
 531         return if $c->config->{disable_component_resolution_regex_fallback};
 532         # This is here so $c->comp( '::M::' ) works
 533         my $query = ref $name ? $name : qr{$name}i;
 534
 535         my @result = grep { m{$query} } keys %{ $c->components };
 536         return map { $c->_filter_component( $_, @args ) } @result if ref $name;
 537
 538         if( $result[ 0 ] ) {
 539             $c->log->warn( Carp::shortmess(qq(Found results for "${name}" using regexp fallback)) );
 540             $c->log->warn( 'Relying on the regexp fallback behavior for component resolution' );
 541             $c->log->warn( 'is unreliable and unsafe. You have been warned' );
 542             return $c->_filter_component( $result[ 0 ], @args );
 543         }
 544
 545         # I would expect to return an empty list here, but that breaks back-compat
 546     }
 547
 548     # fallback
 549     return sort keys %{ $c->components };
 550 }
 551
 552 =head2 CLASS DATA AND HELPER CLASSES
 553
 554 =head2 $c->config
 555
 556 Returns or takes a hashref containing the application's configuration.
 557
 558     __PACKAGE__->config( { db => 'dsn:SQLite:foo.db' } );
 559
 560 You can also use a C<YAML>, C<XML> or L<Config::General> config file
 561 like C<myapp.conf> in your applications home directory. See
 562 L<Catalyst::Plugin::ConfigLoader>.
 563
 564 =head3 Cascading configuration
 565
 566 The config method is present on all Catalyst components, and configuration
 567 will be merged when an application is started. Configuration loaded with
 568 L<Catalyst::Plugin::ConfigLoader> takes precedence over other configuration,
 569 followed by configuration in your top level C<MyApp> class. These two
 570 configurations are merged, and then configuration data whose hash key matches a
 571 component name is merged with configuration for that component.
 572
 573 The configuration for a component is then passed to the C<new> method when a
 574 component is constructed.
 575
 576 For example:
 577
 578     MyApp->config({ 'Model::Foo' => { bar => 'baz', overrides => 'me' } });
 579     MyApp::Model::Foo->config({ quux => 'frob', 'overrides => 'this' });
 580
 581 will mean that C<MyApp::Model::Foo> receives the following data when
 582 constructed:
 583
 584     MyApp::Model::Foo->new({
 585         bar => 'baz',
 586         quux => 'frob',
 587         overrides => 'me',
 588     });
 589
 590 =cut
 591
 592 around config => sub {
 593     my $orig = shift;
 594     my $c = shift;
 595
 596     croak('Setting config after setup has been run is not allowed.')
 597         if ( @_ and $c->setup_finished );
 598
 599     $c->$orig(@_);
 600 };
 601
 602 =head2 $c->log
 603
 604 Returns the logging object instance. Unless it is already set, Catalyst
 605 sets this up with a L<Catalyst::Log> object. To use your own log class,
 606 set the logger with the C<< __PACKAGE__->log >> method prior to calling
 607 C<< __PACKAGE__->setup >>.
 608
 609  __PACKAGE__->log( MyLogger->new );
 610  __PACKAGE__->setup;
 611
 612 And later:
 613
 614     $c->log->info( 'Now logging with my own logger!' );
 615
 616 Your log class should implement the methods described in
 617 L<Catalyst::Log>.
 618
 619
 620 =head2 $c->debug
 621
 622 Returns 1 if debug mode is enabled, 0 otherwise.
 623
 624 You can enable debug mode in several ways:
 625
 626 =over
 627
 628 =item By calling myapp_server.pl with the -d flag
 629
 630 =item With the environment variables MYAPP_DEBUG, or CATALYST_DEBUG
 631
 632 =item The -Debug option in your MyApp.pm
 633
 634 =item By declaring C<sub debug { 1 }> in your MyApp.pm.
 635
 636 =back
 637
 638 Calling C<< $c->debug(1) >> has no effect.
 639
 640 =cut
 641
 642 sub debug { 0 }
 643
 644 =head2 $c->dispatcher
 645
 646 Returns the dispatcher instance. See L<Catalyst::Dispatcher>.
 647
 648 =head2 $c->engine
 649
 650 Returns the engine instance. See L<Catalyst::Engine>.
 651
 652
 653 =head2 UTILITY METHODS
 654
 655 =head2 $c->path_to(@path)
 656
 657 Merges C<@path> with C<< $c->config->{home} >> and returns a
 658 L<Path::Class::Dir> object. Note you can usually use this object as
 659 a filename, but sometimes you will have to explicitly stringify it
 660 yourself by calling the C<< ->stringify >> method.
 661
 662 For example:
 663
 664     $c->path_to( 'db', 'sqlite.db' );
 665
 666 =cut
 667
 668 sub path_to {
 669     my ( $c, @path ) = @_;
 670     my $path = Path::Class::Dir->new( $c->config->{home}, @path );
 671     if ( -d $path ) { return $path }
 672     else { return Path::Class::File->new( $c->config->{home}, @path ) }
 673 }
 674
 675 =head2 $c->plugin( $name, $class, @args )
 676
 677 Helper method for plugins. It creates a class data accessor/mutator and
 678 loads and instantiates the given class.
 679
 680     MyApp->plugin( 'prototype', 'HTML::Prototype' );
 681
 682     $c->prototype->define_javascript_functions;
 683
 684 B<Note:> This method of adding plugins is deprecated. The ability
 685 to add plugins like this B<will be removed> in a Catalyst 5.81.
 686 Please do not use this functionality in new code.
 687
 688 =cut
 689
 690 sub plugin {
 691     my ( $class, $name, $plugin, @args ) = @_;
 692
 693     # See block comment in t/unit_core_plugin.t
 694     $class->log->warn(qq/Adding plugin using the ->plugin method is deprecated, and will be removed in Catalyst 5.81/);
 695
 696     $class->_register_plugin( $plugin, 1 );
 697
 698     eval { $plugin->import };
 699     $class->mk_classdata($name);
 700     my $obj;
 701     eval { $obj = $plugin->new(@args) };
 702
 703     if ($@) {
 704         Catalyst::Exception->throw( message =>
 705               qq/Couldn't instantiate instant plugin "$plugin", "$@"/ );
 706     }
 707
 708     $class->$name($obj);
 709     $class->log->debug(qq/Initialized instant plugin "$plugin" as "$name"/)
 710       if $class->debug;
 711 }
 712
 713 =head2 MyApp->setup
 714
 715 Initializes the dispatcher and engine, loads any plugins, and loads the
 716 model, view, and controller components. You may also specify an array
 717 of plugins to load here, if you choose to not load them in the C<use
 718 Catalyst> line.
 719
 720     MyApp->setup;
 721     MyApp->setup( qw/-Debug/ );
 722
 723 =cut
 724
 725 sub setup {
 726     my ( $class, @arguments ) = @_;
 727     croak('Running setup more than once')
 728         if ( $class->setup_finished );
 729
 730     unless ( $class->isa('Catalyst') ) {
 731
 732         Catalyst::Exception->throw(
 733             message => qq/'$class' does not inherit from Catalyst/ );
 734     }
 735
 736     if ( $class->arguments ) {
 737         @arguments = ( @arguments, @{ $class->arguments } );
 738     }
 739
 740     # Process options
 741     my $flags = {};
 742
 743     foreach (@arguments) {
 744
 745         if (/^-Debug$/) {
 746             $flags->{log} =
 747               ( $flags->{log} ) ? 'debug,' . $flags->{log} : 'debug';
 748         }
 749         elsif (/^-(\w+)=?(.*)$/) {
 750             $flags->{ lc $1 } = $2;
 751         }
 752         else {
 753             push @{ $flags->{plugins} }, $_;
 754         }
 755     }
 756
 757     $class->setup_home( delete $flags->{home} );
 758
 759     $class->setup_log( delete $flags->{log} );
 760     $class->setup_plugins( delete $flags->{plugins} );
 761     $class->setup_dispatcher( delete $flags->{dispatcher} );
 762     $class->setup_engine( delete $flags->{engine} );
 763     $class->setup_stats( delete $flags->{stats} );
 764
 765     for my $flag ( sort keys %{$flags} ) {
 766
 767         if ( my $code = $class->can( 'setup_' . $flag ) ) {
 768             &$code( $class, delete $flags->{$flag} );
 769         }
 770         else {
 771             $class->log->warn(qq/Unknown flag "$flag"/);
 772         }
 773     }
 774
 775     eval { require Catalyst::Devel; };
 776     if( !$@ && $ENV{CATALYST_SCRIPT_GEN} && ( $ENV{CATALYST_SCRIPT_GEN} < $Catalyst::Devel::CATALYST_SCRIPT_GEN ) ) {
 777         $class->log->warn(<<"EOF");
 778 You are running an old script!
 779
 780   Please update by running (this will overwrite existing files):
 781     catalyst.pl -force -scripts $class
 782
 783   or (this will not overwrite existing files):
 784     catalyst.pl -scripts $class
 785
 786 EOF
 787     }
 788
 789     if ( $class->debug ) {
 790         my @plugins = map { "$_  " . ( $_->VERSION || '' ) } $class->registered_plugins;
 791
 792         if (@plugins) {
 793             my $column_width = Catalyst::Utils::term_width() - 6;
 794             my $t = Text::SimpleTable->new($column_width);
 795             $t->row($_) for @plugins;
 796             $class->log->debug( "Loaded plugins:\n" . $t->draw . "\n" );
 797         }
 798
 799         my $dispatcher = $class->dispatcher;
 800         my $engine     = $class->engine;
 801         my $home       = $class->config->{home};
 802
 803         $class->log->debug(sprintf(q/Loaded dispatcher "%s"/, blessed($dispatcher)));
 804         $class->log->debug(sprintf(q/Loaded engine "%s"/, blessed($engine)));
 805
 806         $home
 807           ? ( -d $home )
 808           ? $class->log->debug(qq/Found home "$home"/)
 809           : $class->log->debug(qq/Home "$home" doesn't exist/)
 810           : $class->log->debug(q/Couldn't find home/);
 811     }
 812
 813     # Call plugins setup, this is stupid and evil.
 814     # Also screws C3 badly on 5.10, hack to avoid.
 815     {
 816         no warnings qw/redefine/;
 817         local *setup = sub { };
 818         $class->setup unless $Catalyst::__AM_RESTARTING;
 819     }
 820
 821     # Initialize our data structure
 822     $class->components( {} );
 823
 824     $class->setup_components;
 825
 826     if ( $class->debug ) {
 827         my $column_width = Catalyst::Utils::term_width() - 8 - 9;
 828         my $t = Text::SimpleTable->new( [ $column_width, 'Class' ], [ 8, 'Type' ] );
 829         for my $comp ( sort keys %{ $class->components } ) {
 830             my $type = ref $class->components->{$comp} ? 'instance' : 'class';
 831             $t->row( $comp, $type );
 832         }
 833         $class->log->debug( "Loaded components:\n" . $t->draw . "\n" )
 834           if ( keys %{ $class->components } );
 835     }
 836
 837     $class->setup_actions;
 838
 839     if ( $class->debug ) {
 840         my $name = $class->config->{name} || 'Application';
 841         $class->log->info("$name powered by Catalyst $Catalyst::VERSION");
 842     }
 843
 844     # Make sure that the application class becomes immutable at this point,
 845     B::Hooks::EndOfScope::on_scope_end {
 846         return if $@;
 847         my $meta = Class::MOP::get_metaclass_by_name($class);
 848         if (
 849             $meta->is_immutable
 850             && ! { $meta->immutable_options }->{replace_constructor}
 851             && (
 852                    $class->isa('Class::Accessor::Fast')
 853                 || $class->isa('Class::Accessor')
 854             )
 855         ) {
 856             warn "You made your application class ($class) immutable, "
 857                 . "but did not inline the\nconstructor. "
 858                 . "This will break catalyst, as your app \@ISA "
 859                 . "Class::Accessor(::Fast)?\nPlease pass "
 860                 . "(replace_constructor => 1)\nwhen making your class immutable.\n";
 861         }
 862         $meta->make_immutable(
 863             replace_constructor => 1,
 864         ) unless $meta->is_immutable;
 865     };
 866
 867     $class->setup_finalize;
 868     # Should be the last thing we do so that user things hooking
 869     # setup_finalize can log..
 870     $class->log->_flush() if $class->log->can('_flush');
 871     return 1; # Explicit return true as people have __PACKAGE__->setup as the last thing in their class. HATE.
 872 }
 873
 874
 875 =head2 $app->setup_finalize
 876
 877 A hook to attach modifiers to.
 878 Using C<< after setup => sub{}; >> doesn't work, because of quirky things done for plugin setup.
 879 Also better than C< setup_finished(); >, as that is a getter method.
 880
 881     sub setup_finalize {
 882
 883         my $app = shift;
 884
 885         ## do stuff, i.e., determine a primary key column for sessions stored in a DB
 886
 887         $app->next::method(@_);
 888
 889
 890     }
 891
 892 =cut
 893
 894 sub setup_finalize {
 895     my ($class) = @_;
 896     $class->setup_finished(1);
 897 }
 898
 899 =head2 $c->welcome_message
 900
 901 Returns the Catalyst welcome HTML page.
 902
 903 =cut
 904
 905 sub welcome_message {
 906     my $c      = shift;
 907     my $name   = $c->config->{name};
 908     my $logo   = $c->uri_for('/static/images/catalyst_logo.png');
 909     my $prefix = Catalyst::Utils::appprefix( ref $c );
 910     $c->response->content_type('text/html; charset=utf-8');
 911     return <<"EOF";
 912 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 913     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 914 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
 915     <head>
 916     <meta http-equiv="Content-Language" content="en" />
 917     <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
 918         <title>$name on Catalyst $VERSION</title>
 919         <style type="text/css">
 920             body {
 921                 color: #000;
 922                 background-color: #eee;
 923             }
 924             div#content {
 925                 width: 640px;
 926                 margin-left: auto;
 927                 margin-right: auto;
 928                 margin-top: 10px;
 929                 margin-bottom: 10px;
 930                 text-align: left;
 931                 background-color: #ccc;
 932                 border: 1px solid #aaa;
 933             }
 934             p, h1, h2 {
 935                 margin-left: 20px;
 936                 margin-right: 20px;
 937                 font-family: verdana, tahoma, sans-serif;
 938             }
 939             a {
 940                 font-family: verdana, tahoma, sans-serif;
 941             }
 942             :link, :visited {
 943                     text-decoration: none;
 944                     color: #b00;
 945                     border-bottom: 1px dotted #bbb;
 946             }
 947             :link:hover, :visited:hover {
 948                     color: #555;
 949             }
 950             div#topbar {
 951                 margin: 0px;
 952             }
 953             pre {
 954                 margin: 10px;
 955                 padding: 8px;
 956             }
 957             div#answers {
 958                 padding: 8px;
 959                 margin: 10px;
 960                 background-color: #fff;
 961                 border: 1px solid #aaa;
 962             }
 963             h1 {
 964                 font-size: 0.9em;
 965                 font-weight: normal;
 966                 text-align: center;
 967             }
 968             h2 {
 969                 font-size: 1.0em;
 970             }
 971             p {
 972                 font-size: 0.9em;
 973             }
 974             p img {
 975                 float: right;
 976                 margin-left: 10px;
 977             }
 978             span#appname {
 979                 font-weight: bold;
 980                 font-size: 1.6em;
 981             }
 982         </style>
 983     </head>
 984     <body>
 985         <div id="content">
 986             <div id="topbar">
 987                 <h1><span id="appname">$name</span> on <a href="http://catalyst.perl.org">Catalyst</a>
 988                     $VERSION</h1>
 989              </div>
 990              <div id="answers">
 991                  <p>
 992                  <img src="$logo" alt="Catalyst Logo" />
 993                  </p>
 994                  <p>Welcome to the  world of Catalyst.
 995                     This <a href="http://en.wikipedia.org/wiki/MVC">MVC</a>
 996                     framework will make web development something you had
 997                     never expected it to be: Fun, rewarding, and quick.</p>
 998                  <h2>What to do now?</h2>
 999                  <p>That really depends  on what <b>you</b> want to do.
1000                     We do, however, provide you with a few starting points.</p>
1001                  <p>If you want to jump right into web development with Catalyst
1002                     you might want to start with a tutorial.</p>
1003 <pre>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Tutorial.pod">Catalyst::Manual::Tutorial</a></code>
1004 </pre>
1005 <p>Afterwards you can go on to check out a more complete look at our features.</p>
1006 <pre>
1007 <code>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Intro.pod">Catalyst::Manual::Intro</a>
1008 <!-- Something else should go here, but the Catalyst::Manual link seems unhelpful -->
1009 </code></pre>
1010                  <h2>What to do next?</h2>
1011                  <p>Next it's time to write an actual application. Use the
1012                     helper scripts to generate <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AController%3A%3A&amp;mode=all">controllers</a>,
1013                     <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AModel%3A%3A&amp;mode=all">models</a>, and
1014                     <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AView%3A%3A&amp;mode=all">views</a>;
1015                     they can save you a lot of work.</p>
1016                     <pre><code>script/${prefix}_create.pl -help</code></pre>
1017                     <p>Also, be sure to check out the vast and growing
1018                     collection of <a href="http://search.cpan.org/search?query=Catalyst">plugins for Catalyst on CPAN</a>;
1019                     you are likely to find what you need there.
1020                     </p>
1021
1022                  <h2>Need help?</h2>
1023                  <p>Catalyst has a very active community. Here are the main places to
1024                     get in touch with us.</p>
1025                  <ul>
1026                      <li>
1027                          <a href="http://dev.catalyst.perl.org">Wiki</a>
1028                      </li>
1029                      <li>
1030                          <a href="http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst">Mailing-List</a>
1031                      </li>
1032                      <li>
1033                          <a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
1034                      </li>
1035                  </ul>
1036                  <h2>In conclusion</h2>
1037                  <p>The Catalyst team hopes you will enjoy using Catalyst as much
1038                     as we enjoyed making it. Please contact us if you have ideas
1039                     for improvement or other feedback.</p>
1040              </div>
1041          </div>
1042     </body>
1043 </html>
1044 EOF
1045 }
1046
1047 =head1 INTERNAL METHODS
1048
1049 These methods are not meant to be used by end users.
1050
1051 =head2 $c->components
1052
1053 Returns a hash of components.
1054
1055 =head2 $c->context_class
1056
1057 Returns or sets the context class.
1058
1059 =head2 $c->dispatcher_class
1060
1061 Returns or sets the dispatcher class.
1062
1063 =head2 $c->engine_class
1064
1065 Returns or sets the engine class.
1066
1067 =head2 $c->handle_request( $class, @arguments )
1068
1069 Called to handle each HTTP request.
1070
1071 =cut
1072
1073 sub handle_request {
1074     my ( $class, @arguments ) = @_;
1075
1076     # Always expect worst case!
1077     my $status = -1;
1078     eval {
1079         if ($class->debug) {
1080             my $secs = time - $START || 1;
1081             my $av = sprintf '%.3f', $COUNT / $secs;
1082             my $time = localtime time;
1083             $class->log->info("*** Request $COUNT ($av/s) [$$] [$time] ***");
1084         }
1085
1086         my $c = $class->prepare(@arguments);
1087         $c->dispatch;
1088         $status = $c->finalize;
1089     };
1090
1091     if ( my $error = $@ ) {
1092         chomp $error;
1093         $class->log->error(qq/Caught exception in engine "$error"/);
1094     }
1095
1096     $COUNT++;
1097
1098     if(my $coderef = $class->log->can('_flush')){
1099         $class->log->$coderef();
1100     }
1101     return $status;
1102 }
1103
1104 =head2 $c->prepare( @arguments )
1105
1106 Creates a Catalyst context from an engine-specific request (Apache, CGI,
1107 etc.).
1108
1109 =cut
1110
1111 sub prepare {
1112     my ( $class, @arguments ) = @_;
1113
1114     # XXX
1115     # After the app/ctxt split, this should become an attribute based on something passed
1116     # into the application.
1117     $class->context_class( ref $class || $class ) unless $class->context_class;
1118
1119     my $app = $class->new({});
1120     my $c = $class->context_class->new( application => $app );
1121
1122     # For on-demand data
1123     $c->request->_context($c);
1124     $c->response->_context($c);
1125
1126     #surely this is not the most efficient way to do things...
1127     $c->stats($class->stats_class->new)->enable($c->use_stats);
1128     if ( $c->debug ) {
1129         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
1130     }
1131
1132     #XXX reuse coderef from can
1133     # Allow engine to direct the prepare flow (for POE)
1134     if ( $c->engine->can('prepare') ) {
1135         $c->engine->prepare( $c, @arguments );
1136     }
1137     else {
1138         $c->prepare_request(@arguments);
1139         $c->prepare_connection;
1140         $c->prepare_query_parameters;
1141         $c->prepare_headers;
1142         $c->prepare_cookies;
1143         $c->prepare_path;
1144
1145         # Prepare the body for reading, either by prepare_body
1146         # or the user, if they are using $c->read
1147         $c->prepare_read;
1148
1149         # Parse the body unless the user wants it on-demand
1150         unless ( $app->config->{parse_on_demand} ) {
1151             $c->prepare_body;
1152         }
1153     }
1154
1155     my $method  = $c->req->method  || '';
1156     my $path    = $c->req->path;
1157     $path       = '/' unless length $path;
1158     my $address = $c->req->address || '';
1159
1160     $c->log->debug(qq/"$method" request for "$path" from "$address"/)
1161       if $c->debug;
1162
1163     $c->prepare_action;
1164
1165     return $c;
1166 }
1167
1168 =head2 $c->request_class
1169
1170 Returns or sets the request class.
1171
1172 =head2 $c->response_class
1173
1174 Returns or sets the response class.
1175
1176 =head2 $c->run
1177
1178 Starts the engine.
1179
1180 =cut
1181
1182 sub run { my $c = shift; return $c->engine->run( $c, @_ ) }
1183
1184 =head2 $c->set_action( $action, $code, $namespace, $attrs )
1185
1186 Sets an action in a given namespace.
1187
1188 =cut
1189
1190 sub set_action { my $c = shift; $c->dispatcher->set_action( $c, @_ ) }
1191
1192 =head2 $c->setup_actions($component)
1193
1194 Sets up actions for a component.
1195
1196 =cut
1197
1198 sub setup_actions { my $c = shift; $c->dispatcher->setup_actions( $c, @_ ) }
1199
1200 =head2 $c->setup_components
1201
1202 This method is called internally to set up the application's components.
1203
1204 It finds modules by calling the L<locate_components> method, expands them to
1205 package names with the L<expand_component_module> method, and then installs
1206 each component into the application.
1207
1208 The C<setup_components> config option is passed to both of the above methods.
1209
1210 Installation of each component is performed by the L<setup_component> method,
1211 below.
1212
1213 =cut
1214
1215 sub setup_components {
1216     my $class = shift;
1217
1218     my $config  = $class->config->{ setup_components };
1219
1220     my @comps = sort { length $a <=> length $b }
1221                 $class->locate_components($config);
1222     my %comps = map { $_ => 1 } @comps;
1223
1224     my $deprecatedcatalyst_component_names = grep { /::[CMV]::/ } @comps;
1225     $class->log->warn(qq{Your application is using the deprecated ::[MVC]:: type naming scheme.\n}.
1226         qq{Please switch your class names to ::Model::, ::View:: and ::Controller: as appropriate.\n}
1227     ) if $deprecatedcatalyst_component_names;
1228
1229     for my $component ( @comps ) {
1230
1231         # We pass ignore_loaded here so that overlay files for (e.g.)
1232         # Model::DBI::Schema sub-classes are loaded - if it's in @comps
1233         # we know M::P::O found a file on disk so this is safe
1234
1235         Catalyst::Utils::ensure_class_loaded( $component, { ignore_loaded => 1 } );
1236
1237         # Needs to be done as soon as the component is loaded, as loading a sub-component
1238         # (next time round the loop) can cause us to get the wrong metaclass..
1239         $class->_controller_init_base_classes($component);
1240     }
1241
1242     for my $component (@comps) {
1243         $class->components->{ $component } = $class->setup_component($component);
1244         for my $component ($class->expand_component_module( $component, $config )) {
1245             next if $comps{$component};
1246             $class->_controller_init_base_classes($component); # Also cover inner packages
1247             $class->components->{ $component } = $class->setup_component($component);
1248         }
1249     }
1250 }
1251
1252 =head2 $c->locate_components( $setup_component_config )
1253
1254 This method is meant to provide a list of component modules that should be
1255 setup for the application.  By default, it will use L<Module::Pluggable>.
1256
1257 Specify a C<setup_components> config option to pass additional options directly
1258 to L<Module::Pluggable>. To add additional search paths, specify a key named
1259 C<search_extra> as an array reference. Items in the array beginning with C<::>
1260 will have the application class name prepended to them.
1261
1262 =cut
1263
1264 sub locate_components {
1265     my $class  = shift;
1266     my $config = shift;
1267
1268     my @paths   = qw( ::Controller ::C ::Model ::M ::View ::V );
1269     my $extra   = delete $config->{ search_extra } || [];
1270
1271     push @paths, @$extra;
1272
1273     my $locator = Module::Pluggable::Object->new(
1274         search_path => [ map { s/^(?=::)/$class/; $_; } @paths ],
1275         %$config
1276     );
1277
1278     my @comps = $locator->plugins;
1279
1280     return @comps;
1281 }
1282
1283 =head2 $c->expand_component_module( $component, $setup_component_config )
1284
1285 Components found by C<locate_components> will be passed to this method, which
1286 is expected to return a list of component (package) names to be set up.
1287
1288 =cut
1289
1290 sub expand_component_module {
1291     my ($class, $module) = @_;
1292     return Devel::InnerPackage::list_packages( $module );
1293 }
1294
1295 =head2 $c->setup_component
1296
1297 =cut
1298
1299 # FIXME - Ugly, ugly hack to ensure the we force initialize non-moose base classes
1300 #         nearest to Catalyst::Controller first, no matter what order stuff happens
1301 #         to be loaded. There are TODO tests in Moose for this, see
1302 #         f2391d17574eff81d911b97be15ea51080500003
1303 sub _controller_init_base_classes {
1304     my ($app_class, $component) = @_;
1305     return unless $component->isa('Catalyst::Controller');
1306     foreach my $class ( reverse @{ mro::get_linear_isa($component) } ) {
1307         Moose::Meta::Class->initialize( $class )
1308             unless find_meta($class);
1309     }
1310 }
1311
1312 sub setup_component {
1313     my( $class, $component ) = @_;
1314
1315     unless ( $component->can( 'COMPONENT' ) ) {
1316         return $component;
1317     }
1318
1319     my $suffix = Catalyst::Utils::class2classsuffix( $component );
1320     my $config = $class->config->{ $suffix } || {};
1321     # Stash catalyst_component_name in the config here, so that custom COMPONENT
1322     # methods also pass it. local to avoid pointlessly shitting in config
1323     # for the debug screen, as $component is already the key name.
1324     local $config->{catalyst_component_name} = $component;
1325
1326     my $instance = eval { $component->COMPONENT( $class, $config ); };
1327
1328     if ( my $error = $@ ) {
1329         chomp $error;
1330         Catalyst::Exception->throw(
1331             message => qq/Couldn't instantiate component "$component", "$error"/
1332         );
1333     }
1334
1335     unless (blessed $instance) {
1336         my $metaclass = Moose::Util::find_meta($component);
1337         my $method_meta = $metaclass->find_method_by_name('COMPONENT');
1338         my $component_method_from = $method_meta->associated_metaclass->name;
1339         my $value = defined($instance) ? $instance : 'undef';
1340         Catalyst::Exception->throw(
1341             message =>
1342             qq/Couldn't instantiate component "$component", COMPONENT() method (from $component_method_from) didn't return an object-like value (value was $value)./
1343         );
1344     }
1345     return $instance;
1346 }
1347
1348 =head2 $c->setup_dispatcher
1349
1350 Sets up dispatcher.
1351
1352 =cut
1353
1354 sub setup_dispatcher {
1355     my ( $class, $dispatcher ) = @_;
1356
1357     if ($dispatcher) {
1358         $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
1359     }
1360
1361     if ( my $env = Catalyst::Utils::env_value( $class, 'DISPATCHER' ) ) {
1362         $dispatcher = 'Catalyst::Dispatcher::' . $env;
1363     }
1364
1365     unless ($dispatcher) {
1366         $dispatcher = $class->dispatcher_class;
1367     }
1368
1369     Class::MOP::load_class($dispatcher);
1370
1371     # dispatcher instance
1372     $class->dispatcher( $dispatcher->new );
1373 }
1374
1375 =head2 $c->setup_engine
1376
1377 Sets up engine.
1378
1379 =cut
1380
1381 sub setup_engine {
1382     my ( $class, $engine ) = @_;
1383
1384     if ($engine) {
1385         $engine = 'Catalyst::Engine::' . $engine;
1386     }
1387
1388     if ( my $env = Catalyst::Utils::env_value( $class, 'ENGINE' ) ) {
1389         $engine = 'Catalyst::Engine::' . $env;
1390     }
1391
1392     if ( $ENV{MOD_PERL} ) {
1393         my $meta = Class::MOP::get_metaclass_by_name($class);
1394
1395         # create the apache method
1396         $meta->add_method('apache' => sub { shift->engine->apache });
1397
1398         my ( $software, $version ) =
1399           $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
1400
1401         $version =~ s/_//g;
1402         $version =~ s/(\.[^.]+)\./$1/g;
1403
1404         if ( $software eq 'mod_perl' ) {
1405
1406             if ( !$engine ) {
1407
1408                 if ( $version >= 1.99922 ) {
1409                     $engine = 'Catalyst::Engine::Apache2::MP20';
1410                 }
1411
1412                 elsif ( $version >= 1.9901 ) {
1413                     $engine = 'Catalyst::Engine::Apache2::MP19';
1414                 }
1415
1416                 elsif ( $version >= 1.24 ) {
1417                     $engine = 'Catalyst::Engine::Apache::MP13';
1418                 }
1419
1420                 else {
1421                     Catalyst::Exception->throw( message =>
1422                           qq/Unsupported mod_perl version: $ENV{MOD_PERL}/ );
1423                 }
1424
1425             }
1426
1427             # install the correct mod_perl handler
1428             if ( $version >= 1.9901 ) {
1429                 *handler = sub  : method {
1430                     shift->handle_request(@_);
1431                 };
1432             }
1433             else {
1434                 *handler = sub ($$) { shift->handle_request(@_) };
1435             }
1436
1437         }
1438
1439         elsif ( $software eq 'Zeus-Perl' ) {
1440             $engine = 'Catalyst::Engine::Zeus';
1441         }
1442
1443         else {
1444             Catalyst::Exception->throw(
1445                 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/ );
1446         }
1447     }
1448
1449     unless ($engine) {
1450         $engine = $class->engine_class;
1451     }
1452
1453     Class::MOP::load_class($engine);
1454
1455     # check for old engines that are no longer compatible
1456     my $old_engine;
1457     if ( $engine->isa('Catalyst::Engine::Apache')
1458         && !Catalyst::Engine::Apache->VERSION )
1459     {
1460         $old_engine = 1;
1461     }
1462
1463     elsif ( $engine->isa('Catalyst::Engine::Server::Base')
1464         && Catalyst::Engine::Server->VERSION le '0.02' )
1465     {
1466         $old_engine = 1;
1467     }
1468
1469     elsif ($engine->isa('Catalyst::Engine::HTTP::POE')
1470         && $engine->VERSION eq '0.01' )
1471     {
1472         $old_engine = 1;
1473     }
1474
1475     elsif ($engine->isa('Catalyst::Engine::Zeus')
1476         && $engine->VERSION eq '0.01' )
1477     {
1478         $old_engine = 1;
1479     }
1480
1481     if ($old_engine) {
1482         Catalyst::Exception->throw( message =>
1483               qq/Engine "$engine" is not supported by this version of Catalyst/
1484         );
1485     }
1486
1487     # engine instance
1488     $class->engine( $engine->new );
1489 }
1490
1491 =head2 $c->setup_home
1492
1493 Sets up the home directory.
1494
1495 =cut
1496
1497 sub setup_home {
1498     my ( $class, $home ) = @_;
1499
1500     if ( my $env = Catalyst::Utils::env_value( $class, 'HOME' ) ) {
1501         $home = $env;
1502     }
1503
1504     $home ||= Catalyst::Utils::home($class);
1505
1506     if ($home) {
1507         #I remember recently being scolded for assigning config values like this
1508         $class->config->{home} ||= $home;
1509         $class->config->{root} ||= Path::Class::Dir->new($home)->subdir('root');
1510     }
1511 }
1512
1513 =head2 $c->setup_log
1514
1515 Sets up log by instantiating a L<Catalyst::Log|Catalyst::Log> object and
1516 passing it to C<log()>. Pass in a comma-delimited list of levels to set the
1517 log to.
1518
1519 This method also installs a C<debug> method that returns a true value into the
1520 catalyst subclass if the "debug" level is passed in the comma-delimited list,
1521 or if the C<$CATALYST_DEBUG> environment variable is set to a true value.
1522
1523 Note that if the log has already been setup, by either a previous call to
1524 C<setup_log> or by a call such as C<< __PACKAGE__->log( MyLogger->new ) >>,
1525 that this method won't actually set up the log object.
1526
1527 =cut
1528
1529 sub setup_log {
1530     my ( $class, $levels ) = @_;
1531
1532     $levels ||= '';
1533     $levels =~ s/^\s+//;
1534     $levels =~ s/\s+$//;
1535     my %levels = map { $_ => 1 } split /\s*,\s*/, $levels;
1536
1537     my $env_debug = Catalyst::Utils::env_value( $class, 'DEBUG' );
1538     if ( defined $env_debug ) {
1539         $levels{debug} = 1 if $env_debug; # Ugly!
1540         delete($levels{debug}) unless $env_debug;
1541     }
1542
1543     unless ( $class->log ) {
1544         $class->log( Catalyst::Log->new(keys %levels) );
1545     }
1546
1547     if ( $levels{debug} ) {
1548         Class::MOP::get_metaclass_by_name($class)->add_method('debug' => sub { 1 });
1549         $class->log->debug('Debug messages enabled');
1550     }
1551 }
1552
1553 =head2 $c->setup_plugins
1554
1555 Sets up plugins.
1556
1557 =cut
1558
1559 =head2 $c->setup_stats
1560
1561 Sets up timing statistics class.
1562
1563 =cut
1564
1565 sub setup_stats {
1566     my ( $class, $stats ) = @_;
1567
1568     Catalyst::Utils::ensure_class_loaded($class->stats_class);
1569
1570     my $env = Catalyst::Utils::env_value( $class, 'STATS' );
1571     if ( defined($env) ? $env : ($stats || $class->debug ) ) {
1572         Class::MOP::get_metaclass_by_name($class)->add_method('use_stats' => sub { 1 });
1573         $class->log->debug('Statistics enabled');
1574     }
1575 }
1576
1577
1578 =head2 $c->registered_plugins
1579
1580 Returns a sorted list of the plugins which have either been stated in the
1581 import list or which have been added via C<< MyApp->plugin(@args); >>.
1582
1583 If passed a given plugin name, it will report a boolean value indicating
1584 whether or not that plugin is loaded.  A fully qualified name is required if
1585 the plugin name does not begin with C<Catalyst::Plugin::>.
1586
1587  if ($c->registered_plugins('Some::Plugin')) {
1588      ...
1589  }
1590
1591 =cut
1592
1593 {
1594
1595     sub registered_plugins {
1596         my $proto = shift;
1597         return sort keys %{ $proto->_plugins } unless @_;
1598         my $plugin = shift;
1599         return 1 if exists $proto->_plugins->{$plugin};
1600         return exists $proto->_plugins->{"Catalyst::Plugin::$plugin"};
1601     }
1602
1603     sub _register_plugin {
1604         my ( $proto, $plugin, $instant ) = @_;
1605         my $class = ref $proto || $proto;
1606
1607         Class::MOP::load_class( $plugin );
1608
1609         $proto->_plugins->{$plugin} = 1;
1610         unless ($instant) {
1611             no strict 'refs';
1612             if ( my $meta = Class::MOP::get_metaclass_by_name($class) ) {
1613               my @superclasses = ($plugin, $meta->superclasses );
1614               $meta->superclasses(@superclasses);
1615             } else {
1616               unshift @{"$class\::ISA"}, $plugin;
1617             }
1618         }
1619         return $class;
1620     }
1621
1622     sub setup_plugins {
1623         my ( $class, $plugins ) = @_;
1624
1625         $class->_plugins( {} ) unless $class->_plugins;
1626         $plugins ||= [];
1627
1628         my @plugins = Catalyst::Utils::resolve_namespace($class . '::Plugin', 'Catalyst::Plugin', @$plugins);
1629
1630         for my $plugin ( reverse @plugins ) {
1631             Class::MOP::load_class($plugin);
1632             my $meta = find_meta($plugin);
1633             next if $meta && $meta->isa('Moose::Meta::Role');
1634
1635             $class->_register_plugin($plugin);
1636         }
1637
1638         my @roles =
1639             map { $_->name }
1640             grep { $_ && blessed($_) && $_->isa('Moose::Meta::Role') }
1641             map { find_meta($_) }
1642             @plugins;
1643
1644         Moose::Util::apply_all_roles(
1645             $class => @roles
1646         ) if @roles;
1647     }
1648 }
1649
1650 =head2 $c->stats_class
1651
1652 Returns or sets the stats (timing statistics) class.
1653
1654 =head2 $c->use_stats
1655
1656 Returns 1 when stats collection is enabled.  Stats collection is enabled
1657 when the -Stats options is set, debug is on or when the <MYAPP>_STATS
1658 environment variable is set.
1659
1660 Note that this is a static method, not an accessor and should be overridden
1661 by declaring C<sub use_stats { 1 }> in your MyApp.pm, not by calling C<< $c->use_stats(1) >>.
1662
1663 =cut
1664
1665 sub use_stats { 0 }
1666
1667 =head2 version
1668
1669 Returns the Catalyst version number. Mostly useful for "powered by"
1670 messages in template systems.
1671
1672 =cut
1673
1674 sub version { return $Catalyst::VERSION }
1675
1676 =head1 CONFIGURATION
1677
1678 There are a number of 'base' config variables which can be set:
1679
1680 =over
1681
1682 =item *
1683
1684 C<default_model> - The default model picked if you say C<< $c->model >>. See L</$c->model($name)>.
1685
1686 =item *
1687
1688 C<default_view> - The default view to be rendered or returned when C<< $c->view >>. See L</$c->view($name)>.
1689 is called.
1690
1691 =item *
1692
1693 C<disable_component_resolution_regex_fallback> - Turns
1694 off the deprecated component resolution functionality so
1695 that if any of the component methods (e.g. C<< $c->controller('Foo') >>)
1696 are called then regex search will not be attempted on string values and
1697 instead C<undef> will be returned.
1698
1699 =item *
1700
1701 C<home> - The application home directory. In an uninstalled application,
1702 this is the top level application directory. In an installed application,
1703 this will be the directory containing C<< MyApp.pm >>.
1704
1705 =item *
1706
1707 C<ignore_frontend_proxy> - See L</PROXY SUPPORT>
1708
1709 =item *
1710
1711 C<name> - The name of the application in debug messages and the debug and
1712 welcome screens
1713
1714 =item *
1715
1716 C<parse_on_demand> - The request body (for example file uploads) will not be parsed
1717 until it is accessed. This allows you to (for example) check authentication (and reject
1718 the upload) before actually recieving all the data. See L</ON-DEMAND PARSER>
1719
1720 =item *
1721
1722 C<root> - The root directory for templates. Usually this is just a
1723 subdirectory of the home directory, but you can set it to change the
1724 templates to a different directory.
1725
1726 =item *
1727
1728 C<search_extra> - Array reference passed to Module::Pluggable to for additional
1729 namespaces from which components will be loaded (and constructed and stored in
1730 C<< $c->components >>).
1731
1732 =item *
1733
1734 C<show_internal_actions> - If true, causes internal actions such as C<< _DISPATCH >>
1735 to be shown in hit debug tables in the test server.
1736
1737 =item *
1738
1739 C<using_frontend_proxy> - See L</PROXY SUPPORT>.
1740
1741 =back
1742
1743 =head1 INTERNAL ACTIONS
1744
1745 Catalyst uses internal actions like C<_DISPATCH>, C<_BEGIN>, C<_AUTO>,
1746 C<_ACTION>, and C<_END>. These are by default not shown in the private
1747 action table, but you can make them visible with a config parameter.
1748
1749     MyApp->config(show_internal_actions => 1);
1750
1751 =head1 ON-DEMAND PARSER
1752
1753 The request body is usually parsed at the beginning of a request,
1754 but if you want to handle input yourself, you can enable on-demand
1755 parsing with a config parameter.
1756
1757     MyApp->config(parse_on_demand => 1);
1758
1759 =head1 PROXY SUPPORT
1760
1761 Many production servers operate using the common double-server approach,
1762 with a lightweight frontend web server passing requests to a larger
1763 backend server. An application running on the backend server must deal
1764 with two problems: the remote user always appears to be C<127.0.0.1> and
1765 the server's hostname will appear to be C<localhost> regardless of the
1766 virtual host that the user connected through.
1767
1768 Catalyst will automatically detect this situation when you are running
1769 the frontend and backend servers on the same machine. The following
1770 changes are made to the request.
1771
1772     $c->req->address is set to the user's real IP address, as read from
1773     the HTTP X-Forwarded-For header.
1774
1775     The host value for $c->req->base and $c->req->uri is set to the real
1776     host, as read from the HTTP X-Forwarded-Host header.
1777
1778 Additionally, you may be running your backend application on an insecure
1779 connection (port 80) while your frontend proxy is running under SSL.  If there
1780 is a discrepancy in the ports, use the HTTP header C<X-Forwarded-Port> to
1781 tell Catalyst what port the frontend listens on.  This will allow all URIs to
1782 be created properly.
1783
1784 In the case of passing in:
1785
1786     X-Forwarded-Port: 443
1787
1788 All calls to C<uri_for> will result in an https link, as is expected.
1789
1790 Obviously, your web server must support these headers for this to work.
1791
1792 In a more complex server farm environment where you may have your
1793 frontend proxy server(s) on different machines, you will need to set a
1794 configuration option to tell Catalyst to read the proxied data from the
1795 headers.
1796
1797     MyApp->config(using_frontend_proxy => 1);
1798
1799 If you do not wish to use the proxy support at all, you may set:
1800
1801     MyApp->config(ignore_frontend_proxy => 1);
1802
1803 =head1 THREAD SAFETY
1804
1805 Catalyst has been tested under Apache 2's threading C<mpm_worker>,
1806 C<mpm_winnt>, and the standalone forking HTTP server on Windows. We
1807 believe the Catalyst core to be thread-safe.
1808
1809 If you plan to operate in a threaded environment, remember that all other
1810 modules you are using must also be thread-safe. Some modules, most notably
1811 L<DBD::SQLite>, are not thread-safe.
1812
1813 =head1 SUPPORT
1814
1815 IRC:
1816
1817     Join #catalyst on irc.perl.org.
1818
1819 Mailing Lists:
1820
1821     http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst
1822     http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst-dev
1823
1824 Web:
1825
1826     http://catalyst.perl.org
1827
1828 Wiki:
1829
1830     http://dev.catalyst.perl.org
1831
1832 =head1 SEE ALSO
1833
1834 =head2 L<Task::Catalyst> - All you need to start with Catalyst
1835
1836 =head2 L<Catalyst::Manual> - The Catalyst Manual
1837
1838 =head2 L<Catalyst::Component>, L<Catalyst::Controller> - Base classes for components
1839
1840 =head2 L<Catalyst::Engine> - Core engine
1841
1842 =head2 L<Catalyst::Log> - Log class.
1843
1844 =head2 L<Catalyst::Request> - Request object
1845
1846 =head2 L<Catalyst::Response> - Response object
1847
1848 =head2 L<Catalyst::Test> - The test suite.
1849
1850 =head1 PROJECT FOUNDER
1851
1852 sri: Sebastian Riedel <sri@cpan.org>
1853
1854 =head1 CONTRIBUTORS
1855
1856 abw: Andy Wardley
1857
1858 acme: Leon Brocard <leon@astray.com>
1859
1860 abraxxa: Alexander Hartmaier <abraxxa@cpan.org>
1861
1862 Andrew Bramble
1863
1864 Andrew Ford E<lt>A.Ford@ford-mason.co.ukE<gt>
1865
1866 Andrew Ruthven
1867
1868 andyg: Andy Grundman <andy@hybridized.org>
1869
1870 audreyt: Audrey Tang
1871
1872 bricas: Brian Cassidy <bricas@cpan.org>
1873
1874 Caelum: Rafael Kitover <rkitover@io.com>
1875
1876 chansen: Christian Hansen
1877
1878 chicks: Christopher Hicks
1879
1880 Chisel Wright C<pause@herlpacker.co.uk>
1881
1882 Danijel Milicevic C<me@danijel.de>
1883
1884 David Kamholz E<lt>dkamholz@cpan.orgE<gt>
1885
1886 David Naughton, C<naughton@umn.edu>
1887
1888 David E. Wheeler
1889
1890 dkubb: Dan Kubb <dan.kubb-cpan@onautopilot.com>
1891
1892 Drew Taylor
1893
1894 dwc: Daniel Westermann-Clark <danieltwc@cpan.org>
1895
1896 esskar: Sascha Kiefer
1897
1898 fireartist: Carl Franks <cfranks@cpan.org>
1899
1900 frew: Arthur Axel "fREW" Schmidt <frioux@gmail.com>
1901
1902 gabb: Danijel Milicevic
1903
1904 Gary Ashton Jones
1905
1906 Gavin Henry C<ghenry@perl.me.uk>
1907
1908 Geoff Richards
1909
1910 groditi: Guillermo Roditi <groditi@gmail.com>
1911
1912 hobbs: Andrew Rodland <andrew@cleverdomain.org>
1913
1914 ilmari: Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
1915
1916 jcamacho: Juan Camacho
1917
1918 jester: Jesse Sheidlower C<jester@panix.com>
1919
1920 jhannah: Jay Hannah <jay@jays.net>
1921
1922 Jody Belka
1923
1924 Johan Lindstrom
1925
1926 jon: Jon Schutz <jjschutz@cpan.org>
1927
1928 Jonathan Rockway C<< <jrockway@cpan.org> >>
1929
1930 Kieren Diment C<kd@totaldatasolution.com>
1931
1932 konobi: Scott McWhirter <konobi@cpan.org>
1933
1934 marcus: Marcus Ramberg <mramberg@cpan.org>
1935
1936 miyagawa: Tatsuhiko Miyagawa <miyagawa@bulknews.net>
1937
1938 mst: Matt S. Trout <mst@shadowcatsystems.co.uk>
1939
1940 mugwump: Sam Vilain
1941
1942 naughton: David Naughton
1943
1944 ningu: David Kamholz <dkamholz@cpan.org>
1945
1946 nothingmuch: Yuval Kogman <nothingmuch@woobling.org>
1947
1948 numa: Dan Sully <daniel@cpan.org>
1949
1950 obra: Jesse Vincent
1951
1952 omega: Andreas Marienborg
1953
1954 Oleg Kostyuk <cub.uanic@gmail.com>
1955
1956 phaylon: Robert Sedlacek <phaylon@dunkelheit.at>
1957
1958 rafl: Florian Ragwitz <rafl@debian.org>
1959
1960 random: Roland Lammel <lammel@cpan.org>
1961
1962 Robert Sedlacek C<< <rs@474.at> >>
1963
1964 sky: Arthur Bergman
1965
1966 t0m: Tomas Doran <bobtfish@bobtfish.net>
1967
1968 Ulf Edvinsson
1969
1970 Viljo Marrandi C<vilts@yahoo.com>
1971
1972 Will Hawes C<info@whawes.co.uk>
1973
1974 willert: Sebastian Willert <willert@cpan.org>
1975
1976 Yuval Kogman, C<nothingmuch@woobling.org>
1977
1978 =head1 LICENSE
1979
1980 This library is free software. You can redistribute it and/or modify it under
1981 the same terms as Perl itself.
1982
1983 =cut
1984
1985 no Moose;
1986
1987 __PACKAGE__->meta->make_immutable;
1988
1989 1;