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