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