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