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