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