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         my $cb   = $self->parent;
 440
 441         ### check if the package looks like a perl core package
 442         return 1 if $self->package_name eq PERL_CORE;
 443
 444         ### address #44562: ::Module->package_is_perl_code : problem comparing
 445         ### version strings -- use $cb->_vcmp to avoid warnings when version
 446         ### have _ in them
 447
 448         my $core = $self->module_is_supplied_with_perl_core;
 449         ### ok, so it's found in the core, BUT it could be dual-lifed
 450         if ($core) {
 451             ### if the package is newer than installed, then it's dual-lifed
 452             return if $cb->_vcmp($self->version, $self->installed_version) > 0;
 453
 454             ### if the package is newer or equal to the corelist,
 455             ### then it's dual-lifed
 456             return if $cb->_vcmp( $self->version, $core ) >= 0;
 457
 458             ### otherwise, it's older than corelist, thus unsuitable.
 459             return 1;
 460         }
 461
 462         ### not in corelist, not a perl core package.
 463         return;
 464     }
 465
 466     sub module_is_supplied_with_perl_core {
 467         my $self = shift;
 468         my $ver  = shift || $];
 469
 470         ### allow it to be called as a package function as well like:
 471         ###   CPANPLUS::Module::module_is_supplied_with_perl_core('Config')
 472         ### so that we can check the status of modules that aren't released
 473         ### to CPAN, but are part of the core.
 474         my $name = ref $self ? $self->module : $self;
 475
 476         ### check Module::CoreList to see if it's a core package
 477         require Module::CoreList;
 478
 479         ### Address #41157: Module::module_is_supplied_with_perl_core()
 480         ### broken for perl 5.10: Module::CoreList's version key for the
 481         ### hash has a different number of trailing zero than $] aka
 482         ### $PERL_VERSION.
 483         my $core = $Module::CoreList::version{ 0+$ver }->{ $name };
 484
 485         return $core;
 486     }
 487
 488     ### make sure Bundle-Foo also gets flagged as bundle
 489     sub is_bundle {
 490         my $self = shift;
 491
 492         ### cpan'd bundle
 493         return 1 if $self->module =~ /^bundle(?:-|::)/i;
 494
 495         ### autobundle
 496         return 1 if $self->is_autobundle;
 497
 498         ### neither
 499         return;
 500     }
 501
 502     ### full path to a generated autobundle
 503     sub is_autobundle {
 504         my $self    = shift;
 505         my $conf    = $self->parent->configure_object;
 506         my $prefix  = $conf->_get_build('autobundle_prefix');
 507
 508         return 1 if $self->module eq $prefix;
 509         return;
 510     }
 511
 512     sub is_third_party {
 513         my $self = shift;
 514
 515         return unless can_load( modules => { 'Module::ThirdParty' => 0 } );
 516
 517         return Module::ThirdParty::is_3rd_party( $self->name );
 518     }
 519
 520     sub third_party_information {
 521         my $self = shift;
 522
 523         return unless $self->is_third_party;
 524
 525         return Module::ThirdParty::module_information( $self->name );
 526     }
 527 }
 528
 529 =pod
 530
 531 =head2 $clone = $self->clone
 532
 533 Clones the current module object for tinkering with.
 534 It will have a clean C<CPANPLUS::Module::Status> object, as well as
 535 a fake C<CPANPLUS::Module::Author> object.
 536
 537 =cut
 538
 539 {   ### accessors dont change during run time, so only compute once
 540     my @acc = grep !/status/, __PACKAGE__->accessors();
 541
 542     sub clone {
 543         my $self = shift;
 544
 545         ### clone the object ###
 546         my %data = map { $_ => $self->$_ } @acc;
 547
 548         my $obj = CPANPLUS::Module::Fake->new( %data );
 549
 550         return $obj;
 551     }
 552 }
 553
 554 =pod
 555
 556 =head2 $where = $self->fetch
 557
 558 Fetches the module from a CPAN mirror.
 559 Look at L<CPANPLUS::Internals::Fetch::_fetch()> for details on the
 560 options you can pass.
 561
 562 =cut
 563
 564 sub fetch {
 565     my $self = shift;
 566     my $cb   = $self->parent;
 567
 568     ### custom args
 569     my %args            = ( module => $self );
 570
 571     ### if a custom fetch location got specified before, add that here
 572     $args{fetch_from}   = $self->status->_fetch_from
 573                             if $self->status->_fetch_from;
 574
 575     my $where = $cb->_fetch( @_, %args ) or return;
 576
 577     ### do an md5 check ###
 578     if( !$self->status->_fetch_from and
 579         $cb->configure_object->get_conf('md5') and
 580         $self->package ne CHECKSUMS
 581     ) {
 582         unless( $self->_validate_checksum ) {
 583             error( loc( "Checksum error for '%1' -- will not trust package",
 584                         $self->package) );
 585             return;
 586         }
 587     }
 588
 589     return $where;
 590 }
 591
 592 =pod
 593
 594 =head2 $path = $self->extract
 595
 596 Extracts the fetched module.
 597 Look at L<CPANPLUS::Internals::Extract::_extract()> for details on
 598 the options you can pass.
 599
 600 =cut
 601
 602 sub extract {
 603     my $self = shift;
 604     my $cb   = $self->parent;
 605
 606     unless( $self->status->fetch ) {
 607         error( loc( "You have not fetched '%1' yet -- cannot extract",
 608                     $self->module) );
 609         return;
 610     }
 611
 612     ### can't extract these, so just use the basedir for the file
 613     if( $self->is_autobundle ) {
 614
 615         ### this is expected to be set after an extract call
 616         $self->get_installer_type;
 617
 618         return $self->status->extract( dirname( $self->status->fetch ) );
 619     }
 620
 621     return $cb->_extract( @_, module => $self );
 622 }
 623
 624 =head2 $type = $self->get_installer_type([prefer_makefile => BOOL])
 625
 626 Gets the installer type for this module. This may either be C<build> or
 627 C<makemaker>. If C<Module::Build> is unavailable or no installer type
 628 is available, it will fall back to C<makemaker>. If both are available,
 629 it will pick the one indicated by your config, or by the
 630 C<prefer_makefile> option you can pass to this function.
 631
 632 Returns the installer type on success, and false on error.
 633
 634 =cut
 635
 636 sub get_installer_type {
 637     my $self = shift;
 638     my $cb   = $self->parent;
 639     my $conf = $cb->configure_object;
 640     my %hash = @_;
 641
 642     my ($prefer_makefile,$verbose);
 643     my $tmpl = {
 644         prefer_makefile => { default => $conf->get_conf('prefer_makefile'),
 645                              store   => \$prefer_makefile, allow => BOOLEANS },
 646         verbose         => { default => $conf->get_conf('verbose'),
 647                              store   => \$verbose },
 648     };
 649
 650     check( $tmpl, \%hash ) or return;
 651
 652     my $type;
 653
 654     ### autobundles use their own installer, so return that
 655     if( $self->is_autobundle ) {
 656         $type = INSTALLER_AUTOBUNDLE;
 657
 658     } else {
 659         my $extract = $self->status->extract();
 660         unless( $extract ) {
 661             error(loc(
 662                 "Cannot determine installer type of unextracted module '%1'",
 663                 $self->module
 664             ));
 665             return;
 666         }
 667
 668         ### check if it's a makemaker or a module::build type dist ###
 669         my $found_build     = -e BUILD_PL->( $extract );
 670         my $found_makefile  = -e MAKEFILE_PL->( $extract );
 671
 672         $type = INSTALLER_BUILD if !$prefer_makefile &&  $found_build;
 673         $type = INSTALLER_BUILD if  $found_build     && !$found_makefile;
 674         $type = INSTALLER_MM    if  $prefer_makefile &&  $found_makefile;
 675         $type = INSTALLER_MM    if  $found_makefile  && !$found_build;
 676     }
 677
 678     ### ok, so it's a 'build' installer, but you don't /have/ module build
 679     if( $type eq INSTALLER_BUILD and
 680         not CPANPLUS::Dist->has_dist_type( INSTALLER_BUILD )
 681     ) {
 682
 683         ### XXX this is for recording purposes only. We *have* to install
 684         ### these before even creating a dist object, or we'll get an error
 685         ### saying 'no such dist type';
 686         my $href = $self->status->configure_requires || {};
 687         my $deps = { INSTALLER_BUILD, 0, %$href };
 688
 689         $self->status->configure_requires( $deps );
 690
 691         msg(loc("This module requires '%1' and '%2' to be installed first. ".
 692                 "Adding these modules to your prerequisites list",
 693                  'Module::Build', INSTALLER_BUILD
 694         ), $verbose );
 695
 696
 697     ### ok, actually we found neither ###
 698     } elsif ( !$type ) {
 699         error( loc( "Unable to find '%1' or '%2' for '%3'; ".
 700                     "Will default to '%4' but might be unable ".
 701                     "to install!", BUILD_PL->(), MAKEFILE_PL->(),
 702                     $self->module, INSTALLER_MM ) );
 703         $type = INSTALLER_MM;
 704     }
 705
 706     return $self->status->installer_type( $type ) if $type;
 707     return;
 708 }
 709
 710 =pod
 711
 712 =head2 $dist = $self->dist([target => 'prepare|create', format => DISTRIBUTION_TYPE, args => {key => val}]);
 713
 714 Create a distribution object, ready to be installed.
 715 Distribution type defaults to your config settings
 716
 717 The optional C<args> hashref is passed on to the specific distribution
 718 types' C<create> method after being dereferenced.
 719
 720 Returns a distribution object on success, false on failure.
 721
 722 See C<CPANPLUS::Dist> for details.
 723
 724 =cut
 725
 726 sub dist {
 727     my $self = shift;
 728     my $cb   = $self->parent;
 729     my $conf = $cb->configure_object;
 730     my %hash = @_;
 731
 732     ### have you determined your installer type yet? if not, do it here,
 733     ### we need the info
 734     $self->get_installer_type unless $self->status->installer_type;
 735
 736     my($type,$args,$target);
 737     my $tmpl = {
 738         format  => { default => $conf->get_conf('dist_type') ||
 739                                 $self->status->installer_type,
 740                      store   => \$type },
 741         target  => { default => TARGET_CREATE, store => \$target },
 742         args    => { default => {}, store => \$args },
 743     };
 744
 745     check( $tmpl, \%hash ) or return;
 746
 747     ### ok, check for $type. Do we have it?
 748     unless( CPANPLUS::Dist->has_dist_type( $type ) ) {
 749
 750         ### ok, we don't have it. Is it C::D::Build? if so we can install the
 751         ### whole thing now
 752         ### XXX we _could_ do this for any type we dont have actually...
 753         if( $type eq INSTALLER_BUILD ) {
 754             msg(loc("Bootstrapping installer '%1'", $type));
 755
 756             ### don't propagate the format, it's the one we're trying to
 757             ### bootstrap, so it'll be an infinite loop if we do
 758
 759             $cb->module_tree( $type )->install( target => $target, %$args ) or
 760                 do {
 761                     error(loc("Could not bootstrap installer '%1' -- ".
 762                               "can not continue", $type));
 763                     return;
 764                 };
 765
 766             ### re-scan for available modules now
 767             CPANPLUS::Dist->rescan_dist_types;
 768
 769             unless( CPANPLUS::Dist->has_dist_type( $type ) ) {
 770                 error(loc("Newly installed installer type '%1' should be ".
 771                           "available, but is not! -- aborting", $type));
 772                 return;
 773             } else {
 774                 msg(loc("Installer '%1' succesfully bootstrapped", $type));
 775             }
 776
 777         ### some other plugin you dont have. Abort
 778         } else {
 779             error(loc("Installer type '%1' not found. Please verify your ".
 780                       "installation -- aborting", $type ));
 781             return;
 782         }
 783     }
 784
 785     ### make sure we don't overwrite it, just in case we came
 786     ### back from a ->save_state. This allows restoration to
 787     ### work correctly
 788     my( $dist, $dist_cpan );
 789
 790     unless( $dist = $self->status->dist ) {
 791         $dist = $type->new( module => $self ) or return;
 792         $self->status->dist( $dist );
 793     }
 794
 795     unless( $dist_cpan = $self->status->dist_cpan ) {
 796
 797         $dist_cpan = $type eq $self->status->installer_type
 798                         ? $self->status->dist
 799                         : $self->status->installer_type->new( module => $self );
 800
 801
 802         $self->status->dist_cpan(   $dist_cpan );
 803     }
 804
 805
 806     DIST: {
 807         ### first prepare the dist
 808         $dist->prepare( %$args ) or return;
 809         $self->status->prepared(1);
 810
 811         ### you just wanted us to prepare?
 812         last DIST if $target eq TARGET_PREPARE;
 813
 814         $dist->create( %$args ) or return;
 815         $self->status->created(1);
 816     }
 817
 818     return $dist;
 819 }
 820
 821 =pod
 822
 823 =head2 $bool = $mod->prepare( )
 824
 825 Convenience method around C<install()> that prepares a module
 826 without actually building it. This is equivalent to invoking C<install>
 827 with C<target> set to C<prepare>
 828
 829 Returns true on success, false on failure.
 830
 831 =cut
 832
 833 sub prepare {
 834     my $self = shift;
 835     return $self->install( @_, target => TARGET_PREPARE );
 836 }
 837
 838 =head2 $bool = $mod->create( )
 839
 840 Convenience method around C<install()> that creates a module.
 841 This is equivalent to invoking C<install> with C<target> set to
 842 C<create>
 843
 844 Returns true on success, false on failure.
 845
 846 =cut
 847
 848 sub create {
 849     my $self = shift;
 850     return $self->install( @_, target => TARGET_CREATE );
 851 }
 852
 853 =head2 $bool = $mod->test( )
 854
 855 Convenience wrapper around C<install()> that tests a module, without
 856 installing it.
 857 It's the equivalent to invoking C<install()> with C<target> set to
 858 C<create> and C<skiptest> set to C<0>.
 859
 860 Returns true on success, false on failure.
 861
 862 =cut
 863
 864 sub test {
 865     my $self = shift;
 866     return $self->install( @_, target => TARGET_CREATE, skiptest => 0 );
 867 }
 868
 869 =pod
 870
 871 =head2 $bool = $self->install([ target => 'prepare|create|install', format => FORMAT_TYPE, extractdir => DIRECTORY, fetchdir => DIRECTORY, prefer_bin => BOOL, force => BOOL, verbose => BOOL, ..... ]);
 872
 873 Installs the current module. This includes fetching it and extracting
 874 it, if this hasn't been done yet, as well as creating a distribution
 875 object for it.
 876
 877 This means you can pass it more arguments than described above, which
 878 will be passed on to the relevant methods as they are called.
 879
 880 See C<CPANPLUS::Internals::Fetch>, C<CPANPLUS::Internals::Extract> and
 881 C<CPANPLUS::Dist> for details.
 882
 883 Returns true on success, false on failure.
 884
 885 =cut
 886
 887 sub install {
 888     my $self = shift;
 889     my $cb   = $self->parent;
 890     my $conf = $cb->configure_object;
 891     my %hash = @_;
 892
 893     my $args; my $target; my $format;
 894     {   ### so we can use the rest of the args to the create calls etc ###
 895         local $Params::Check::NO_DUPLICATES = 1;
 896         local $Params::Check::ALLOW_UNKNOWN = 1;
 897
 898         ### targets 'dist' and 'test' are now completely ignored ###
 899         my $tmpl = {
 900                         ### match this allow list with Dist->_resolve_prereqs
 901             target     => { default => TARGET_INSTALL, store => \$target,
 902                             allow   => [TARGET_PREPARE, TARGET_CREATE,
 903                                         TARGET_INSTALL] },
 904             force      => { default => $conf->get_conf('force'), },
 905             verbose    => { default => $conf->get_conf('verbose'), },
 906             format     => { default => $conf->get_conf('dist_type'),
 907                                 store => \$format },
 908         };
 909
 910         $args = check( $tmpl, \%hash ) or return;
 911     }
 912
 913
 914     ### if this target isn't 'install', we will need to at least 'create'
 915     ### every prereq, so it can build
 916     ### XXX prereq_target of 'prepare' will do weird things here, and is
 917     ### not supported.
 918     $args->{'prereq_target'} ||= TARGET_CREATE if $target ne TARGET_INSTALL;
 919
 920     ### check if it's already upto date ###
 921     if( $target eq TARGET_INSTALL and !$args->{'force'} and
 922         !$self->package_is_perl_core() and         # separate rules apply
 923         ( $self->status->installed() or $self->is_uptodate ) and
 924         !INSTALL_VIA_PACKAGE_MANAGER->($format)
 925     ) {
 926         msg(loc("Module '%1' already up to date, won't install without force",
 927                 $self->module), $args->{'verbose'} );
 928         return $self->status->installed(1);
 929     }
 930
 931     # if it's a non-installable core package, abort the install.
 932     if( $self->package_is_perl_core() ) {
 933         # if the installed is newer, say so.
 934         if( $self->installed_version > $self->version ) {
 935             error(loc("The core Perl %1 module '%2' (%3) is more ".
 936                       "recent than the latest release on CPAN (%4). ".
 937                       "Aborting install.",
 938                       $], $self->module, $self->installed_version,
 939                       $self->version ) );
 940         # if the installed matches, say so.
 941         } elsif( $self->installed_version == $self->version ) {
 942             error(loc("The core Perl %1 module '%2' (%3) can only ".
 943                       "be installed by Perl itself. ".
 944                       "Aborting install.",
 945                       $], $self->module, $self->installed_version ) );
 946         # otherwise, the installed is older; say so.
 947         } else {
 948             error(loc("The core Perl %1 module '%2' can only be ".
 949                       "upgraded from %3 to %4 by Perl itself (%5). ".
 950                       "Aborting install.",
 951                       $], $self->module, $self->installed_version,
 952                       $self->version, $self->package ) );
 953         }
 954         return;
 955
 956     ### it might be a known 3rd party module
 957     } elsif ( $self->is_third_party ) {
 958         my $info = $self->third_party_information;
 959         error(loc(
 960             "%1 is a known third-party module.\n\n".
 961             "As it isn't available on the CPAN, CPANPLUS can't install " .
 962             "it automatically. Therefore you need to install it manually " .
 963             "before proceeding.\n\n".
 964             "%2 is part of %3, published by %4, and should be available ".
 965             "for download at the following address:\n\t%5",
 966             $self->name, $self->name, $info->{name}, $info->{author},
 967             $info->{url}
 968         ));
 969
 970         return;
 971     }
 972
 973     ### fetch it if need be ###
 974     unless( $self->status->fetch ) {
 975         my $params;
 976         for (qw[prefer_bin fetchdir]) {
 977             $params->{$_} = $args->{$_} if exists $args->{$_};
 978         }
 979         for (qw[force verbose]) {
 980             $params->{$_} = $args->{$_} if defined $args->{$_};
 981         }
 982         $self->fetch( %$params ) or return;
 983     }
 984
 985     ### extract it if need be ###
 986     unless( $self->status->extract ) {
 987         my $params;
 988         for (qw[prefer_bin extractdir]) {
 989             $params->{$_} = $args->{$_} if exists $args->{$_};
 990         }
 991         for (qw[force verbose]) {
 992             $params->{$_} = $args->{$_} if defined $args->{$_};
 993         }
 994         $self->extract( %$params ) or return;
 995     }
 996
 997     $format ||= $self->status->installer_type;
 998
 999     unless( $format ) {
1000         error( loc( "Don't know what installer to use; " .
1001                     "Couldn't find either '%1' or '%2' in the extraction " .
1002                     "directory '%3' -- will be unable to install",
1003                     BUILD_PL->(), MAKEFILE_PL->(), $self->status->extract ) );
1004
1005         $self->status->installed(0);
1006         return;
1007     }
1008
1009
1010     ### do SIGNATURE checks? ###
1011     ### XXX check status and not recheck EVERY time?
1012     if( $conf->get_conf('signature') ) {
1013         unless( $self->check_signature( verbose => $args->{verbose} ) ) {
1014             error( loc( "Signature check failed for module '%1' ".
1015                         "-- Not trusting this module, aborting install",
1016                         $self->module ) );
1017             $self->status->signature(0);
1018
1019             ### send out test report on broken sig
1020             if( $conf->get_conf('cpantest') ) {
1021                 $cb->_send_report(
1022                     module  => $self,
1023                     failed  => 1,
1024                     buffer  => CPANPLUS::Error->stack_as_string,
1025                     verbose => $args->{verbose},
1026                     force   => $args->{force},
1027                 ) or error(loc("Failed to send test report for '%1'",
1028                      $self->module ) );
1029             }
1030
1031             return;
1032
1033         } else {
1034             ### signature OK ###
1035             $self->status->signature(1);
1036         }
1037     }
1038
1039     ### a target of 'create' basically means not to run make test ###
1040     ### eh, no it /doesn't/.. skiptest => 1 means skiptest => 1.
1041     #$args->{'skiptest'} = 1 if $target eq 'create';
1042
1043     ### bundle rules apply ###
1044     if( $self->is_bundle ) {
1045         ### check what we need to install ###
1046         my @prereqs = $self->bundle_modules();
1047         unless( @prereqs ) {
1048             error( loc( "Bundle '%1' does not specify any modules to install",
1049                         $self->module ) );
1050
1051             ### XXX mark an error here? ###
1052         }
1053     }
1054
1055     my $dist = $self->dist( format  => $format,
1056                             target  => $target,
1057                             args    => $args );
1058     unless( $dist ) {
1059         error( loc( "Unable to create a new distribution object for '%1' " .
1060                     "-- cannot continue", $self->module ) );
1061         return;
1062     }
1063
1064     return 1 if $target ne TARGET_INSTALL;
1065
1066     my $ok = $dist->install( %$args ) ? 1 : 0;
1067
1068     $self->status->installed($ok);
1069
1070     return 1 if $ok;
1071     return;
1072 }
1073
1074 =pod @list = $self->bundle_modules()
1075
1076 Returns a list of module objects the Bundle specifies.
1077
1078 This requires you to have extracted the bundle already, using the
1079 C<extract()> method.
1080
1081 Returns false on error.
1082
1083 =cut
1084
1085 sub bundle_modules {
1086     my $self = shift;
1087     my $cb   = $self->parent;
1088
1089     unless( $self->is_bundle ) {
1090         error( loc("'%1' is not a bundle", $self->module ) );
1091         return;
1092     }
1093
1094     my @files;
1095
1096     ### autobundles are special files generated by CPANPLUS. If we can
1097     ### read the file, we can determine the prereqs
1098     if( $self->is_autobundle ) {
1099         my $where;
1100         unless( $where = $self->status->fetch ) {
1101             error(loc("Don't know where '%1' was fetched to", $self->package));
1102             return;
1103         }
1104
1105         push @files, $where
1106
1107     ### regular bundle::* upload
1108     } else {
1109         my $dir;
1110         unless( $dir = $self->status->extract ) {
1111             error(loc("Don't know where '%1' was extracted to", $self->module));
1112             return;
1113         }
1114
1115         find( {
1116             wanted   => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i },
1117             no_chdir => 1,
1118         }, $dir );
1119     }
1120
1121     my $prereqs = {}; my @list; my $seen = {};
1122     for my $file ( @files ) {
1123         my $fh = FileHandle->new($file)
1124                     or( error(loc("Could not open '%1' for reading: %2",
1125                         $file,$!)), next );
1126
1127         my $flag;
1128         while( local $_ = <$fh> ) {
1129             ### quick hack to read past the header of the file ###
1130             last if $flag && m|^=head|i;
1131
1132             ### from perldoc cpan:
1133             ### =head1 CONTENTS
1134             ### In this pod section each line obeys the format
1135             ### Module_Name [Version_String] [- optional text]
1136             $flag = 1 if m|^=head1 CONTENTS|i;
1137
1138             if ($flag && /^(?!=)(\S+)\s*(\S+)?/) {
1139                 my $module  = $1;
1140                 my $version = $cb->_version_to_number( version => $2 );
1141
1142                 my $obj = $cb->module_tree($module);
1143
1144                 unless( $obj ) {
1145                     error(loc("Cannot find bundled module '%1'", $module),
1146                           loc("-- it does not seem to exist") );
1147                     next;
1148                 }
1149
1150                 ### make sure we list no duplicates ###
1151                 unless( $seen->{ $obj->module }++ ) {
1152                     push @list, $obj;
1153                     $prereqs->{ $module } =
1154                         $cb->_version_to_number( version => $version );
1155                 }
1156             }
1157         }
1158     }
1159
1160     ### store the prereqs we just found ###
1161     $self->status->prereqs( $prereqs );
1162
1163     return @list;
1164 }
1165
1166 =pod
1167
1168 =head2 $text = $self->readme
1169
1170 Fetches the readme belonging to this module and stores it under
1171 C<< $obj->status->readme >>. Returns the readme as a string on
1172 success and returns false on failure.
1173
1174 =cut
1175
1176 sub readme {
1177     my $self = shift;
1178     my $conf = $self->parent->configure_object;
1179
1180     ### did we already dl the readme once? ###
1181     return $self->status->readme() if $self->status->readme();
1182
1183     ### this should be core ###
1184     return unless can_load( modules     => { FileHandle => '0.0' },
1185                             verbose     => 1,
1186                         );
1187
1188     ### get a clone of the current object, with a fresh status ###
1189     my $obj  = $self->clone or return;
1190
1191     ### munge the package name
1192     my $pkg = README->( $obj );
1193     $obj->package($pkg);
1194
1195     my $file;
1196     {   ### disable checksum fetches on readme downloads
1197
1198         my $tmp = $conf->get_conf( 'md5' );
1199         $conf->set_conf( md5 => 0 );
1200
1201         $file = $obj->fetch;
1202
1203         $conf->set_conf( md5 => $tmp );
1204
1205         return unless $file;
1206     }
1207
1208     ### read the file into a scalar, to store in the original object ###
1209     my $fh = new FileHandle;
1210     unless( $fh->open($file) ) {
1211         error( loc( "Could not open file '%1': %2", $file, $! ) );
1212         return;
1213     }
1214
1215     my $in = do{ local $/; <$fh> };
1216     $fh->close;
1217
1218     return $self->status->readme( $in );
1219 }
1220
1221 =pod
1222
1223 =head2 $version = $self->installed_version()
1224
1225 Returns the currently installed version of this module, if any.
1226
1227 =head2 $where = $self->installed_file()
1228
1229 Returns the location of the currently installed file of this module,
1230 if any.
1231
1232 =head2 $dir = $self->installed_dir()
1233
1234 Returns the directory (or more accurately, the C<@INC> handle) from
1235 which this module was loaded, if any.
1236
1237 =head2 $bool = $self->is_uptodate([version => VERSION_NUMBER])
1238
1239 Returns a boolean indicating if this module is uptodate or not.
1240
1241 =cut
1242
1243 ### uptodate/installed functions
1244 {   my $map = {             # hashkey,      alternate rv
1245         installed_version   => ['version',  0 ],
1246         installed_file      => ['file',     ''],
1247         installed_dir       => ['dir',      ''],
1248         is_uptodate         => ['uptodate', 0 ],
1249     };
1250
1251     while( my($method, $aref) = each %$map ) {
1252         my($key,$alt_rv) = @$aref;
1253
1254         no strict 'refs';
1255         *$method = sub {
1256             ### never use the @INC hooks to find installed versions of
1257             ### modules -- they're just there in case they're not on the
1258             ### perl install, but the user shouldn't trust them for *other*
1259             ### modules!
1260             ### XXX CPANPLUS::inc is now obsolete, so this should not
1261             ### be needed anymore
1262             #local @INC = CPANPLUS::inc->original_inc;
1263
1264             my $self = shift;
1265
1266             ### make sure check_install is not looking in %INC, as
1267             ### that may contain some of our sneakily loaded modules
1268             ### that aren't installed as such. -- kane
1269             local $Module::Load::Conditional::CHECK_INC_HASH = 0;
1270             my $href = check_install(
1271                             module  => $self->module,
1272                             version => $self->version,
1273                             @_,
1274                         );
1275
1276             return $href->{$key} || $alt_rv;
1277         }
1278     }
1279 }
1280
1281
1282
1283 =pod
1284
1285 =head2 $href = $self->details()
1286
1287 Returns a hashref with key/value pairs offering more information about
1288 a particular module. For example, for C<Time::HiRes> it might look like
1289 this:
1290
1291     Author                  Jarkko Hietaniemi (jhi@iki.fi)
1292     Description             High resolution time, sleep, and alarm
1293     Development Stage       Released
1294     Installed File          /usr/local/perl/lib/Time/Hires.pm
1295     Interface Style         plain Functions, no references used
1296     Language Used           C and perl, a C compiler will be needed
1297     Package                 Time-HiRes-1.65.tar.gz
1298     Public License          Unknown
1299     Support Level           Developer
1300     Version Installed       1.52
1301     Version on CPAN         1.65
1302
1303 =cut
1304
1305 sub details {
1306     my $self = shift;
1307     my $conf = $self->parent->configure_object();
1308     my $cb   = $self->parent;
1309     my %hash = @_;
1310
1311     my $res = {
1312         Author              => loc("%1 (%2)",   $self->author->author(),
1313                                                 $self->author->email() ),
1314         Package             => $self->package,
1315         Description         => $self->description     || loc('None given'),
1316         'Version on CPAN'   => $self->version,
1317     };
1318
1319     ### check if we have the module installed
1320     ### if so, add version have and version on cpan
1321     $res->{'Version Installed'} = $self->installed_version
1322                                     if $self->installed_version;
1323     $res->{'Installed File'} = $self->installed_file if $self->installed_file;
1324
1325     my $i = 0;
1326     for my $item( split '', $self->dslip ) {
1327         $res->{ $cb->_dslip_defs->[$i]->[0] } =
1328                 $cb->_dslip_defs->[$i]->[1]->{$item} || loc('Unknown');
1329         $i++;
1330     }
1331
1332     return $res;
1333 }
1334
1335 =head2 @list = $self->contains()
1336
1337 Returns a list of module objects that represent the modules also
1338 present in the package of this module.
1339
1340 For example, for C<Archive::Tar> this might return:
1341
1342     Archive::Tar
1343     Archive::Tar::Constant
1344     Archive::Tar::File
1345
1346 =cut
1347
1348 sub contains {
1349     my $self = shift;
1350     my $cb   = $self->parent;
1351     my $pkg  = $self->package;
1352
1353     my @mods = $cb->search( type => 'package', allow => [qr/^$pkg$/] );
1354
1355     return @mods;
1356 }
1357
1358 =pod
1359
1360 =head2 @list_of_hrefs = $self->fetch_report()
1361
1362 This function queries the CPAN testers database at
1363 I<http://testers.cpan.org/> for test results of specified module
1364 objects, module names or distributions.
1365
1366 Look at L<CPANPLUS::Internals::Report::_query_report()> for details on
1367 the options you can pass and the return value to expect.
1368
1369 =cut
1370
1371 sub fetch_report {
1372     my $self    = shift;
1373     my $cb      = $self->parent;
1374
1375     return $cb->_query_report( @_, module => $self );
1376 }
1377
1378 =pod
1379
1380 =head2 $bool = $self->uninstall([type => [all|man|prog])
1381
1382 This function uninstalls the specified module object.
1383
1384 You can install 2 types of files, either C<man> pages or C<prog>ram
1385 files. Alternately you can specify C<all> to uninstall both (which
1386 is the default).
1387
1388 Returns true on success and false on failure.
1389
1390 Do note that this does an uninstall via the so-called C<.packlist>,
1391 so if you used a module installer like say, C<ports> or C<apt>, you
1392 should not use this, but use your package manager instead.
1393
1394 =cut
1395
1396 sub uninstall {
1397     my $self = shift;
1398     my $conf = $self->parent->configure_object();
1399     my %hash = @_;
1400
1401     my ($type,$verbose);
1402     my $tmpl = {
1403         type    => { default => 'all', allow => [qw|man prog all|],
1404                         store => \$type },
1405         verbose => { default => $conf->get_conf('verbose'),
1406                         store => \$verbose },
1407         force   => { default => $conf->get_conf('force') },
1408     };
1409
1410     ### XXX add a warning here if your default install dist isn't
1411     ### makefile or build -- that means you are using a package manager
1412     ### and this will not do what you think!
1413
1414     my $args = check( $tmpl, \%hash ) or return;
1415
1416     if( $conf->get_conf('dist_type') and (
1417         ($conf->get_conf('dist_type') ne INSTALLER_BUILD) or
1418         ($conf->get_conf('dist_type') ne INSTALLER_MM))
1419     ) {
1420         msg(loc("You have a default installer type set (%1) ".
1421                 "-- you should probably use that package manager to " .
1422                 "uninstall modules", $conf->get_conf('dist_type')), $verbose);
1423     }
1424
1425     ### check if we even have the module installed -- no point in continuing
1426     ### otherwise
1427     unless( $self->installed_version ) {
1428         error( loc( "Module '%1' is not installed, so cannot uninstall",
1429                     $self->module ) );
1430         return;
1431     }
1432
1433                                                 ### nothing to uninstall ###
1434     my $files   = $self->files( type => $type )             or return;
1435     my $dirs    = $self->directory_tree( type => $type )    or return;
1436     my $sudo    = $conf->get_program('sudo');
1437
1438     ### just in case there's no file; M::B doensn't provide .packlists yet ###
1439     my $pack    = $self->packlist;
1440     $pack       = $pack->[0]->packlist_file() if $pack;
1441
1442     ### first remove the files, then the dirs if they are empty ###
1443     my $flag = 0;
1444     for my $file( @$files, $pack ) {
1445         next unless defined $file && -f $file;
1446
1447         msg(loc("Unlinking '%1'", $file), $verbose);
1448
1449         my @cmd = ($^X, "-eunlink+q[$file]");
1450         unshift @cmd, $sudo if $sudo;
1451
1452         my $buffer;
1453         unless ( run(   command => \@cmd,
1454                         verbose => $verbose,
1455                         buffer  => \$buffer )
1456         ) {
1457             error(loc("Failed to unlink '%1': '%2'",$file, $buffer));
1458             $flag++;
1459         }
1460     }
1461
1462     for my $dir ( sort @$dirs ) {
1463         local *DIR;
1464         opendir DIR, $dir or next;
1465         my @count = readdir(DIR);
1466         close DIR;
1467
1468         next unless @count == 2;    # . and ..
1469
1470         msg(loc("Removing '%1'", $dir), $verbose);
1471
1472         ### this fails on my win2k machines.. it indeed leaves the
1473         ### dir, but it's not a critical error, since the files have
1474         ### been removed. --kane
1475         #unless( rmdir $dir ) {
1476         #    error( loc( "Could not remove '%1': %2", $dir, $! ) )
1477         #        unless $^O eq 'MSWin32';
1478         #}
1479
1480         my @cmd = ($^X, "-e", "rmdir q[$dir]");
1481         unshift @cmd, $sudo if $sudo;
1482
1483         my $buffer;
1484         unless ( run(   command => \@cmd,
1485                         verbose => $verbose,
1486                         buffer  => \$buffer )
1487         ) {
1488             error(loc("Failed to rmdir '%1': %2",$dir,$buffer));
1489             $flag++;
1490         }
1491     }
1492
1493     $self->status->uninstall(!$flag);
1494     $self->status->installed( $flag ? 1 : undef);
1495
1496     return !$flag;
1497 }
1498
1499 =pod
1500
1501 =head2 @modobj = $self->distributions()
1502
1503 Returns a list of module objects representing all releases for this
1504 module on success, false on failure.
1505
1506 =cut
1507
1508 sub distributions {
1509     my $self = shift;
1510     my %hash = @_;
1511
1512     my @list = $self->author->distributions( %hash, module => $self ) or return;
1513
1514     ### it's another release then by the same author ###
1515     return grep { $_->package_name eq $self->package_name } @list;
1516 }
1517
1518 =pod
1519
1520 =head2 @list = $self->files ()
1521
1522 Returns a list of files used by this module, if it is installed.
1523
1524 =head2 @list = $self->directory_tree ()
1525
1526 Returns a list of directories used by this module.
1527
1528 =head2 @list = $self->packlist ()
1529
1530 Returns the C<ExtUtils::Packlist> object for this module.
1531
1532 =head2 @list = $self->validate ()
1533
1534 Returns a list of files that are missing for this modules, but
1535 are present in the .packlist file.
1536
1537 =cut
1538
1539 for my $sub (qw[files directory_tree packlist validate]) {
1540     no strict 'refs';
1541     *$sub = sub {
1542         return shift->_extutils_installed( @_, method => $sub );
1543     }
1544 }
1545
1546 ### generic method to call an ExtUtils::Installed method ###
1547 sub _extutils_installed {
1548     my $self = shift;
1549     my $cb   = $self->parent;
1550     my $conf = $cb->configure_object;
1551     my $home = $cb->_home_dir;          # may be needed to fix up prefixes
1552     my %hash = @_;
1553
1554     my ($verbose,$type,$method);
1555     my $tmpl = {
1556         verbose => {    default     => $conf->get_conf('verbose'),
1557                         store       => \$verbose, },
1558         type    => {    default     => 'all',
1559                         allow       => [qw|prog man all|],
1560                         store       => \$type, },
1561         method  => {    required    => 1,
1562                         store       => \$method,
1563                         allow       => [qw|files directory_tree packlist
1564                                         validate|],
1565                     },
1566     };
1567
1568     my $args = check( $tmpl, \%hash ) or return;
1569
1570     ### old versions of cygwin + perl < 5.8 are buggy here. bail out if we
1571     ### find we're being used by them
1572     {   my $err = ON_OLD_CYGWIN;
1573         if($err) { error($err); return };
1574     }
1575
1576     return unless can_load(
1577                         modules     => { 'ExtUtils::Installed' => '0.0' },
1578                         verbose     => $verbose,
1579                     );
1580
1581     my @config_names = (
1582         ### lib
1583         {   lib     => 'privlib',       # perl-only
1584             arch    => 'archlib',       # compiled code
1585             prefix  => 'prefix',        # prefix to both
1586         },
1587         ### site
1588         {   lib      => 'sitelib',
1589             arch     => 'sitearch',
1590             prefix   => 'siteprefix',
1591         },
1592         ### vendor
1593         {   lib     => 'vendorlib',
1594             arch    => 'vendorarch',
1595             prefix  => 'vendorprefix',
1596         },
1597     );
1598
1599     ### search in your regular @INC, and anything you added to your config.
1600     ### this lets EU::Installed find .packlists that are *not* in the standard
1601     ### compiled in @INC path. Requires EU::I 1.42 or up. this addresses #33438
1602     ### make sure the archname path is also added, as that's where the .packlist
1603     ### files are written
1604     my @libs;
1605     for my $lib ( @{ $conf->get_conf('lib') } ) {
1606         require Config;
1607
1608         ### and just the standard dir
1609         push @libs, $lib;
1610
1611         ### figure out what an MM prefix expands to. Basically, it's the
1612         ### site install target from %Config, ie: /opt/lib/perl5/site_perl/5.8.8
1613         ### minus the site wide prefix, ie: /opt
1614         ### this lets users add the dir they have set as their EU::MM PREFIX
1615         ### to our 'lib' config and it Just Works
1616         ### the arch specific dir, ie:
1617         ### /opt/lib/perl5/site_perl/5.8.8/darwin-2level
1618         ### XXX is this the right thing to do?
1619
1620         ### we add all 6 dir combos for prefixes:
1621         ### /foo/lib
1622         ### /foo/lib/arch
1623         ### /foo/site/lib
1624         ### /foo/site/lib/arch
1625         ### /foo/vendor/lib
1626         ### /foo/vendor/lib/arch
1627         for my $href ( @config_names ) {
1628             for my $key ( qw[lib arch] ) {
1629
1630                 ### look up the config value -- use EXP for the EXPANDED
1631                 ### version, so no ~ etc are found in there
1632                 my $dir     = $Config::Config{ $href->{ $key } .'exp' } or next;
1633                 my $prefix  = $Config::Config{ $href->{prefix} };
1634
1635                 ### prefix may be relative to home, and contain a ~
1636                 ### if so, fix it up.
1637                 $prefix     =~ s/^~/$home/;
1638
1639                 ### remove the prefix from it, so we can append to our $lib
1640                 $dir        =~ s/^\Q$prefix\E//;
1641
1642                 ### do the appending
1643                 push @libs, File::Spec->catdir( $lib, $dir );
1644
1645             }
1646         }
1647     }
1648
1649     my $inst;
1650     unless( $inst = ExtUtils::Installed->new( extra_libs => \@libs ) ) {
1651         error( loc("Could not create an '%1' object", 'ExtUtils::Installed' ) );
1652
1653         ### in case it's being used directly... ###
1654         return;
1655     }
1656
1657
1658     {   ### EU::Installed can die =/
1659         my @files;
1660         eval { @files = $inst->$method( $self->module, $type ) };
1661
1662         if( $@ ) {
1663             chomp $@;
1664             error( loc("Could not get '%1' for '%2': %3",
1665                         $method, $self->module, $@ ) );
1666             return;
1667         }
1668
1669         return wantarray ? @files : \@files;
1670     }
1671 }
1672
1673 =head2 $bool = $self->add_to_includepath;
1674
1675 Adds the current modules path to C<@INC> and C<$PERL5LIB>. This allows
1676 you to add the module from its build dir to your path.
1677
1678 You can reset C<@INC> and C<$PERL5LIB> to its original state when you
1679 started the program, by calling:
1680
1681     $self->parent->flush('lib');
1682
1683 =cut
1684
1685 sub add_to_includepath {
1686     my $self = shift;
1687     my $cb   = $self->parent;
1688
1689     if( my $dir = $self->status->extract ) {
1690
1691             $cb->_add_to_includepath(
1692                     directories => [
1693                         File::Spec->catdir(BLIB->($dir), LIB),
1694                         File::Spec->catdir(BLIB->($dir), ARCH),
1695                         BLIB->($dir),
1696                     ]
1697             ) or return;
1698
1699     } else {
1700         error(loc(  "No extract dir registered for '%1' -- can not add ".
1701                     "add builddir to search path!", $self->module ));
1702         return;
1703     }
1704
1705     return 1;
1706
1707 }
1708
1709 =pod
1710
1711 =head2 $path = $self->best_path_to_module_build();
1712
1713 B<OBSOLETE>
1714
1715 If a newer version of Module::Build is found in your path, it will
1716 return this C<special> path. If the newest version of C<Module::Build>
1717 is found in your regular C<@INC>, the method will return false. This
1718 indicates you do not need to add a special directory to your C<@INC>.
1719
1720 Note that this is only relevant if you're building your own
1721 C<CPANPLUS::Dist::*> plugin -- the built-in dist types already have
1722 this taken care of.
1723
1724 =cut
1725
1726 ### make sure we're always running 'perl Build.PL' and friends
1727 ### against the highest version of module::build available
1728 sub best_path_to_module_build {
1729     my $self = shift;
1730
1731     ### Since M::B will actually shell out and run the Build.PL, we must
1732     ### make sure it refinds the proper version of M::B in the path.
1733     ### that may be either in our cp::inc or in site_perl, or even a
1734     ### new M::B being installed.
1735     ### don't add anything else here, as that might screw up prereq checks
1736
1737     ### XXX this might be needed for Dist::MM too, if a makefile.pl is
1738     ### masquerading as a Build.PL
1739
1740     ### did we find the most recent module::build in our installer path?
1741
1742     ### XXX can't do changes to @INC, they're being ignored by
1743     ### new_from_context when writing a Build script. see ticket:
1744     ### #8826 Module::Build ignores changes to @INC when writing Build
1745     ### from new_from_context
1746     ### XXX applied schwern's patches (as seen on CPANPLUS::Devel 10/12/04)
1747     ### and upped the version to 0.26061 of the bundled version, and things
1748     ### work again
1749
1750     ### this functionality is now obsolete -- prereqs should be installed
1751     ### and we no longer use the CPANPLUS::inc magic.. so comment this out.
1752 #     require Module::Build;
1753 #     if( CPANPLUS::inc->path_to('Module::Build') and (
1754 #         CPANPLUS::inc->path_to('Module::Build') eq
1755 #         CPANPLUS::inc->installer_path )
1756 #     ) {
1757 #
1758 #         ### if the module being installed is *not* Module::Build
1759 #         ### itself -- as that would undoubtedly be newer -- add
1760 #         ### the path to the installers to @INC
1761 #         ### if it IS module::build itself, add 'lib' to its path,
1762 #         ### as the Build.PL would do as well, but the API doesn't.
1763 #         ### this makes self updates possible
1764 #         return $self->module eq 'Module::Build'
1765 #                         ? 'lib'
1766 #                         : CPANPLUS::inc->installer_path;
1767 #     }
1768
1769     ### otherwise, the path was found through a 'normal' way of
1770     ### scanning @INC.
1771     return;
1772 }
1773
1774 =pod
1775
1776 =head1 BUG REPORTS
1777
1778 Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
1779
1780 =head1 AUTHOR
1781
1782 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
1783
1784 =head1 COPYRIGHT
1785
1786 The CPAN++ interface (of which this module is a part of) is copyright (c)
1787 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
1788
1789 This library is free software; you may redistribute and/or modify it
1790 under the same terms as Perl itself.
1791
1792 =cut
1793
1794 # Local variables:
1795 # c-indentation-style: bsd
1796 # c-basic-offset: 4
1797 # indent-tabs-mode: nil
1798 # End:
1799 # vim: expandtab shiftwidth=4:
1800
1801 1;
1802
1803 __END__
1804
1805 todo:
1806 reports();