This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
3fc14622054dbd933cf8baab3a659d31d6ce4c6c
[perl5.git] / 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();