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