lib/CPANPLUS/Module.pm

   1 package CPANPLUS::Module;
   2
   3 use strict;
   4 use vars qw[@ISA];
   5
   6
   7 use CPANPLUS::Dist;
   8 use CPANPLUS::Error;
   9 use CPANPLUS::Module::Signature;
  10 use CPANPLUS::Module::Checksums;
  11 use CPANPLUS::Internals::Constants;
  12
  13 use FileHandle;
  14
  15 use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
  16 use IPC::Cmd                    qw[can_run run];
  17 use File::Find                  qw[find];
  18 use Params::Check               qw[check];
  19 use File::Basename              qw[dirname];
  20 use Module::Load::Conditional   qw[can_load check_install];
  21
  22 $Params::Check::VERBOSE = 1;
  23
  24 @ISA = qw[ CPANPLUS::Module::Signature CPANPLUS::Module::Checksums];
  25
  26 =pod
  27
  28 =head1 NAME
  29
  30 CPANPLUS::Module
  31
  32 =head1 SYNOPSIS
  33
  34     ### get a module object from the CPANPLUS::Backend object
  35     my $mod = $cb->module_tree('Some::Module');
  36
  37     ### accessors
  38     $mod->version;
  39     $mod->package;
  40
  41     ### methods
  42     $mod->fetch;
  43     $mod->extract;
  44     $mod->install;
  45
  46
  47 =head1 DESCRIPTION
  48
  49 C<CPANPLUS::Module> creates objects from the information in the
  50 source files. These can then be used to query and perform actions
  51 on, like fetching or installing.
  52
  53 These objects should only be created internally. For C<fake> objects,
  54 there's the C<CPANPLUS::Module::Fake> class. To obtain a module object
  55 consult the C<CPANPLUS::Backend> documentation.
  56
  57 =cut
  58
  59 my $tmpl = {
  60     module      => { default => '', required => 1 },    # full module name
  61     version     => { default => '0.0' },                # version number
  62     path        => { default => '', required => 1 },    # extended path on the
  63                                                         # cpan mirror, like
  64                                                         # /author/id/K/KA/KANE
  65     comment     => { default => ''},                    # comment on module
  66     package     => { default => '', required => 1 },    # package name, like
  67                                                         # 'bar-baz-1.03.tgz'
  68     description => { default => '' },                   # description of the
  69                                                         # module
  70     dslip       => { default => EMPTY_DSLIP },          # dslip information
  71     _id         => { required => 1 },                   # id of the Internals
  72                                                         # parent object
  73     _status     => { no_override => 1 },                # stores status object
  74     author      => { default => '', required => 1,
  75                      allow => IS_AUTHOBJ },             # module author
  76     mtime       => { default => '' },
  77 };
  78
  79 ### some of these will be resolved by wrapper functions that
  80 ### do Clever Things to find the actual value, so don't create
  81 ### an autogenerated sub for that just here, take an alternate
  82 ### name to allow for a wrapper
  83 {   my %rename = (
  84         dslip   => '_dslip'
  85     );
  86
  87     ### autogenerate accessors ###
  88     for my $key ( keys %$tmpl ) {
  89         no strict 'refs';
  90
  91         my $sub = $rename{$key} || $key;
  92
  93         *{__PACKAGE__."::$sub"} = sub {
  94             $_[0]->{$key} = $_[1] if @_ > 1;
  95             return $_[0]->{$key};
  96         }
  97     }
  98 }
  99
 100
 101 =pod
 102
 103 =head1 CLASS METHODS
 104
 105 =head2 accessors ()
 106
 107 Returns a list of all accessor methods to the object
 108
 109 =cut
 110
 111 ### *name is an alias, include it explicitly
 112 sub accessors { return ('name', keys %$tmpl) };
 113
 114 =head1 ACCESSORS
 115
 116 An objects of this class has the following accessors:
 117
 118 =over 4
 119
 120 =item name
 121
 122 Name of the module.
 123
 124 =item module
 125
 126 Name of the module.
 127
 128 =item version
 129
 130 Version of the module. Defaults to '0.0' if none was provided.
 131
 132 =item path
 133
 134 Extended path on the mirror.
 135
 136 =item comment
 137
 138 Any comment about the module -- largely unused.
 139
 140 =item package
 141
 142 The name of the package.
 143
 144 =item description
 145
 146 Description of the module -- only registered modules have this.
 147
 148 =item dslip
 149
 150 The five character dslip string, that represents meta-data of the
 151 module -- again, only registered modules have this.
 152
 153 =cut
 154
 155 sub dslip {
 156     my $self    = shift;
 157
 158     ### if this module has relevant dslip info, return it
 159     return $self->_dslip if $self->_dslip ne EMPTY_DSLIP;
 160
 161     ### if not, look at other modules in the same package,
 162     ### see if *they* have any dslip info
 163     for my $mod ( $self->contains ) {
 164         return $mod->_dslip if $mod->_dslip ne EMPTY_DSLIP;
 165     }
 166
 167     ### ok, really no dslip info found, return the default
 168     return EMPTY_DSLIP;
 169 }
 170
 171
 172 =pod
 173
 174 =item status
 175
 176 The C<CPANPLUS::Module::Status> object associated with this object.
 177 (see below).
 178
 179 =item author
 180
 181 The C<CPANPLUS::Module::Author> object associated with this object.
 182
 183 =item parent
 184
 185 The C<CPANPLUS::Internals> object that spawned this module object.
 186
 187 =back
 188
 189 =cut
 190
 191 ### Alias ->name to ->module, for human beings.
 192 *name = *module;
 193
 194 sub parent {
 195     my $self = shift;
 196     my $obj  = CPANPLUS::Internals->_retrieve_id( $self->_id );
 197
 198     return $obj;
 199 }
 200
 201 =head1 STATUS ACCESSORS
 202
 203 C<CPANPLUS> caches a lot of results from method calls and saves data
 204 it collected along the road for later reuse.
 205
 206 C<CPANPLUS> uses this internally, but it is also available for the end
 207 user. You can get a status object by calling:
 208
 209     $modobj->status
 210
 211 You can then query the object as follows:
 212
 213 =over 4
 214
 215 =item installer_type
 216
 217 The installer type used for this distribution. Will be one of
 218 'makemaker' or 'build'. This determines whether C<CPANPLUS::Dist::MM>
 219 or C<CPANPLUS::Dist::Build> will be used to build this distribution.
 220
 221 =item dist_cpan
 222
 223 The dist object used to do the CPAN-side of the installation. Either
 224 a C<CPANPLUS::Dist::MM> or C<CPANPLUS::Dist::Build> object.
 225
 226 =item dist
 227
 228 The custom dist object used to do the operating specific side of the
 229 installation, if you've chosen to use this. For example, if you've
 230 chosen to install using the C<ports> format, this may be a
 231 C<CPANPLUS::Dist::Ports> object.
 232
 233 Undefined if you didn't specify a separate format to install through.
 234
 235 =item prereqs | requires
 236
 237 A hashref of prereqs this distribution was found to have. Will look
 238 something like this:
 239
 240     { Carp  => 0.01, strict => 0 }
 241
 242 Might be undefined if the distribution didn't have any prerequisites.
 243
 244 =item configure_requires
 245
 246 Like prereqs, but these are necessary to be installed before the
 247 build process can even begin.
 248
 249 =item signature
 250
 251 Flag indicating, if a signature check was done, whether it was OK or
 252 not.
 253
 254 =item extract
 255
 256 The directory this distribution was extracted to.
 257
 258 =item fetch
 259
 260 The location this distribution was fetched to.
 261
 262 =item readme
 263
 264 The text of this distributions README file.
 265
 266 =item uninstall
 267
 268 Flag indicating if an uninstall call was done successfully.
 269
 270 =item created
 271
 272 Flag indicating if the C<create> call to your dist object was done
 273 successfully.
 274
 275 =item installed
 276
 277 Flag indicating if the C<install> call to your dist object was done
 278 successfully.
 279
 280 =item checksums
 281
 282 The location of this distributions CHECKSUMS file.
 283
 284 =item checksum_ok
 285
 286 Flag indicating if the checksums check was done successfully.
 287
 288 =item checksum_value
 289
 290 The checksum value this distribution is expected to have
 291
 292 =back
 293
 294 =head1 METHODS
 295
 296 =head2 $self = CPANPLUS::Module->new( OPTIONS )
 297
 298 This method returns a C<CPANPLUS::Module> object. Normal users
 299 should never call this method directly, but instead use the
 300 C<CPANPLUS::Backend> to obtain module objects.
 301
 302 This example illustrates a C<new()> call with all required arguments:
 303
 304         CPANPLUS::Module->new(
 305             module  => 'Foo',
 306             path    => 'authors/id/A/AA/AAA',
 307             package => 'Foo-1.0.tgz',
 308             author  => $author_object,
 309             _id     => INTERNALS_OBJECT_ID,
 310         );
 311
 312 Every accessor is also a valid option to pass to C<new>.
 313
 314 Returns a module object on success and false on failure.
 315
 316 =cut
 317
 318
 319 sub new {
 320     my($class, %hash) = @_;
 321
 322     ### don't check the template for sanity
 323     ### -- we know it's good and saves a lot of performance
 324     local $Params::Check::SANITY_CHECK_TEMPLATE = 0;
 325
 326     my $object  = check( $tmpl, \%hash ) or return;
 327
 328     bless $object, $class;
 329
 330     return $object;
 331 }
 332
 333 ### only create status objects when they're actually asked for
 334 sub status {
 335     my $self = shift;
 336     return $self->_status if $self->_status;
 337
 338     my $acc = Object::Accessor->new;
 339     $acc->mk_accessors( qw[ installer_type dist_cpan dist prereqs
 340                             signature extract fetch readme uninstall
 341                             created installed prepared checksums files
 342                             checksum_ok checksum_value _fetch_from
 343                             configure_requires
 344                         ] );
 345
 346     ### create an alias from 'requires' to 'prereqs', so it's more in
 347     ### line with 'configure_requires';
 348     $acc->mk_aliases( requires => 'prereqs' );
 349
 350     $self->_status( $acc );
 351
 352     return $self->_status;
 353 }
 354
 355
 356 ### flush the cache of this object ###
 357 sub _flush {
 358     my $self = shift;
 359     $self->status->mk_flush;
 360     return 1;
 361 }
 362
 363 =head2 $mod->package_name( [$package_string] )
 364
 365 Returns the name of the package a module is in. For C<Acme::Bleach>
 366 that might be C<Acme-Bleach>.
 367
 368 =head2 $mod->package_version( [$package_string] )
 369
 370 Returns the version of the package a module is in. For a module
 371 in the package C<Acme-Bleach-1.1.tar.gz> this would be C<1.1>.
 372
 373 =head2 $mod->package_extension( [$package_string] )
 374
 375 Returns the suffix added by the compression method of a package a
 376 certain module is in. For a module in C<Acme-Bleach-1.1.tar.gz>, this
 377 would be C<tar.gz>.
 378
 379 =head2 $mod->package_is_perl_core
 380
 381 Returns a boolean indicating of the package a particular module is in,
 382 is actually a core perl distribution.
 383
 384 =head2 $mod->module_is_supplied_with_perl_core( [version => $]] )
 385
 386 Returns a boolean indicating whether C<ANY VERSION> of this module
 387 was supplied with the current running perl's core package.
 388
 389 =head2 $mod->is_bundle
 390
 391 Returns a boolean indicating if the module you are looking at, is
 392 actually a bundle. Bundles are identified as modules whose name starts
 393 with C<Bundle::>.
 394
 395 =head2 $mod->is_autobundle;
 396
 397 Returns a boolean indicating if the module you are looking at, is
 398 actually an autobundle as generated by C<< $cb->autobundle >>.
 399
 400 =head2 $mod->is_third_party
 401
 402 Returns a boolean indicating whether the package is a known third-party
 403 module (i.e. it's not provided by the standard Perl distribution and
 404 is not available on the CPAN, but on a third party software provider).
 405 See L<Module::ThirdParty> for more details.
 406
 407 =head2 $mod->third_party_information
 408
 409 Returns a reference to a hash with more information about a third-party
 410 module. See the documentation about C<module_information()> in
 411 L<Module::ThirdParty> for more details.
 412
 413 =cut
 414
 415 {   ### fetches the test reports for a certain module ###
 416     my %map = (
 417         name        => 0,
 418         version     => 1,
 419         extension   => 2,
 420     );
 421
 422     while ( my($type, $index) = each %map ) {
 423         my $name    = 'package_' . $type;
 424
 425         no strict 'refs';
 426         *$name = sub {
 427             my $self = shift;
 428             my $val  = shift || $self->package;
 429             my @res  = $self->parent->_split_package_string( package => $val );
 430
 431             ### return the corresponding index from the result
 432             return $res[$index] if @res;
 433             return;
 434         };
 435     }
 436
 437     sub package_is_perl_core {
 438         my $self = shift;
 439
 440         ### check if the package looks like a perl core package
 441         return 1 if $self->package_name eq PERL_CORE;
 442
 443         my $core = $self->module_is_supplied_with_perl_core;
 444         ### ok, so it's found in the core, BUT it could be dual-lifed
 445         if ($core) {
 446             ### if the package is newer than installed, then it's dual-lifed
 447             return if $self->version > $self->installed_version;
 448
 449             ### if the package is newer or equal to the corelist,
 450             ### then it's dual-lifed
 451             return if $self->version >= $core;
 452
 453             ### otherwise, it's older than corelist, thus unsuitable.
 454             return 1;
 455         }
 456
 457         ### not in corelist, not a perl core package.
 458         return;
 459     }
 460
 461     sub module_is_supplied_with_perl_core {
 462         my $self = shift;
 463         my $ver  = shift || $];
 464
 465         ### allow it to be called as a package function as well like:
 466         ###   CPANPLUS::Module::module_is_supplied_with_perl_core('Config')
 467         ### so that we can check the status of modules that aren't released
 468         ### to CPAN, but are part of the core.
 469         my $name = ref $self ? $self->module : $self;
 470
 471         ### check Module::CoreList to see if it's a core package
 472         require Module::CoreList;
 473
 474         ### Address #41157: Module::module_is_supplied_with_perl_core()
 475         ### broken for perl 5.10: Module::CoreList's version key for the
 476         ### hash has a different number of trailing zero than $] aka
 477         ### $PERL_VERSION.
 478         my $core = $Module::CoreList::version{ 0+$ver }->{ $name };
 479
 480         return $core;
 481     }
 482
 483     ### make sure Bundle-Foo also gets flagged as bundle
 484     sub is_bundle {
 485         my $self = shift;
 486
 487         ### cpan'd bundle
 488         return 1 if $self->module =~ /^bundle(?:-|::)/i;
 489
 490         ### autobundle
 491         return 1 if $self->is_autobundle;
 492
 493         ### neither
 494         return;
 495     }
 496
 497     ### full path to a generated autobundle
 498     sub is_autobundle {
 499         my $self    = shift;
 500         my $conf    = $self->parent->configure_object;
 501         my $prefix  = $conf->_get_build('autobundle_prefix');
 502
 503         return 1 if $self->module eq $prefix;
 504         return;
 505     }
 506
 507     sub is_third_party {
 508         my $self = shift;
 509
 510         return unless can_load( modules => { 'Module::ThirdParty' => 0 } );
 511
 512         return Module::ThirdParty::is_3rd_party( $self->name );
 513     }
 514
 515     sub third_party_information {
 516         my $self = shift;
 517
 518         return unless $self->is_third_party;
 519
 520         return Module::ThirdParty::module_information( $self->name );
 521     }
 522 }
 523
 524 =pod
 525
 526 =head2 $clone = $self->clone
 527
 528 Clones the current module object for tinkering with.
 529 It will have a clean C<CPANPLUS::Module::Status> object, as well as
 530 a fake C<CPANPLUS::Module::Author> object.
 531
 532 =cut
 533
 534 {   ### accessors dont change during run time, so only compute once
 535     my @acc = grep !/status/, __PACKAGE__->accessors();
 536
 537     sub clone {
 538         my $self = shift;
 539
 540         ### clone the object ###
 541         my %data = map { $_ => $self->$_ } @acc;
 542
 543         my $obj = CPANPLUS::Module::Fake->new( %data );
 544
 545         return $obj;
 546     }
 547 }
 548
 549 =pod
 550
 551 =head2 $where = $self->fetch
 552
 553 Fetches the module from a CPAN mirror.
 554 Look at L<CPANPLUS::Internals::Fetch::_fetch()> for details on the
 555 options you can pass.
 556
 557 =cut
 558
 559 sub fetch {
 560     my $self = shift;
 561     my $cb   = $self->parent;
 562
 563     ### custom args
 564     my %args            = ( module => $self );
 565
 566     ### if a custom fetch location got specified before, add that here
 567     $args{fetch_from}   = $self->status->_fetch_from
 568                             if $self->status->_fetch_from;
 569
 570     my $where = $cb->_fetch( @_, %args ) or return;
 571
 572     ### do an md5 check ###
 573     if( !$self->status->_fetch_from and
 574         $cb->configure_object->get_conf('md5') and
 575         $self->package ne CHECKSUMS
 576     ) {
 577         unless( $self->_validate_checksum ) {
 578             error( loc( "Checksum error for '%1' -- will not trust package",
 579                         $self->package) );
 580             return;
 581         }
 582     }
 583
 584     return $where;
 585 }
 586
 587 =pod
 588
 589 =head2 $path = $self->extract
 590
 591 Extracts the fetched module.
 592 Look at L<CPANPLUS::Internals::Extract::_extract()> for details on
 593 the options you can pass.
 594
 595 =cut
 596
 597 sub extract {
 598     my $self = shift;
 599     my $cb   = $self->parent;
 600
 601     unless( $self->status->fetch ) {
 602         error( loc( "You have not fetched '%1' yet -- cannot extract",
 603                     $self->module) );
 604         return;
 605     }
 606
 607     ### can't extract these, so just use the basedir for the file
 608     if( $self->is_autobundle ) {
 609
 610         ### this is expected to be set after an extract call
 611         $self->get_installer_type;
 612
 613         return $self->status->extract( dirname( $self->status->fetch ) );
 614     }
 615
 616     return $cb->_extract( @_, module => $self );
 617 }
 618
 619 =head2 $type = $self->get_installer_type([prefer_makefile => BOOL])
 620
 621 Gets the installer type for this module. This may either be C<build> or
 622 C<makemaker>. If C<Module::Build> is unavailable or no installer type
 623 is available, it will fall back to C<makemaker>. If both are available,
 624 it will pick the one indicated by your config, or by the
 625 C<prefer_makefile> option you can pass to this function.
 626
 627 Returns the installer type on success, and false on error.
 628
 629 =cut
 630
 631 sub get_installer_type {
 632     my $self = shift;
 633     my $cb   = $self->parent;
 634     my $conf = $cb->configure_object;
 635     my %hash = @_;
 636
 637     my ($prefer_makefile,$verbose);
 638     my $tmpl = {
 639         prefer_makefile => { default => $conf->get_conf('prefer_makefile'),
 640                              store   => \$prefer_makefile, allow => BOOLEANS },
 641         verbose         => { default => $conf->get_conf('verbose'),
 642                              store   => \$verbose },
 643     };
 644
 645     check( $tmpl, \%hash ) or return;
 646
 647     my $type;
 648
 649     ### autobundles use their own installer, so return that
 650     if( $self->is_autobundle ) {
 651         $type = INSTALLER_AUTOBUNDLE;
 652
 653     } else {
 654         my $extract = $self->status->extract();
 655         unless( $extract ) {
 656             error(loc(
 657                 "Cannot determine installer type of unextracted module '%1'",
 658                 $self->module
 659             ));
 660             return;
 661         }
 662
 663         ### check if it's a makemaker or a module::build type dist ###
 664         my $found_build     = -e BUILD_PL->( $extract );
 665         my $found_makefile  = -e MAKEFILE_PL->( $extract );
 666
 667         $type = INSTALLER_BUILD if !$prefer_makefile &&  $found_build;
 668         $type = INSTALLER_BUILD if  $found_build     && !$found_makefile;
 669         $type = INSTALLER_MM    if  $prefer_makefile &&  $found_makefile;
 670         $type = INSTALLER_MM    if  $found_makefile  && !$found_build;
 671     }
 672
 673     ### ok, so it's a 'build' installer, but you don't /have/ module build
 674     if( $type eq INSTALLER_BUILD and
 675         not CPANPLUS::Dist->has_dist_type( INSTALLER_BUILD )
 676     ) {
 677
 678         ### XXX this is for recording purposes only. We *have* to install
 679         ### these before even creating a dist object, or we'll get an error
 680         ### saying 'no such dist type';
 681         my $href = $self->status->configure_requires || {};
 682         my $deps = { INSTALLER_BUILD, 0, %$href };
 683
 684         $self->status->configure_requires( $deps );
 685
 686         msg(loc("This module requires '%1' and '%2' to be installed first. ".
 687                 "Adding these modules to your prerequisites list",
 688                  'Module::Build', INSTALLER_BUILD
 689         ), $verbose );
 690
 691
 692     ### ok, actually we found neither ###
 693     } elsif ( !$type ) {
 694         error( loc( "Unable to find '%1' or '%2' for '%3'; ".
 695                     "Will default to '%4' but might be unable ".
 696                     "to install!", BUILD_PL->(), MAKEFILE_PL->(),
 697                     $self->module, INSTALLER_MM ) );
 698         $type = INSTALLER_MM;
 699     }
 700
 701     return $self->status->installer_type( $type ) if $type;
 702     return;
 703 }
 704
 705 =pod
 706
 707 =head2 $dist = $self->dist([target => 'prepare|create', format => DISTRIBUTION_TYPE, args => {key => val}]);
 708
 709 Create a distribution object, ready to be installed.
 710 Distribution type defaults to your config settings
 711
 712 The optional C<args> hashref is passed on to the specific distribution
 713 types' C<create> method after being dereferenced.
 714
 715 Returns a distribution object on success, false on failure.
 716
 717 See C<CPANPLUS::Dist> for details.
 718
 719 =cut
 720
 721 sub dist {
 722     my $self = shift;
 723     my $cb   = $self->parent;
 724     my $conf = $cb->configure_object;
 725     my %hash = @_;
 726
 727     ### have you determined your installer type yet? if not, do it here,
 728     ### we need the info
 729     $self->get_installer_type unless $self->status->installer_type;
 730
 731     my($type,$args,$target);
 732     my $tmpl = {
 733         format  => { default => $conf->get_conf('dist_type') ||
 734                                 $self->status->installer_type,
 735                      store   => \$type },
 736         target  => { default => TARGET_CREATE, store => \$target },
 737         args    => { default => {}, store => \$args },
 738     };
 739
 740     check( $tmpl, \%hash ) or return;
 741
 742     ### ok, check for $type. Do we have it?
 743     unless( CPANPLUS::Dist->has_dist_type( $type ) ) {
 744
 745         ### ok, we don't have it. Is it C::D::Build? if so we can install the
 746         ### whole thing now
 747         ### XXX we _could_ do this for any type we dont have actually...
 748         if( $type eq INSTALLER_BUILD ) {
 749             msg(loc("Bootstrapping installer '%1'", $type));
 750
 751             ### don't propagate the format, it's the one we're trying to
 752             ### bootstrap, so it'll be an infinite loop if we do
 753
 754             $cb->module_tree( $type )->install( target => $target, %$args ) or
 755                 do {
 756                     error(loc("Could not bootstrap installer '%1' -- ".
 757                               "can not continue", $type));
 758                     return;
 759                 };
 760
 761             ### re-scan for available modules now
 762             CPANPLUS::Dist->rescan_dist_types;
 763
 764             unless( CPANPLUS::Dist->has_dist_type( $type ) ) {
 765                 error(loc("Newly installed installer type '%1' should be ".
 766                           "available, but is not! -- aborting", $type));
 767                 return;
 768             } else {
 769                 msg(loc("Installer '%1' succesfully bootstrapped", $type));
 770             }
 771
 772         ### some other plugin you dont have. Abort
 773         } else {
 774             error(loc("Installer type '%1' not found. Please verify your ".
 775                       "installation -- aborting", $type ));
 776             return;
 777         }
 778     }
 779
 780     my $dist = $type->new( module => $self ) or return;
 781
 782     my $dist_cpan = $type eq $self->status->installer_type
 783                         ? $dist
 784                         : $self->status->installer_type->new( module => $self );
 785
 786     ### store the dists
 787     $self->status->dist_cpan(   $dist_cpan );
 788     $self->status->dist(        $dist );
 789
 790     DIST: {
 791         ### first prepare the dist
 792         $dist->prepare( %$args ) or return;
 793         $self->status->prepared(1);
 794
 795         ### you just wanted us to prepare?
 796         last DIST if $target eq TARGET_PREPARE;
 797
 798         $dist->create( %$args ) or return;
 799         $self->status->created(1);
 800     }
 801
 802     return $dist;
 803 }
 804
 805 =pod
 806
 807 =head2 $bool = $mod->prepare( )
 808
 809 Convenience method around C<install()> that prepares a module
 810 without actually building it. This is equivalent to invoking C<install>
 811 with C<target> set to C<prepare>
 812
 813 Returns true on success, false on failure.
 814
 815 =cut
 816
 817 sub prepare {
 818     my $self = shift;
 819     return $self->install( @_, target => TARGET_PREPARE );
 820 }
 821
 822 =head2 $bool = $mod->create( )
 823
 824 Convenience method around C<install()> that creates a module.
 825 This is equivalent to invoking C<install> with C<target> set to
 826 C<create>
 827
 828 Returns true on success, false on failure.
 829
 830 =cut
 831
 832 sub create {
 833     my $self = shift;
 834     return $self->install( @_, target => TARGET_CREATE );
 835 }
 836
 837 =head2 $bool = $mod->test( )
 838
 839 Convenience wrapper around C<install()> that tests a module, without
 840 installing it.
 841 It's the equivalent to invoking C<install()> with C<target> set to
 842 C<create> and C<skiptest> set to C<0>.
 843
 844 Returns true on success, false on failure.
 845
 846 =cut
 847
 848 sub test {
 849     my $self = shift;
 850     return $self->install( @_, target => TARGET_CREATE, skiptest => 0 );
 851 }
 852
 853 =pod
 854
 855 =head2 $bool = $self->install([ target => 'prepare|create|install', format => FORMAT_TYPE, extractdir => DIRECTORY, fetchdir => DIRECTORY, prefer_bin => BOOL, force => BOOL, verbose => BOOL, ..... ]);
 856
 857 Installs the current module. This includes fetching it and extracting
 858 it, if this hasn't been done yet, as well as creating a distribution
 859 object for it.
 860
 861 This means you can pass it more arguments than described above, which
 862 will be passed on to the relevant methods as they are called.
 863
 864 See C<CPANPLUS::Internals::Fetch>, C<CPANPLUS::Internals::Extract> and
 865 C<CPANPLUS::Dist> for details.
 866
 867 Returns true on success, false on failure.
 868
 869 =cut
 870
 871 sub install {
 872     my $self = shift;
 873     my $cb   = $self->parent;
 874     my $conf = $cb->configure_object;
 875     my %hash = @_;
 876
 877     my $args; my $target; my $format;
 878     {   ### so we can use the rest of the args to the create calls etc ###
 879         local $Params::Check::NO_DUPLICATES = 1;
 880         local $Params::Check::ALLOW_UNKNOWN = 1;
 881
 882         ### targets 'dist' and 'test' are now completely ignored ###
 883         my $tmpl = {
 884                         ### match this allow list with Dist->_resolve_prereqs
 885             target     => { default => TARGET_INSTALL, store => \$target,
 886                             allow   => [TARGET_PREPARE, TARGET_CREATE,
 887                                         TARGET_INSTALL] },
 888             force      => { default => $conf->get_conf('force'), },
 889             verbose    => { default => $conf->get_conf('verbose'), },
 890             format     => { default => $conf->get_conf('dist_type'),
 891                                 store => \$format },
 892         };
 893
 894         $args = check( $tmpl, \%hash ) or return;
 895     }
 896
 897
 898     ### if this target isn't 'install', we will need to at least 'create'
 899     ### every prereq, so it can build
 900     ### XXX prereq_target of 'prepare' will do weird things here, and is
 901     ### not supported.
 902     $args->{'prereq_target'} ||= TARGET_CREATE if $target ne TARGET_INSTALL;
 903
 904     ### check if it's already upto date ###
 905     if( $target eq TARGET_INSTALL and !$args->{'force'} and
 906         !$self->package_is_perl_core() and         # separate rules apply
 907         ( $self->status->installed() or $self->is_uptodate ) and
 908         !INSTALL_VIA_PACKAGE_MANAGER->($format)
 909     ) {
 910         msg(loc("Module '%1' already up to date, won't install without force",
 911                 $self->module), $args->{'verbose'} );
 912         return $self->status->installed(1);
 913     }
 914
 915     # if it's a non-installable core package, abort the install.
 916     if( $self->package_is_perl_core() ) {
 917         # if the installed is newer, say so.
 918         if( $self->installed_version > $self->version ) {
 919             error(loc("The core Perl %1 module '%2' (%3) is more ".
 920                       "recent than the latest release on CPAN (%4). ".
 921                       "Aborting install.",
 922                       $], $self->module, $self->installed_version,
 923                       $self->version ) );
 924         # if the installed matches, say so.
 925         } elsif( $self->installed_version == $self->version ) {
 926             error(loc("The core Perl %1 module '%2' (%3) can only ".
 927                       "be installed by Perl itself. ".
 928                       "Aborting install.",
 929                       $], $self->module, $self->installed_version ) );
 930         # otherwise, the installed is older; say so.
 931         } else {
 932             error(loc("The core Perl %1 module '%2' can only be ".
 933                       "upgraded from %3 to %4 by Perl itself (%5). ".
 934                       "Aborting install.",
 935                       $], $self->module, $self->installed_version,
 936                       $self->version, $self->package ) );
 937         }
 938         return;
 939
 940     ### it might be a known 3rd party module
 941     } elsif ( $self->is_third_party ) {
 942         my $info = $self->third_party_information;
 943         error(loc(
 944             "%1 is a known third-party module.\n\n".
 945             "As it isn't available on the CPAN, CPANPLUS can't install " .
 946             "it automatically. Therefore you need to install it manually " .
 947             "before proceeding.\n\n".
 948             "%2 is part of %3, published by %4, and should be available ".
 949             "for download at the following address:\n\t%5",
 950             $self->name, $self->name, $info->{name}, $info->{author},
 951             $info->{url}
 952         ));
 953
 954         return;
 955     }
 956
 957     ### fetch it if need be ###
 958     unless( $self->status->fetch ) {
 959         my $params;
 960         for (qw[prefer_bin fetchdir]) {
 961             $params->{$_} = $args->{$_} if exists $args->{$_};
 962         }
 963         for (qw[force verbose]) {
 964             $params->{$_} = $args->{$_} if defined $args->{$_};
 965         }
 966         $self->fetch( %$params ) or return;
 967     }
 968
 969     ### extract it if need be ###
 970     unless( $self->status->extract ) {
 971         my $params;
 972         for (qw[prefer_bin extractdir]) {
 973             $params->{$_} = $args->{$_} if exists $args->{$_};
 974         }
 975         for (qw[force verbose]) {
 976             $params->{$_} = $args->{$_} if defined $args->{$_};
 977         }
 978         $self->extract( %$params ) or return;
 979     }
 980
 981     $format ||= $self->status->installer_type;
 982
 983     unless( $format ) {
 984         error( loc( "Don't know what installer to use; " .
 985                     "Couldn't find either '%1' or '%2' in the extraction " .
 986                     "directory '%3' -- will be unable to install",
 987                     BUILD_PL->(), MAKEFILE_PL->(), $self->status->extract ) );
 988
 989         $self->status->installed(0);
 990         return;
 991     }
 992
 993
 994     ### do SIGNATURE checks? ###
 995     if( $conf->get_conf('signature') ) {
 996         unless( $self->check_signature( verbose => $args->{verbose} ) ) {
 997             error( loc( "Signature check failed for module '%1' ".
 998                         "-- Not trusting this module, aborting install",
 999                         $self->module ) );
1000             $self->status->signature(0);
1001
1002             ### send out test report on broken sig
1003             if( $conf->get_conf('cpantest') ) {
1004                 $cb->_send_report(
1005                     module  => $self,
1006                     failed  => 1,
1007                     buffer  => CPANPLUS::Error->stack_as_string,
1008                     verbose => $args->{verbose},
1009                     force   => $args->{force},
1010                 ) or error(loc("Failed to send test report for '%1'",
1011                      $self->module ) );
1012             }
1013
1014             return;
1015
1016         } else {
1017             ### signature OK ###
1018             $self->status->signature(1);
1019         }
1020     }
1021
1022     ### a target of 'create' basically means not to run make test ###
1023     ### eh, no it /doesn't/.. skiptest => 1 means skiptest => 1.
1024     #$args->{'skiptest'} = 1 if $target eq 'create';
1025
1026     ### bundle rules apply ###
1027     if( $self->is_bundle ) {
1028         ### check what we need to install ###
1029         my @prereqs = $self->bundle_modules();
1030         unless( @prereqs ) {
1031             error( loc( "Bundle '%1' does not specify any modules to install",
1032                         $self->module ) );
1033
1034             ### XXX mark an error here? ###
1035         }
1036     }
1037
1038     my $dist = $self->dist( format  => $format,
1039                             target  => $target,
1040                             args    => $args );
1041     unless( $dist ) {
1042         error( loc( "Unable to create a new distribution object for '%1' " .
1043                     "-- cannot continue", $self->module ) );
1044         return;
1045     }
1046
1047     return 1 if $target ne TARGET_INSTALL;
1048
1049     my $ok = $dist->install( %$args ) ? 1 : 0;
1050
1051     $self->status->installed($ok);
1052
1053     return 1 if $ok;
1054     return;
1055 }
1056
1057 =pod @list = $self->bundle_modules()
1058
1059 Returns a list of module objects the Bundle specifies.
1060
1061 This requires you to have extracted the bundle already, using the
1062 C<extract()> method.
1063
1064 Returns false on error.
1065
1066 =cut
1067
1068 sub bundle_modules {
1069     my $self = shift;
1070     my $cb   = $self->parent;
1071
1072     unless( $self->is_bundle ) {
1073         error( loc("'%1' is not a bundle", $self->module ) );
1074         return;
1075     }
1076
1077     my @files;
1078
1079     ### autobundles are special files generated by CPANPLUS. If we can
1080     ### read the file, we can determine the prereqs
1081     if( $self->is_autobundle ) {
1082         my $where;
1083         unless( $where = $self->status->fetch ) {
1084             error(loc("Don't know where '%1' was fetched to", $self->package));
1085             return;
1086         }
1087
1088         push @files, $where
1089
1090     ### regular bundle::* upload
1091     } else {
1092         my $dir;
1093         unless( $dir = $self->status->extract ) {
1094             error(loc("Don't know where '%1' was extracted to", $self->module));
1095             return;
1096         }
1097
1098         find( {
1099             wanted   => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i },
1100             no_chdir => 1,
1101         }, $dir );
1102     }
1103
1104     my $prereqs = {}; my @list; my $seen = {};
1105     for my $file ( @files ) {
1106         my $fh = FileHandle->new($file)
1107                     or( error(loc("Could not open '%1' for reading: %2",
1108                         $file,$!)), next );
1109
1110         my $flag;
1111         while( local $_ = <$fh> ) {
1112             ### quick hack to read past the header of the file ###
1113             last if $flag && m|^=head|i;
1114
1115             ### from perldoc cpan:
1116             ### =head1 CONTENTS
1117             ### In this pod section each line obeys the format
1118             ### Module_Name [Version_String] [- optional text]
1119             $flag = 1 if m|^=head1 CONTENTS|i;
1120
1121             if ($flag && /^(?!=)(\S+)\s*(\S+)?/) {
1122                 my $module  = $1;
1123                 my $version = $cb->_version_to_number( version => $2 );
1124
1125                 my $obj = $cb->module_tree($module);
1126
1127                 unless( $obj ) {
1128                     error(loc("Cannot find bundled module '%1'", $module),
1129                           loc("-- it does not seem to exist") );
1130                     next;
1131                 }
1132
1133                 ### make sure we list no duplicates ###
1134                 unless( $seen->{ $obj->module }++ ) {
1135                     push @list, $obj;
1136                     $prereqs->{ $module } =
1137                         $cb->_version_to_number( version => $version );
1138                 }
1139             }
1140         }
1141     }
1142
1143     ### store the prereqs we just found ###
1144     $self->status->prereqs( $prereqs );
1145
1146     return @list;
1147 }
1148
1149 =pod
1150
1151 =head2 $text = $self->readme
1152
1153 Fetches the readme belonging to this module and stores it under
1154 C<< $obj->status->readme >>. Returns the readme as a string on
1155 success and returns false on failure.
1156
1157 =cut
1158
1159 sub readme {
1160     my $self = shift;
1161     my $conf = $self->parent->configure_object;
1162
1163     ### did we already dl the readme once? ###
1164     return $self->status->readme() if $self->status->readme();
1165
1166     ### this should be core ###
1167     return unless can_load( modules     => { FileHandle => '0.0' },
1168                             verbose     => 1,
1169                         );
1170
1171     ### get a clone of the current object, with a fresh status ###
1172     my $obj  = $self->clone or return;
1173
1174     ### munge the package name
1175     my $pkg = README->( $obj );
1176     $obj->package($pkg);
1177
1178     my $file;
1179     {   ### disable checksum fetches on readme downloads
1180
1181         my $tmp = $conf->get_conf( 'md5' );
1182         $conf->set_conf( md5 => 0 );
1183
1184         $file = $obj->fetch;
1185
1186         $conf->set_conf( md5 => $tmp );
1187
1188         return unless $file;
1189     }
1190
1191     ### read the file into a scalar, to store in the original object ###
1192     my $fh = new FileHandle;
1193     unless( $fh->open($file) ) {
1194         error( loc( "Could not open file '%1': %2", $file, $! ) );
1195         return;
1196     }
1197
1198     my $in = do{ local $/; <$fh> };
1199     $fh->close;
1200
1201     return $self->status->readme( $in );
1202 }
1203
1204 =pod
1205
1206 =head2 $version = $self->installed_version()
1207
1208 Returns the currently installed version of this module, if any.
1209
1210 =head2 $where = $self->installed_file()
1211
1212 Returns the location of the currently installed file of this module,
1213 if any.
1214
1215 =head2 $dir = $self->installed_dir()
1216
1217 Returns the directory (or more accurately, the C<@INC> handle) from
1218 which this module was loaded, if any.
1219
1220 =head2 $bool = $self->is_uptodate([version => VERSION_NUMBER])
1221
1222 Returns a boolean indicating if this module is uptodate or not.
1223
1224 =cut
1225
1226 ### uptodate/installed functions
1227 {   my $map = {             # hashkey,      alternate rv
1228         installed_version   => ['version',  0 ],
1229         installed_file      => ['file',     ''],
1230         installed_dir       => ['dir',      ''],
1231         is_uptodate         => ['uptodate', 0 ],
1232     };
1233
1234     while( my($method, $aref) = each %$map ) {
1235         my($key,$alt_rv) = @$aref;
1236
1237         no strict 'refs';
1238         *$method = sub {
1239             ### never use the @INC hooks to find installed versions of
1240             ### modules -- they're just there in case they're not on the
1241             ### perl install, but the user shouldn't trust them for *other*
1242             ### modules!
1243             ### XXX CPANPLUS::inc is now obsolete, so this should not
1244             ### be needed anymore
1245             #local @INC = CPANPLUS::inc->original_inc;
1246
1247             my $self = shift;
1248
1249             ### make sure check_install is not looking in %INC, as
1250             ### that may contain some of our sneakily loaded modules
1251             ### that aren't installed as such. -- kane
1252             local $Module::Load::Conditional::CHECK_INC_HASH = 0;
1253             my $href = check_install(
1254                             module  => $self->module,
1255                             version => $self->version,
1256                             @_,
1257                         );
1258
1259             return $href->{$key} || $alt_rv;
1260         }
1261     }
1262 }
1263
1264
1265
1266 =pod
1267
1268 =head2 $href = $self->details()
1269
1270 Returns a hashref with key/value pairs offering more information about
1271 a particular module. For example, for C<Time::HiRes> it might look like
1272 this:
1273
1274     Author                  Jarkko Hietaniemi (jhi@iki.fi)
1275     Description             High resolution time, sleep, and alarm
1276     Development Stage       Released
1277     Installed File          /usr/local/perl/lib/Time/Hires.pm
1278     Interface Style         plain Functions, no references used
1279     Language Used           C and perl, a C compiler will be needed
1280     Package                 Time-HiRes-1.65.tar.gz
1281     Public License          Unknown
1282     Support Level           Developer
1283     Version Installed       1.52
1284     Version on CPAN         1.65
1285
1286 =cut
1287
1288 sub details {
1289     my $self = shift;
1290     my $conf = $self->parent->configure_object();
1291     my $cb   = $self->parent;
1292     my %hash = @_;
1293
1294     my $res = {
1295         Author              => loc("%1 (%2)",   $self->author->author(),
1296                                                 $self->author->email() ),
1297         Package             => $self->package,
1298         Description         => $self->description     || loc('None given'),
1299         'Version on CPAN'   => $self->version,
1300     };
1301
1302     ### check if we have the module installed
1303     ### if so, add version have and version on cpan
1304     $res->{'Version Installed'} = $self->installed_version
1305                                     if $self->installed_version;
1306     $res->{'Installed File'} = $self->installed_file if $self->installed_file;
1307
1308     my $i = 0;
1309     for my $item( split '', $self->dslip ) {
1310         $res->{ $cb->_dslip_defs->[$i]->[0] } =
1311                 $cb->_dslip_defs->[$i]->[1]->{$item} || loc('Unknown');
1312         $i++;
1313     }
1314
1315     return $res;
1316 }
1317
1318 =head2 @list = $self->contains()
1319
1320 Returns a list of module objects that represent the modules also
1321 present in the package of this module.
1322
1323 For example, for C<Archive::Tar> this might return:
1324
1325     Archive::Tar
1326     Archive::Tar::Constant
1327     Archive::Tar::File
1328
1329 =cut
1330
1331 sub contains {
1332     my $self = shift;
1333     my $cb   = $self->parent;
1334     my $pkg  = $self->package;
1335
1336     my @mods = $cb->search( type => 'package', allow => [qr/^$pkg$/] );
1337
1338     return @mods;
1339 }
1340
1341 =pod
1342
1343 =head2 @list_of_hrefs = $self->fetch_report()
1344
1345 This function queries the CPAN testers database at
1346 I<http://testers.cpan.org/> for test results of specified module
1347 objects, module names or distributions.
1348
1349 Look at L<CPANPLUS::Internals::Report::_query_report()> for details on
1350 the options you can pass and the return value to expect.
1351
1352 =cut
1353
1354 sub fetch_report {
1355     my $self    = shift;
1356     my $cb      = $self->parent;
1357
1358     return $cb->_query_report( @_, module => $self );
1359 }
1360
1361 =pod
1362
1363 =head2 $bool = $self->uninstall([type => [all|man|prog])
1364
1365 This function uninstalls the specified module object.
1366
1367 You can install 2 types of files, either C<man> pages or C<prog>ram
1368 files. Alternately you can specify C<all> to uninstall both (which
1369 is the default).
1370
1371 Returns true on success and false on failure.
1372
1373 Do note that this does an uninstall via the so-called C<.packlist>,
1374 so if you used a module installer like say, C<ports> or C<apt>, you
1375 should not use this, but use your package manager instead.
1376
1377 =cut
1378
1379 sub uninstall {
1380     my $self = shift;
1381     my $conf = $self->parent->configure_object();
1382     my %hash = @_;
1383
1384     my ($type,$verbose);
1385     my $tmpl = {
1386         type    => { default => 'all', allow => [qw|man prog all|],
1387                         store => \$type },
1388         verbose => { default => $conf->get_conf('verbose'),
1389                         store => \$verbose },
1390         force   => { default => $conf->get_conf('force') },
1391     };
1392
1393     ### XXX add a warning here if your default install dist isn't
1394     ### makefile or build -- that means you are using a package manager
1395     ### and this will not do what you think!
1396
1397     my $args = check( $tmpl, \%hash ) or return;
1398
1399     if( $conf->get_conf('dist_type') and (
1400         ($conf->get_conf('dist_type') ne INSTALLER_BUILD) or
1401         ($conf->get_conf('dist_type') ne INSTALLER_MM))
1402     ) {
1403         msg(loc("You have a default installer type set (%1) ".
1404                 "-- you should probably use that package manager to " .
1405                 "uninstall modules", $conf->get_conf('dist_type')), $verbose);
1406     }
1407
1408     ### check if we even have the module installed -- no point in continuing
1409     ### otherwise
1410     unless( $self->installed_version ) {
1411         error( loc( "Module '%1' is not installed, so cannot uninstall",
1412                     $self->module ) );
1413         return;
1414     }
1415
1416                                                 ### nothing to uninstall ###
1417     my $files   = $self->files( type => $type )             or return;
1418     my $dirs    = $self->directory_tree( type => $type )    or return;
1419     my $sudo    = $conf->get_program('sudo');
1420
1421     ### just in case there's no file; M::B doensn't provide .packlists yet ###
1422     my $pack    = $self->packlist;
1423     $pack       = $pack->[0]->packlist_file() if $pack;
1424
1425     ### first remove the files, then the dirs if they are empty ###
1426     my $flag = 0;
1427     for my $file( @$files, $pack ) {
1428         next unless defined $file && -f $file;
1429
1430         msg(loc("Unlinking '%1'", $file), $verbose);
1431
1432         my @cmd = ($^X, "-eunlink+q[$file]");
1433         unshift @cmd, $sudo if $sudo;
1434
1435         my $buffer;
1436         unless ( run(   command => \@cmd,
1437                         verbose => $verbose,
1438                         buffer  => \$buffer )
1439         ) {
1440             error(loc("Failed to unlink '%1': '%2'",$file, $buffer));
1441             $flag++;
1442         }
1443     }
1444
1445     for my $dir ( sort @$dirs ) {
1446         local *DIR;
1447         opendir DIR, $dir or next;
1448         my @count = readdir(DIR);
1449         close DIR;
1450
1451         next unless @count == 2;    # . and ..
1452
1453         msg(loc("Removing '%1'", $dir), $verbose);
1454
1455         ### this fails on my win2k machines.. it indeed leaves the
1456         ### dir, but it's not a critical error, since the files have
1457         ### been removed. --kane
1458         #unless( rmdir $dir ) {
1459         #    error( loc( "Could not remove '%1': %2", $dir, $! ) )
1460         #        unless $^O eq 'MSWin32';
1461         #}
1462
1463         my @cmd = ($^X, "-e", "rmdir q[$dir]");
1464         unshift @cmd, $sudo if $sudo;
1465
1466         my $buffer;
1467         unless ( run(   command => \@cmd,
1468                         verbose => $verbose,
1469                         buffer  => \$buffer )
1470         ) {
1471             error(loc("Failed to rmdir '%1': %2",$dir,$buffer));
1472             $flag++;
1473         }
1474     }
1475
1476     $self->status->uninstall(!$flag);
1477     $self->status->installed( $flag ? 1 : undef);
1478
1479     return !$flag;
1480 }
1481
1482 =pod
1483
1484 =head2 @modobj = $self->distributions()
1485
1486 Returns a list of module objects representing all releases for this
1487 module on success, false on failure.
1488
1489 =cut
1490
1491 sub distributions {
1492     my $self = shift;
1493     my %hash = @_;
1494
1495     my @list = $self->author->distributions( %hash, module => $self ) or return;
1496
1497     ### it's another release then by the same author ###
1498     return grep { $_->package_name eq $self->package_name } @list;
1499 }
1500
1501 =pod
1502
1503 =head2 @list = $self->files ()
1504
1505 Returns a list of files used by this module, if it is installed.
1506
1507 =cut
1508
1509 sub files {
1510     return shift->_extutils_installed( @_, method => 'files' );
1511 }
1512
1513 =pod
1514
1515 =head2 @list = $self->directory_tree ()
1516
1517 Returns a list of directories used by this module.
1518
1519 =cut
1520
1521 sub directory_tree {
1522     return shift->_extutils_installed( @_, method => 'directory_tree' );
1523 }
1524
1525 =pod
1526
1527 =head2 @list = $self->packlist ()
1528
1529 Returns the C<ExtUtils::Packlist> object for this module.
1530
1531 =cut
1532
1533 sub packlist {
1534     return shift->_extutils_installed( @_, method => 'packlist' );
1535 }
1536
1537 =pod
1538
1539 =head2 @list = $self->validate ()
1540
1541 Returns a list of files that are missing for this modules, but
1542 are present in the .packlist file.
1543
1544 =cut
1545
1546 sub validate {
1547     return shift->_extutils_installed( method => 'validate' );
1548 }
1549
1550 ### generic method to call an ExtUtils::Installed method ###
1551 sub _extutils_installed {
1552     my $self = shift;
1553     my $conf = $self->parent->configure_object();
1554     my %hash = @_;
1555
1556     my ($verbose,$type,$method);
1557     my $tmpl = {
1558         verbose => {    default     => $conf->get_conf('verbose'),
1559                         store       => \$verbose, },
1560         type    => {    default     => 'all',
1561                         allow       => [qw|prog man all|],
1562                         store       => \$type, },
1563         method  => {    required    => 1,
1564                         store       => \$method,
1565                         allow       => [qw|files directory_tree packlist
1566                                         validate|],
1567                     },
1568     };
1569
1570     my $args = check( $tmpl, \%hash ) or return;
1571
1572     ### old versions of cygwin + perl < 5.8 are buggy here. bail out if we
1573     ### find we're being used by them
1574     {   my $err = ON_OLD_CYGWIN;
1575         if($err) { error($err); return };
1576     }
1577
1578     return unless can_load(
1579                         modules     => { 'ExtUtils::Installed' => '0.0' },
1580                         verbose     => $verbose,
1581                     );
1582
1583     ### search in your regular @INC, and anything you added to your config.
1584     ### this lets EU::Installed find .packlists that are *not* in the standard
1585     ### compiled in @INC path. Requires EU::I 1.42 or up. this addresses #33438
1586     ### make sure the archname path is also added, as that's where the .packlist
1587     ### files are written
1588     my @libs;
1589     for my $lib ( @{ $conf->get_conf('lib') } ) {
1590         require Config;
1591
1592         ### figure out what an MM prefix expands to. Basically, it's the
1593         ### site install target from %Config, ie: /opt/lib/perl5/site_perl/5.8.8
1594         ### minus the site wide prefix, ie: /opt
1595         ### this lets users add the dir they have set as their EU::MM PREFIX
1596         ### to our 'lib' config and it Just Works
1597         ### XXX is this the right thing to do?
1598         push @libs, do {
1599             my $site    = $Config::Config{sitelib};
1600             my $prefix  = quotemeta $Config::Config{prefix};
1601
1602             ### strip the prefix from the site dir
1603             $site =~ s/^$prefix//;
1604
1605             File::Spec->catdir( $lib, $site ),
1606             File::Spec->catdir( $lib, $site, $Config::Config{'archname'} );
1607         };
1608
1609         ### the arch specific dir, ie:
1610         ### /opt/lib/perl5/site_perl/5.8.8/darwin-2level
1611         push @libs, File::Spec->catdir( $lib, $Config::Config{'archname'} );
1612
1613         ### and just the standard dir
1614         push @libs, $lib;
1615     }
1616
1617     my $inst;
1618     unless( $inst = ExtUtils::Installed->new( extra_libs => \@libs ) ) {
1619         error( loc("Could not create an '%1' object", 'ExtUtils::Installed' ) );
1620
1621         ### in case it's being used directly... ###
1622         return;
1623     }
1624
1625
1626     {   ### EU::Installed can die =/
1627         my @files;
1628         eval { @files = $inst->$method( $self->module, $type ) };
1629
1630         if( $@ ) {
1631             chomp $@;
1632             error( loc("Could not get '%1' for '%2': %3",
1633                         $method, $self->module, $@ ) );
1634             return;
1635         }
1636
1637         return wantarray ? @files : \@files;
1638     }
1639 }
1640
1641 =head2 $bool = $self->add_to_includepath;
1642
1643 Adds the current modules path to C<@INC> and C<$PERL5LIB>. This allows
1644 you to add the module from its build dir to your path.
1645
1646 You can reset C<@INC> and C<$PERL5LIB> to its original state when you
1647 started the program, by calling:
1648
1649     $self->parent->flush('lib');
1650
1651 =cut
1652
1653 sub add_to_includepath {
1654     my $self = shift;
1655     my $cb   = $self->parent;
1656
1657     if( my $dir = $self->status->extract ) {
1658
1659             $cb->_add_to_includepath(
1660                     directories => [
1661                         File::Spec->catdir(BLIB->($dir), LIB),
1662                         File::Spec->catdir(BLIB->($dir), ARCH),
1663                         BLIB->($dir),
1664                     ]
1665             ) or return;
1666
1667     } else {
1668         error(loc(  "No extract dir registered for '%1' -- can not add ".
1669                     "add builddir to search path!", $self->module ));
1670         return;
1671     }
1672
1673     return 1;
1674
1675 }
1676
1677 =pod
1678
1679 =head2 $path = $self->best_path_to_module_build();
1680
1681 B<OBSOLETE>
1682
1683 If a newer version of Module::Build is found in your path, it will
1684 return this C<special> path. If the newest version of C<Module::Build>
1685 is found in your regular C<@INC>, the method will return false. This
1686 indicates you do not need to add a special directory to your C<@INC>.
1687
1688 Note that this is only relevant if you're building your own
1689 C<CPANPLUS::Dist::*> plugin -- the built-in dist types already have
1690 this taken care of.
1691
1692 =cut
1693
1694 ### make sure we're always running 'perl Build.PL' and friends
1695 ### against the highest version of module::build available
1696 sub best_path_to_module_build {
1697     my $self = shift;
1698
1699     ### Since M::B will actually shell out and run the Build.PL, we must
1700     ### make sure it refinds the proper version of M::B in the path.
1701     ### that may be either in our cp::inc or in site_perl, or even a
1702     ### new M::B being installed.
1703     ### don't add anything else here, as that might screw up prereq checks
1704
1705     ### XXX this might be needed for Dist::MM too, if a makefile.pl is
1706     ### masquerading as a Build.PL
1707
1708     ### did we find the most recent module::build in our installer path?
1709
1710     ### XXX can't do changes to @INC, they're being ignored by
1711     ### new_from_context when writing a Build script. see ticket:
1712     ### #8826 Module::Build ignores changes to @INC when writing Build
1713     ### from new_from_context
1714     ### XXX applied schwern's patches (as seen on CPANPLUS::Devel 10/12/04)
1715     ### and upped the version to 0.26061 of the bundled version, and things
1716     ### work again
1717
1718     ### this functionality is now obsolete -- prereqs should be installed
1719     ### and we no longer use the CPANPLUS::inc magic.. so comment this out.
1720 #     require Module::Build;
1721 #     if( CPANPLUS::inc->path_to('Module::Build') and (
1722 #         CPANPLUS::inc->path_to('Module::Build') eq
1723 #         CPANPLUS::inc->installer_path )
1724 #     ) {
1725 #
1726 #         ### if the module being installed is *not* Module::Build
1727 #         ### itself -- as that would undoubtedly be newer -- add
1728 #         ### the path to the installers to @INC
1729 #         ### if it IS module::build itself, add 'lib' to its path,
1730 #         ### as the Build.PL would do as well, but the API doesn't.
1731 #         ### this makes self updates possible
1732 #         return $self->module eq 'Module::Build'
1733 #                         ? 'lib'
1734 #                         : CPANPLUS::inc->installer_path;
1735 #     }
1736
1737     ### otherwise, the path was found through a 'normal' way of
1738     ### scanning @INC.
1739     return;
1740 }
1741
1742 =pod
1743
1744 =head1 BUG REPORTS
1745
1746 Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
1747
1748 =head1 AUTHOR
1749
1750 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
1751
1752 =head1 COPYRIGHT
1753
1754 The CPAN++ interface (of which this module is a part of) is copyright (c)
1755 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
1756
1757 This library is free software; you may redistribute and/or modify it
1758 under the same terms as Perl itself.
1759
1760 =cut
1761
1762 # Local variables:
1763 # c-indentation-style: bsd
1764 # c-basic-offset: 4
1765 # indent-tabs-mode: nil
1766 # End:
1767 # vim: expandtab shiftwidth=4:
1768
1769 1;
1770
1771 __END__
1772
1773 todo:
1774 reports();