lib/Catalyst/Setup.pm

   1 package Catalyst::Setup;
   2
   3 use strict;
   4 use Catalyst::Exception;
   5 use Catalyst::Log;
   6 use Catalyst::Utils;
   7 use Path::Class;
   8 use Text::ASCIITable;
   9
  10 =head1 NAME
  11
  12 Catalyst::Setup - The Catalyst Setup class
  13
  14 =head1 SYNOPSIS
  15
  16 See L<Catalyst>.
  17
  18 =head1 DESCRIPTION
  19
  20 =head1 METHODS
  21
  22 =over 4
  23
  24 =item $class->setup_components
  25
  26 Setup components.
  27
  28 =cut
  29
  30 sub setup_components {
  31     my $class = shift;
  32
  33     my $callback = sub {
  34         my ( $component, $context ) = @_;
  35
  36         unless ( $component->isa('Catalyst::Base') ) {
  37             return $component;
  38         }
  39
  40         my $suffix = Catalyst::Utils::class2classsuffix($component);
  41         my $config = $class->config->{$suffix} || {};
  42
  43         my $instance;
  44
  45         eval { $instance = $component->new( $context, $config ); };
  46
  47         if ( my $error = $@ ) {
  48
  49             chomp $error;
  50
  51             Catalyst::Exception->throw(
  52                 message => qq/Couldn't instantiate component "$component", "$error"/
  53             );
  54         }
  55
  56         return $instance;
  57     };
  58
  59     eval {
  60         Module::Pluggable::Fast->import(
  61             name   => '_components',
  62             search => [
  63                 "$class\::Controller", "$class\::C",
  64                 "$class\::Model",      "$class\::M",
  65                 "$class\::View",       "$class\::V"
  66             ],
  67             callback => $callback
  68         );
  69     };
  70
  71     if ( my $error = $@ ) {
  72
  73         chomp $error;
  74
  75         Catalyst::Exception->throw(
  76             message => qq/Couldn't load components "$error"/
  77         );
  78     }
  79
  80     for my $component ( $class->_components($class) ) {
  81         $class->components->{ ref $component || $component } = $component;
  82     }
  83 }
  84
  85 =item $c->setup_dispatcher
  86
  87 =cut
  88
  89 sub setup_dispatcher {
  90     my ( $class, $dispatcher ) = @_;
  91
  92     if ( $dispatcher ) {
  93         $dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
  94     }
  95
  96     if ( $ENV{CATALYST_DISPATCHER} ) {
  97         $dispatcher = 'Catalyst::Dispatcher::' . $ENV{CATALYST_DISPATCHER};
  98     }
  99
 100     if ( $ENV{ uc($class) . '_DISPATCHER' } ) {
 101         $dispatcher = 'Catalyst::Dispatcher::' . $ENV{ uc($class) . '_DISPATCHER' };
 102     }
 103
 104     unless ( $dispatcher ) {
 105         $dispatcher = 'Catalyst::Dispatcher';
 106     }
 107
 108     $dispatcher->require;
 109
 110     if ( $@ ) {
 111         Catalyst::Exception->throw(
 112             message => qq/Couldn't load dispatcher "$dispatcher", "$@"/
 113         );
 114     }
 115
 116     {
 117         no strict 'refs';
 118         push @{"$class\::ISA"}, $dispatcher;
 119     }
 120
 121     $class->dispatcher($dispatcher);
 122 }
 123
 124 =item $c->setup_engine
 125
 126 =cut
 127
 128 sub setup_engine {
 129     my ( $class, $engine ) = @_;
 130
 131     if ( $engine ) {
 132         $engine = 'Catalyst::Engine::' . $engine;
 133     }
 134
 135     if ( $ENV{CATALYST_ENGINE} ) {
 136         $engine = 'Catalyst::Engine::' . $ENV{CATALYST_ENGINE};
 137     }
 138
 139     if ( $ENV{ uc($class) . '_ENGINE' } ) {
 140         $engine = 'Catalyst::Engine::' . $ENV{ uc($class) . '_ENGINE' };
 141     }
 142
 143     if ( ! $engine && $ENV{MOD_PERL} ) {
 144
 145         my ( $software, $version ) = $ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
 146
 147         $version =~ s/_//g;
 148         $version =~ s/(\.[^.]+)\./$1/g;
 149
 150         if ( $software eq 'mod_perl') {
 151
 152             if ( $version >= 1.99922 ) {
 153
 154                 $engine = 'Catalyst::Engine::Apache::MP20';
 155
 156                 if ( Apache2::Request->require ) {
 157                     $engine = 'Catalyst::Engine::Apache::MP20::Apreq';
 158                 }
 159             }
 160
 161             elsif ( $version >= 1.9901 ) {
 162
 163                 $engine = 'Catalyst::Engine::Apache::MP19';
 164
 165                 if ( Apache::Request->require ) {
 166                     $engine = 'Catalyst::Engine::Apache::MP19::Apreq';
 167                 }
 168             }
 169
 170             elsif ( $version >= 1.24 ) {
 171
 172                 $engine = 'Catalyst::Engine::Apache::MP13';
 173
 174                 if ( Apache::Request->require ) {
 175                     $engine = 'Catalyst::Engine::Apache::MP13::Apreq';
 176                 }
 177             }
 178
 179             else {
 180                 Catalyst::Exception->throw(
 181                     message => qq/Unsupported mod_perl version: $ENV{MOD_PERL}/
 182                 );
 183             }
 184         }
 185
 186         elsif ( $software eq 'Zeus-Perl' ) {
 187             $engine = 'Catalyst::Engine::Zeus';
 188         }
 189
 190         else {
 191             Catalyst::Exception->throw(
 192                 message => qq/Unsupported mod_perl: $ENV{MOD_PERL}/
 193             );
 194         }
 195     }
 196
 197     unless ( $engine ) {
 198         $engine = 'Catalyst::Engine::CGI';
 199     }
 200
 201     $engine->require;
 202
 203     if ( $@ ) {
 204         Catalyst::Exception->throw(
 205             message => qq/Couldn't load engine "$engine", "$@"/
 206         );
 207     }
 208
 209     {
 210         no strict 'refs';
 211         push @{"$class\::ISA"}, $engine;
 212     }
 213
 214     $class->engine($engine);
 215 }
 216
 217 =item $c->setup_home
 218
 219 =cut
 220
 221 sub setup_home {
 222     my ( $class, $home ) = @_;
 223
 224     if ( $ENV{CATALYST_HOME} ) {
 225         $home = $ENV{CATALYST_HOME};
 226     }
 227
 228     if ( $ENV{ uc($class) . '_HOME' } ) {
 229         $home = $ENV{ uc($class) . '_HOME' };
 230     }
 231
 232     unless ( $home ) {
 233         $home = Catalyst::Utils::home($class);
 234     }
 235
 236     if ( $home ) {
 237         $class->config->{home} = $home;
 238         $class->config->{root} = dir($home)->subdir('root');
 239     }
 240 }
 241
 242 =item $c->setup_log
 243
 244 =cut
 245
 246 sub setup_log {
 247     my ( $class, $debug ) = @_;
 248
 249     unless ( $class->log ) {
 250         $class->log( Catalyst::Log->new );
 251     }
 252
 253     if ( $ENV{CATALYST_DEBUG} || $ENV{ uc($class) . '_DEBUG' } || $debug ) {
 254         no strict 'refs';
 255         *{"$class\::debug"} = sub { 1 };
 256         $class->log->debug('Debug messages enabled');
 257     }
 258 }
 259
 260 =item $c->setup_plugins
 261
 262 =cut
 263
 264 sub setup_plugins {
 265     my ( $class, $plugins ) = @_;
 266
 267     for my $plugin ( @$plugins ) {
 268
 269         $plugin = "Catalyst::Plugin::$plugin";
 270
 271         $plugin->require;
 272
 273         if ( $@ ) {
 274             Catalyst::Exception->throw(
 275                 message => qq/Couldn't load plugin "$plugin", "$@"/
 276             );
 277         }
 278
 279         {
 280             no strict 'refs';
 281             push @{"$class\::ISA"}, $plugin;
 282         }
 283     }
 284 }
 285
 286 =back
 287
 288 =head1 AUTHOR
 289
 290 Sebastian Riedel, C<sri@cpan.org>
 291 Christian Hansen, C<ch@ngmedia.com>
 292
 293 =head1 COPYRIGHT
 294
 295 This program is free software, you can redistribute it and/or modify
 296 it under the same terms as Perl itself.
 297
 298 =cut
 299
 300 1;