Commit | Line | Data |
6aaee015 |
1 | package CPANPLUS::Dist; |
2 | |
3 | use strict; |
4 | |
5 | |
6 | use CPANPLUS::Error; |
7 | use CPANPLUS::Internals::Constants; |
8 | |
9 | use Params::Check qw[check]; |
10 | use Module::Load::Conditional qw[can_load check_install]; |
11 | use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; |
12 | use Object::Accessor; |
13 | |
14 | local $Params::Check::VERBOSE = 1; |
15 | |
16 | my @methods = qw[status parent]; |
17 | for my $key ( @methods ) { |
18 | no strict 'refs'; |
19 | *{__PACKAGE__."::$key"} = sub { |
20 | my $self = shift; |
21 | $self->{$key} = $_[0] if @_; |
22 | return $self->{$key}; |
23 | } |
24 | } |
25 | |
26 | =pod |
27 | |
28 | =head1 NAME |
29 | |
30 | CPANPLUS::Dist |
31 | |
32 | =head1 SYNOPSIS |
33 | |
34 | my $dist = CPANPLUS::Dist->new( |
35 | format => 'build', |
36 | module => $modobj, |
37 | ); |
38 | |
39 | =head1 DESCRIPTION |
40 | |
41 | C<CPANPLUS::Dist> is a base class for any type of C<CPANPLUS::Dist::> |
42 | modules. |
43 | |
44 | =head1 ACCESSORS |
45 | |
46 | =over 4 |
47 | |
48 | =item parent() |
49 | |
50 | Returns the C<CPANPLUS::Module> object that parented this object. |
51 | |
52 | =item status() |
53 | |
54 | Returns the C<Object::Accessor> object that keeps the status for |
55 | this module. |
56 | |
57 | =back |
58 | |
59 | =head1 STATUS ACCESSORS |
60 | |
61 | All accessors can be accessed as follows: |
62 | $deb->status->ACCESSOR |
63 | |
64 | =over 4 |
65 | |
66 | =item created() |
67 | |
68 | Boolean indicating whether the dist was created successfully. |
69 | Explicitly set to C<0> when failed, so a value of C<undef> may be |
70 | interpreted as C<not yet attempted>. |
71 | |
72 | =item installed() |
73 | |
74 | Boolean indicating whether the dist was installed successfully. |
75 | Explicitly set to C<0> when failed, so a value of C<undef> may be |
76 | interpreted as C<not yet attempted>. |
77 | |
78 | =item uninstalled() |
79 | |
80 | Boolean indicating whether the dist was uninstalled successfully. |
81 | Explicitly set to C<0> when failed, so a value of C<undef> may be |
82 | interpreted as C<not yet attempted>. |
83 | |
84 | =item dist() |
85 | |
86 | The location of the final distribution. This may be a file or |
87 | directory, depending on how your distribution plug in of choice |
88 | works. This will be set upon a successful create. |
89 | |
90 | =cut |
91 | |
622d31ac |
92 | =back |
93 | |
6aaee015 |
94 | =head2 $dist = CPANPLUS::Dist->new( module => MODOBJ, [format => DIST_TYPE] ); |
95 | |
96 | Create a new C<CPANPLUS::Dist> object based on the provided C<MODOBJ>. |
97 | The optional argument C<format> is used to indicate what type of dist |
98 | you would like to create (like C<makemaker> for a C<CPANPLUS::Dist::MM> |
99 | object, C<build> for a C<CPANPLUS::Dist::Build> object, and so on ). |
100 | If not provided, will default to the setting as specified by your |
101 | config C<dist_type>. |
102 | |
103 | Returns a C<CPANPLUS::Dist> object on success and false on failure. |
104 | |
105 | =cut |
106 | |
107 | sub new { |
108 | my $self = shift; |
109 | my %hash = @_; |
110 | |
111 | local $Params::Check::ALLOW_UNKNOWN = 1; |
112 | |
113 | ### first verify we got a module object ### |
114 | my $mod; |
115 | my $tmpl = { |
116 | module => { required => 1, allow => IS_MODOBJ, store => \$mod }, |
117 | }; |
118 | check( $tmpl, \%hash ) or return; |
119 | |
120 | ### get the conf object ### |
121 | my $conf = $mod->parent->configure_object(); |
122 | |
123 | ### figure out what type of dist object to create ### |
124 | my $format; |
125 | my $tmpl2 = { |
126 | format => { default => $conf->get_conf('dist_type'), |
127 | allow => [ __PACKAGE__->dist_types ], |
128 | store => \$format }, |
129 | }; |
130 | check( $tmpl2, \%hash ) or return; |
131 | |
132 | |
133 | unless( can_load( modules => { $format => '0.0' }, verbose => 1 ) ) { |
134 | error(loc("'%1' not found -- you need '%2' version '%3' or higher ". |
135 | "to detect plugins", $format, 'Module::Pluggable','2.4')); |
136 | return; |
137 | } |
138 | |
139 | ### bless the object in the child class ### |
140 | my $obj = bless { parent => $mod }, $format; |
141 | |
142 | ### check if the format is available in this environment ### |
143 | if( $conf->_get_build('sanity_check') and not $obj->format_available ) { |
144 | error( loc( "Format '%1' is not available",$format) ); |
145 | return; |
146 | } |
147 | |
148 | ### create a status object ### |
149 | { my $acc = Object::Accessor->new; |
150 | $obj->status($acc); |
151 | |
152 | ### add minimum supported accessors |
153 | $acc->mk_accessors( qw[prepared created installed uninstalled |
154 | distdir dist] ); |
155 | } |
156 | |
157 | ### now initialize it or admit failure |
158 | unless( $obj->init ) { |
159 | error(loc("Dist initialization of '%1' failed for '%2'", |
160 | $format, $mod->module)); |
161 | return; |
162 | } |
163 | |
164 | ### return the object |
165 | return $obj; |
166 | } |
167 | |
168 | =head2 @dists = CPANPLUS::Dist->dist_types; |
169 | |
170 | Returns a list of the CPANPLUS::Dist::* classes available |
171 | |
172 | =cut |
173 | |
174 | ### returns a list of dist_types we support |
175 | ### will get overridden by Module::Pluggable if loaded |
176 | ### XXX add support for 'plugin' dir in config as well |
177 | { my $Loaded; |
178 | my @Dists = (INSTALLER_MM); |
179 | my @Ignore = (); |
180 | |
181 | ### backdoor method to add more dist types |
182 | sub _add_dist_types { my $self = shift; push @Dists, @_ }; |
183 | |
184 | ### backdoor method to exclude dist types |
185 | sub _ignore_dist_types { my $self = shift; push @Ignore, @_ }; |
186 | |
187 | ### locally add the plugins dir to @INC, so we can find extra plugins |
188 | #local @INC = @INC, File::Spec->catdir( |
189 | # $conf->get_conf('base'), |
190 | # $conf->_get_build('plugins') ); |
191 | |
192 | ### load any possible plugins |
193 | sub dist_types { |
194 | |
195 | if ( !$Loaded++ and check_install( module => 'Module::Pluggable', |
196 | version => '2.4') |
197 | ) { |
198 | require Module::Pluggable; |
199 | |
200 | my $only_re = __PACKAGE__ . '::\w+$'; |
201 | |
202 | Module::Pluggable->import( |
203 | sub_name => '_dist_types', |
204 | search_path => __PACKAGE__, |
205 | only => qr/$only_re/, |
206 | except => [ INSTALLER_MM, |
207 | INSTALLER_SAMPLE, |
208 | INSTALLER_BASE, |
209 | ] |
210 | ); |
211 | my %ignore = map { $_ => $_ } @Ignore; |
212 | |
213 | push @Dists, grep { not $ignore{$_} } __PACKAGE__->_dist_types; |
214 | } |
215 | |
216 | return @Dists; |
217 | } |
218 | } |
219 | |
220 | =head2 prereq_satisfied( modobj => $modobj, version => $version_spec ) |
221 | |
222 | Returns true if this prereq is satisfied. Returns false if it's not. |
223 | Also issues an error if it seems "unsatisfiable," i.e. if it can't be |
224 | found on CPAN or the latest CPAN version doesn't satisfy it. |
225 | |
226 | =cut |
227 | |
228 | sub prereq_satisfied { |
229 | my $dist = shift; |
230 | my $cb = $dist->parent->parent; |
231 | my %hash = @_; |
232 | |
233 | my($mod,$ver); |
234 | my $tmpl = { |
235 | version => { required => 1, store => \$ver }, |
236 | modobj => { required => 1, store => \$mod, allow => IS_MODOBJ }, |
237 | }; |
238 | |
239 | check( $tmpl, \%hash ) or return; |
240 | |
241 | return 1 if $mod->is_uptodate( version => $ver ); |
242 | |
243 | if ( $cb->_vcmp( $ver, $mod->version ) > 0 ) { |
244 | |
245 | error(loc( |
246 | "This distribution depends on %1, but the latest version". |
247 | " of %2 on CPAN (%3) doesn't satisfy the specific version". |
248 | " dependency (%4). You may have to resolve this dependency ". |
249 | "manually.", |
250 | $mod->module, $mod->module, $mod->version, $ver )); |
251 | |
252 | } |
253 | |
254 | return; |
255 | } |
256 | |
257 | =head2 _resolve_prereqs |
258 | |
259 | Makes sure prerequisites are resolved |
260 | |
261 | XXX Need docs, internal use only |
262 | |
263 | =cut |
264 | |
265 | sub _resolve_prereqs { |
266 | my $dist = shift; |
267 | my $self = $dist->parent; |
268 | my $cb = $self->parent; |
269 | my $conf = $cb->configure_object; |
270 | my %hash = @_; |
271 | |
272 | my ($prereqs, $format, $verbose, $target, $force, $prereq_build); |
273 | my $tmpl = { |
274 | ### XXX perhaps this should not be required, since it may not be |
275 | ### packaged, just installed... |
276 | ### Let it be empty as well -- that means the $modobj->install |
277 | ### routine will figure it out, which is fine if we didn't have any |
278 | ### very specific wishes (it will even detect the favourite |
279 | ### dist_type). |
280 | format => { required => 1, store => \$format, |
281 | allow => ['',__PACKAGE__->dist_types], }, |
282 | prereqs => { required => 1, default => { }, |
283 | strict_type => 1, store => \$prereqs }, |
284 | verbose => { default => $conf->get_conf('verbose'), |
285 | store => \$verbose }, |
286 | force => { default => $conf->get_conf('force'), |
287 | store => \$force }, |
288 | ### make sure allow matches with $mod->install's list |
289 | target => { default => '', store => \$target, |
290 | allow => ['',qw[create ignore install]] }, |
291 | prereq_build => { default => 0, store => \$prereq_build }, |
292 | }; |
293 | |
294 | check( $tmpl, \%hash ) or return; |
295 | |
296 | ### so there are no prereqs? then don't even bother |
297 | return 1 unless keys %$prereqs; |
298 | |
299 | ### so you didn't provide an explicit target. |
300 | ### maybe your config can tell us what to do. |
301 | $target ||= { |
302 | PREREQ_ASK, TARGET_INSTALL, # we'll bail out if the user says no |
303 | PREREQ_BUILD, TARGET_CREATE, |
304 | PREREQ_IGNORE, TARGET_IGNORE, |
305 | PREREQ_INSTALL, TARGET_INSTALL, |
306 | }->{ $conf->get_conf('prereqs') } || ''; |
307 | |
308 | ### XXX BIG NASTY HACK XXX FIXME at some point. |
309 | ### when installing Bundle::CPANPLUS::Dependencies, we want to |
310 | ### install all packages matching 'cpanplus' to be installed last, |
311 | ### as all CPANPLUS' prereqs are being installed as well, but are |
312 | ### being loaded for bootstrapping purposes. This means CPANPLUS |
313 | ### can find them, but for example cpanplus::dist::build won't, |
314 | ### which gets messy FAST. So, here we sort our prereqs only IF |
315 | ### the parent module is Bundle::CPANPLUS::Dependencies. |
316 | ### Really, we would wnat some sort of sorted prereq mechanism, |
317 | ### but Bundle:: doesn't support it, and we flatten everything |
318 | ### to a hash internally. A sorted hash *might* do the trick if |
319 | ### we got a transparent implementation.. that would mean we would |
320 | ### just have to remove the 'sort' here, and all will be well |
321 | my @sorted_prereqs; |
322 | |
323 | ### use regex, could either be a module name, or a package name |
324 | if( $self->module =~ /^Bundle(::|-)CPANPLUS(::|-)Dependencies/ ) { |
325 | my (@first, @last); |
326 | for my $mod ( sort keys %$prereqs ) { |
327 | $mod =~ /CPANPLUS/ |
328 | ? push @last, $mod |
329 | : push @first, $mod; |
330 | } |
331 | @sorted_prereqs = (@first, @last); |
332 | } else { |
333 | @sorted_prereqs = sort keys %$prereqs; |
334 | } |
335 | |
336 | ### first, transfer this key/value pairing into a |
337 | ### list of module objects + desired versions |
338 | my @install_me; |
339 | |
340 | for my $mod ( @sorted_prereqs ) { |
341 | my $version = $prereqs->{$mod}; |
342 | my $modobj = $cb->module_tree($mod); |
343 | |
344 | #### XXX we ignore the version, and just assume that the latest |
345 | #### version from cpan will meet your requirements... dodgy =/ |
346 | unless( $modobj ) { |
347 | error( loc( "No such module '%1' found on CPAN", $mod ) ); |
348 | next; |
349 | } |
350 | |
351 | ### it's not uptodate, we need to install it |
352 | if( !$dist->prereq_satisfied(modobj => $modobj, version => $version)) { |
353 | msg(loc("Module '%1' requires '%2' version '%3' to be installed ", |
354 | $self->module, $modobj->module, $version), $verbose ); |
355 | |
356 | push @install_me, [$modobj, $version]; |
357 | |
358 | ### it's not an MM or Build format, that means it's a package |
359 | ### manager... we'll need to install it as well, via the PM |
360 | } elsif ( INSTALL_VIA_PACKAGE_MANAGER->($format) and |
361 | !$modobj->package_is_perl_core and |
362 | ($target ne TARGET_IGNORE) |
363 | ) { |
364 | msg(loc("Module '%1' depends on '%2', may need to build a '%3' ". |
365 | "package for it as well", $self->module, $modobj->module, |
366 | $format)); |
367 | push @install_me, [$modobj, $version]; |
368 | } |
369 | } |
370 | |
371 | |
372 | |
373 | ### so you just want to ignore prereqs? ### |
374 | if( $target eq TARGET_IGNORE ) { |
375 | |
376 | ### but you have modules you need to install |
377 | if( @install_me ) { |
378 | msg(loc("Ignoring prereqs, this may mean your install will fail"), |
379 | $verbose); |
380 | msg(loc("'%1' listed the following dependencies:", $self->module), |
381 | $verbose); |
382 | |
383 | for my $aref (@install_me) { |
384 | my ($mod,$version) = @$aref; |
385 | |
386 | my $str = sprintf "\t%-35s %8s\n", $mod->module, $version; |
387 | msg($str,$verbose); |
388 | } |
389 | |
390 | return; |
391 | |
392 | ### ok, no problem, you have all needed prereqs anyway |
393 | } else { |
394 | return 1; |
395 | } |
396 | } |
397 | |
398 | my $flag; |
399 | for my $aref (@install_me) { |
400 | my($modobj,$version) = @$aref; |
401 | |
402 | ### another prereq may have already installed this one... |
403 | ### so dont ask again if the module turns out to be uptodate |
404 | ### see bug [#11840] |
405 | ### if either force or prereq_build are given, the prereq |
406 | ### should be built anyway |
407 | next if (!$force and !$prereq_build) && |
408 | $dist->prereq_satisfied(modobj => $modobj, version => $version); |
409 | |
410 | ### either we're told to ignore the prereq, |
411 | ### or the user wants us to ask him |
412 | if( ( $conf->get_conf('prereqs') == PREREQ_ASK and not |
413 | $cb->_callbacks->install_prerequisite->($self, $modobj) |
414 | ) |
415 | ) { |
416 | msg(loc("Will not install prerequisite '%1' -- Note " . |
417 | "that the overall install may fail due to this", |
418 | $modobj->module), $verbose); |
419 | next; |
420 | } |
421 | |
422 | ### value set and false -- means failure ### |
423 | if( defined $modobj->status->installed |
424 | && !$modobj->status->installed |
425 | ) { |
426 | error( loc( "Prerequisite '%1' failed to install before in " . |
427 | "this session", $modobj->module ) ); |
428 | $flag++; |
429 | last; |
430 | } |
431 | |
432 | ### part of core? |
433 | if( $modobj->package_is_perl_core ) { |
434 | error(loc("Prerequisite '%1' is perl-core (%2) -- not ". |
435 | "installing that. Aborting install", |
436 | $modobj->module, $modobj->package ) ); |
437 | $flag++; |
438 | last; |
439 | } |
440 | |
441 | ### circular dependency code ### |
442 | my $pending = $cb->_status->pending_prereqs || {}; |
443 | |
444 | ### recursive dependency ### |
445 | if ( $pending->{ $modobj->module } ) { |
446 | error( loc( "Recursive dependency detected (%1) -- skipping", |
447 | $modobj->module ) ); |
448 | next; |
449 | } |
450 | |
451 | ### register this dependency as pending ### |
452 | $pending->{ $modobj->module } = $modobj; |
453 | $cb->_status->pending_prereqs( $pending ); |
454 | |
455 | |
456 | ### call $modobj->install rather than doing |
457 | ### CPANPLUS::Dist->new and the like ourselves, |
458 | ### since ->install will take care of fetch && |
459 | ### extract as well |
460 | my $pa = $dist->status->_prepare_args || {}; |
461 | my $ca = $dist->status->_create_args || {}; |
462 | my $ia = $dist->status->_install_args || {}; |
463 | |
464 | unless( $modobj->install( %$pa, %$ca, %$ia, |
465 | force => $force, |
466 | verbose => $verbose, |
467 | format => $format, |
468 | target => $target ) |
469 | ) { |
470 | error(loc("Failed to install '%1' as prerequisite " . |
471 | "for '%2'", $modobj->module, $self->module ) ); |
472 | $flag++; |
473 | } |
474 | |
475 | ### unregister the pending dependency ### |
476 | $pending->{ $modobj->module } = 0; |
477 | $cb->_status->pending_prereqs( $pending ); |
478 | |
479 | last if $flag; |
480 | |
481 | ### don't want us to install? ### |
482 | if( $target ne TARGET_INSTALL ) { |
483 | my $dir = $modobj->status->extract |
484 | or error(loc("No extraction dir for '%1' found ". |
485 | "-- weird", $modobj->module)); |
486 | |
487 | $modobj->add_to_includepath(); |
488 | |
489 | next; |
490 | } |
491 | } |
492 | |
493 | ### reset the $prereqs iterator, in case we bailed out early ### |
494 | keys %$prereqs; |
495 | |
496 | return 1 unless $flag; |
497 | return; |
498 | } |
499 | |
500 | 1; |
501 | |
502 | # Local variables: |
503 | # c-indentation-style: bsd |
504 | # c-basic-offset: 4 |
505 | # indent-tabs-mode: nil |
506 | # End: |
507 | # vim: expandtab shiftwidth=4: |