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