Commit | Line | Data |
5d9a6d47 |
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 | |
5993f5a2 |
24 | =item $c->setup_components |
5d9a6d47 |
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; |