Update CPANPLUS to 0.86
[p5sagit/p5-mst-13.2.git] / lib / CPANPLUS / Module.pm
CommitLineData
6aaee015 1package CPANPLUS::Module;
2
3use strict;
4use vars qw[@ISA];
5
6
7use CPANPLUS::Dist;
8use CPANPLUS::Error;
9use CPANPLUS::Module::Signature;
10use CPANPLUS::Module::Checksums;
11use CPANPLUS::Internals::Constants;
12
13use FileHandle;
14
15use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
16use IPC::Cmd qw[can_run run];
17use File::Find qw[find];
18use Params::Check qw[check];
4443dd53 19use File::Basename qw[dirname];
6aaee015 20use 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
30CPANPLUS::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
49C<CPANPLUS::Module> creates objects from the information in the
50source files. These can then be used to query and perform actions
51on, like fetching or installing.
52
53These objects should only be created internally. For C<fake> objects,
54there's the C<CPANPLUS::Module::Fake> class. To obtain a module object
55consult the C<CPANPLUS::Backend> documentation.
56
57=cut
58
59my $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
5879cbe1 70 dslip => { default => EMPTY_DSLIP }, # dslip information
6aaee015 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
5879cbe1 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 }
6aaee015 97 }
98}
99
5879cbe1 100
6aaee015 101=pod
102
103=head1 CLASS METHODS
104
105=head2 accessors ()
106
107Returns a list of all accessor methods to the object
108
109=cut
110
111### *name is an alias, include it explicitly
112sub accessors { return ('name', keys %$tmpl) };
113
114=head1 ACCESSORS
115
116An objects of this class has the following accessors:
117
118=over 4
119
120=item name
121
122Name of the module.
123
124=item module
125
126Name of the module.
127
128=item version
129
130Version of the module. Defaults to '0.0' if none was provided.
131
132=item path
133
134Extended path on the mirror.
135
136=item comment
137
138Any comment about the module -- largely unused.
139
140=item package
141
142The name of the package.
143
144=item description
145
146Description of the module -- only registered modules have this.
147
148=item dslip
149
150The five character dslip string, that represents meta-data of the
151module -- again, only registered modules have this.
152
5879cbe1 153=cut
154
155sub 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
6aaee015 174=item status
175
176The C<CPANPLUS::Module::Status> object associated with this object.
177(see below).
178
179=item author
180
181The C<CPANPLUS::Module::Author> object associated with this object.
182
183=item parent
184
185The 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
194sub 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
203C<CPANPLUS> caches a lot of results from method calls and saves data
204it collected along the road for later reuse.
205
206C<CPANPLUS> uses this internally, but it is also available for the end
207user. You can get a status object by calling:
208
209 $modobj->status
210
211You can then query the object as follows:
212
213=over 4
214
215=item installer_type
216
217The installer type used for this distribution. Will be one of
218'makemaker' or 'build'. This determines whether C<CPANPLUS::Dist::MM>
219or C<CPANPLUS::Dist::Build> will be used to build this distribution.
220
221=item dist_cpan
222
223The dist object used to do the CPAN-side of the installation. Either
224a C<CPANPLUS::Dist::MM> or C<CPANPLUS::Dist::Build> object.
225
226=item dist
227
228The custom dist object used to do the operating specific side of the
229installation, if you've chosen to use this. For example, if you've
230chosen to install using the C<ports> format, this may be a
231C<CPANPLUS::Dist::Ports> object.
232
233Undefined if you didn't specify a separate format to install through.
234
4443dd53 235=item prereqs | requires
6aaee015 236
237A hashref of prereqs this distribution was found to have. Will look
238something like this:
239
240 { Carp => 0.01, strict => 0 }
241
242Might be undefined if the distribution didn't have any prerequisites.
243
4443dd53 244=item configure_requires
245
246Like prereqs, but these are necessary to be installed before the
247build process can even begin.
248
6aaee015 249=item signature
250
251Flag indicating, if a signature check was done, whether it was OK or
252not.
253
254=item extract
255
256The directory this distribution was extracted to.
257
258=item fetch
259
260The location this distribution was fetched to.
261
262=item readme
263
264The text of this distributions README file.
265
266=item uninstall
267
268Flag indicating if an uninstall call was done successfully.
269
270=item created
271
272Flag indicating if the C<create> call to your dist object was done
273successfully.
274
275=item installed
276
277Flag indicating if the C<install> call to your dist object was done
278successfully.
279
280=item checksums
281
282The location of this distributions CHECKSUMS file.
283
284=item checksum_ok
285
286Flag indicating if the checksums check was done successfully.
287
288=item checksum_value
289
290The checksum value this distribution is expected to have
291
292=back
293
294=head1 METHODS
295
4443dd53 296=head2 $self = CPANPLUS::Module->new( OPTIONS )
6aaee015 297
298This method returns a C<CPANPLUS::Module> object. Normal users
299should never call this method directly, but instead use the
300C<CPANPLUS::Backend> to obtain module objects.
301
302This 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
312Every accessor is also a valid option to pass to C<new>.
313
314Returns a module object on success and false on failure.
315
316=cut
317
318
319sub 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
334sub 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
4443dd53 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' );
6aaee015 349
350 $self->_status( $acc );
351
352 return $self->_status;
353}
354
355
356### flush the cache of this object ###
357sub _flush {
358 my $self = shift;
359 $self->status->mk_flush;
360 return 1;
361}
362
4443dd53 363=head2 $mod->package_name( [$package_string] )
6aaee015 364
365Returns the name of the package a module is in. For C<Acme::Bleach>
366that might be C<Acme-Bleach>.
367
4443dd53 368=head2 $mod->package_version( [$package_string] )
6aaee015 369
370Returns the version of the package a module is in. For a module
371in the package C<Acme-Bleach-1.1.tar.gz> this would be C<1.1>.
372
4443dd53 373=head2 $mod->package_extension( [$package_string] )
6aaee015 374
375Returns the suffix added by the compression method of a package a
376certain module is in. For a module in C<Acme-Bleach-1.1.tar.gz>, this
377would be C<tar.gz>.
378
379=head2 $mod->package_is_perl_core
380
381Returns a boolean indicating of the package a particular module is in,
382is actually a core perl distribution.
383
384=head2 $mod->module_is_supplied_with_perl_core( [version => $]] )
385
386Returns a boolean indicating whether C<ANY VERSION> of this module
387was supplied with the current running perl's core package.
388
389=head2 $mod->is_bundle
390
391Returns a boolean indicating if the module you are looking at, is
392actually a bundle. Bundles are identified as modules whose name starts
393with C<Bundle::>.
394
4443dd53 395=head2 $mod->is_autobundle;
396
397Returns a boolean indicating if the module you are looking at, is
398actually an autobundle as generated by C<< $cb->autobundle >>.
399
6aaee015 400=head2 $mod->is_third_party
401
402Returns a boolean indicating whether the package is a known third-party
403module (i.e. it's not provided by the standard Perl distribution and
404is not available on the CPAN, but on a third party software provider).
405See L<Module::ThirdParty> for more details.
406
407=head2 $mod->third_party_information
408
409Returns a reference to a hash with more information about a third-party
410module. See the documentation about C<module_information()> in
411L<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;
4443dd53 428 my $val = shift || $self->package;
429 my @res = $self->parent->_split_package_string( package => $val );
6aaee015 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;
20afcebf 439 my $cb = $self->parent;
6aaee015 440
441 ### check if the package looks like a perl core package
442 return 1 if $self->package_name eq PERL_CORE;
443
20afcebf 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
6aaee015 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
20afcebf 452 return if $cb->_vcmp($self->version, $self->installed_version) > 0;
453
6aaee015 454 ### if the package is newer or equal to the corelist,
455 ### then it's dual-lifed
20afcebf 456 return if $cb->_vcmp( $self->version, $core ) >= 0;
6aaee015 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
4443dd53 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
6aaee015 476 ### check Module::CoreList to see if it's a core package
477 require Module::CoreList;
4443dd53 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 };
6aaee015 484
485 return $core;
486 }
487
488 ### make sure Bundle-Foo also gets flagged as bundle
489 sub is_bundle {
4443dd53 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;
6aaee015 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
533Clones the current module object for tinkering with.
534It will have a clean C<CPANPLUS::Module::Status> object, as well as
535a fake C<CPANPLUS::Module::Author> object.
536
537=cut
538
4443dd53 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;
6aaee015 551 }
6aaee015 552}
553
554=pod
555
556=head2 $where = $self->fetch
557
558Fetches the module from a CPAN mirror.
559Look at L<CPANPLUS::Internals::Fetch::_fetch()> for details on the
560options you can pass.
561
562=cut
563
564sub 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
596Extracts the fetched module.
597Look at L<CPANPLUS::Internals::Extract::_extract()> for details on
598the options you can pass.
599
600=cut
601
602sub 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 }
4443dd53 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
6aaee015 621 return $cb->_extract( @_, module => $self );
622}
623
624=head2 $type = $self->get_installer_type([prefer_makefile => BOOL])
625
626Gets the installer type for this module. This may either be C<build> or
627C<makemaker>. If C<Module::Build> is unavailable or no installer type
628is available, it will fall back to C<makemaker>. If both are available,
629it will pick the one indicated by your config, or by the
630C<prefer_makefile> option you can pass to this function.
631
632Returns the installer type on success, and false on error.
633
634=cut
635
636sub get_installer_type {
637 my $self = shift;
638 my $cb = $self->parent;
639 my $conf = $cb->configure_object;
640 my %hash = @_;
641
4443dd53 642 my ($prefer_makefile,$verbose);
6aaee015 643 my $tmpl = {
644 prefer_makefile => { default => $conf->get_conf('prefer_makefile'),
4443dd53 645 store => \$prefer_makefile, allow => BOOLEANS },
646 verbose => { default => $conf->get_conf('verbose'),
647 store => \$verbose },
6aaee015 648 };
649
650 check( $tmpl, \%hash ) or return;
651
6aaee015 652 my $type;
4443dd53 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 }
6aaee015 677
678 ### ok, so it's a 'build' installer, but you don't /have/ module build
4443dd53 679 if( $type eq INSTALLER_BUILD and
680 not CPANPLUS::Dist->has_dist_type( INSTALLER_BUILD )
6aaee015 681 ) {
4443dd53 682
683 ### XXX this is for recording purposes only. We *have* to install
684 ### these before even creating a dist object, or we'll get an error
685 ### saying 'no such dist type';
686 my $href = $self->status->configure_requires || {};
687 my $deps = { INSTALLER_BUILD, 0, %$href };
688
689 $self->status->configure_requires( $deps );
690
691 msg(loc("This module requires '%1' and '%2' to be installed first. ".
692 "Adding these modules to your prerequisites list",
693 'Module::Build', INSTALLER_BUILD
694 ), $verbose );
695
6aaee015 696
697 ### ok, actually we found neither ###
698 } elsif ( !$type ) {
699 error( loc( "Unable to find '%1' or '%2' for '%3'; ".
700 "Will default to '%4' but might be unable ".
701 "to install!", BUILD_PL->(), MAKEFILE_PL->(),
702 $self->module, INSTALLER_MM ) );
703 $type = INSTALLER_MM;
704 }
705
706 return $self->status->installer_type( $type ) if $type;
707 return;
708}
709
710=pod
711
712=head2 $dist = $self->dist([target => 'prepare|create', format => DISTRIBUTION_TYPE, args => {key => val}]);
713
714Create a distribution object, ready to be installed.
715Distribution type defaults to your config settings
716
717The optional C<args> hashref is passed on to the specific distribution
718types' C<create> method after being dereferenced.
719
720Returns a distribution object on success, false on failure.
721
722See C<CPANPLUS::Dist> for details.
723
724=cut
725
726sub dist {
727 my $self = shift;
728 my $cb = $self->parent;
729 my $conf = $cb->configure_object;
730 my %hash = @_;
731
732 ### have you determined your installer type yet? if not, do it here,
733 ### we need the info
734 $self->get_installer_type unless $self->status->installer_type;
735
6aaee015 736 my($type,$args,$target);
737 my $tmpl = {
738 format => { default => $conf->get_conf('dist_type') ||
739 $self->status->installer_type,
740 store => \$type },
741 target => { default => TARGET_CREATE, store => \$target },
742 args => { default => {}, store => \$args },
743 };
744
745 check( $tmpl, \%hash ) or return;
746
4443dd53 747 ### ok, check for $type. Do we have it?
748 unless( CPANPLUS::Dist->has_dist_type( $type ) ) {
749
750 ### ok, we don't have it. Is it C::D::Build? if so we can install the
751 ### whole thing now
752 ### XXX we _could_ do this for any type we dont have actually...
753 if( $type eq INSTALLER_BUILD ) {
754 msg(loc("Bootstrapping installer '%1'", $type));
755
756 ### don't propagate the format, it's the one we're trying to
757 ### bootstrap, so it'll be an infinite loop if we do
758
759 $cb->module_tree( $type )->install( target => $target, %$args ) or
760 do {
761 error(loc("Could not bootstrap installer '%1' -- ".
762 "can not continue", $type));
763 return;
764 };
765
766 ### re-scan for available modules now
767 CPANPLUS::Dist->rescan_dist_types;
768
769 unless( CPANPLUS::Dist->has_dist_type( $type ) ) {
770 error(loc("Newly installed installer type '%1' should be ".
771 "available, but is not! -- aborting", $type));
772 return;
773 } else {
774 msg(loc("Installer '%1' succesfully bootstrapped", $type));
775 }
776
777 ### some other plugin you dont have. Abort
778 } else {
779 error(loc("Installer type '%1' not found. Please verify your ".
780 "installation -- aborting", $type ));
781 return;
782 }
783 }
784
20afcebf 785 ### make sure we don't overwrite it, just in case we came
786 ### back from a ->save_state. This allows restoration to
787 ### work correctly
788 my( $dist, $dist_cpan );
789
790 unless( $dist = $self->status->dist ) {
791 $dist = $type->new( module => $self ) or return;
792 $self->status->dist( $dist );
793 }
794
795 unless( $dist_cpan = $self->status->dist_cpan ) {
796
797 $dist_cpan = $type eq $self->status->installer_type
798 ? $self->status->dist
4443dd53 799 : $self->status->installer_type->new( module => $self );
6aaee015 800
20afcebf 801
802 $self->status->dist_cpan( $dist_cpan );
803 }
804
6aaee015 805
806 DIST: {
807 ### first prepare the dist
808 $dist->prepare( %$args ) or return;
809 $self->status->prepared(1);
810
811 ### you just wanted us to prepare?
812 last DIST if $target eq TARGET_PREPARE;
813
814 $dist->create( %$args ) or return;
815 $self->status->created(1);
816 }
817
818 return $dist;
819}
820
821=pod
822
823=head2 $bool = $mod->prepare( )
824
825Convenience method around C<install()> that prepares a module
826without actually building it. This is equivalent to invoking C<install>
827with C<target> set to C<prepare>
828
829Returns true on success, false on failure.
830
831=cut
832
833sub prepare {
834 my $self = shift;
835 return $self->install( @_, target => TARGET_PREPARE );
836}
837
838=head2 $bool = $mod->create( )
839
840Convenience method around C<install()> that creates a module.
841This is equivalent to invoking C<install> with C<target> set to
842C<create>
843
844Returns true on success, false on failure.
845
846=cut
847
848sub create {
849 my $self = shift;
850 return $self->install( @_, target => TARGET_CREATE );
851}
852
853=head2 $bool = $mod->test( )
854
855Convenience wrapper around C<install()> that tests a module, without
856installing it.
857It's the equivalent to invoking C<install()> with C<target> set to
858C<create> and C<skiptest> set to C<0>.
859
860Returns true on success, false on failure.
861
862=cut
863
864sub test {
865 my $self = shift;
866 return $self->install( @_, target => TARGET_CREATE, skiptest => 0 );
867}
868
869=pod
870
871=head2 $bool = $self->install([ target => 'prepare|create|install', format => FORMAT_TYPE, extractdir => DIRECTORY, fetchdir => DIRECTORY, prefer_bin => BOOL, force => BOOL, verbose => BOOL, ..... ]);
872
873Installs the current module. This includes fetching it and extracting
874it, if this hasn't been done yet, as well as creating a distribution
875object for it.
876
877This means you can pass it more arguments than described above, which
878will be passed on to the relevant methods as they are called.
879
880See C<CPANPLUS::Internals::Fetch>, C<CPANPLUS::Internals::Extract> and
881C<CPANPLUS::Dist> for details.
882
883Returns true on success, false on failure.
884
885=cut
886
887sub install {
888 my $self = shift;
889 my $cb = $self->parent;
890 my $conf = $cb->configure_object;
891 my %hash = @_;
892
893 my $args; my $target; my $format;
894 { ### so we can use the rest of the args to the create calls etc ###
895 local $Params::Check::NO_DUPLICATES = 1;
896 local $Params::Check::ALLOW_UNKNOWN = 1;
897
898 ### targets 'dist' and 'test' are now completely ignored ###
899 my $tmpl = {
900 ### match this allow list with Dist->_resolve_prereqs
901 target => { default => TARGET_INSTALL, store => \$target,
902 allow => [TARGET_PREPARE, TARGET_CREATE,
903 TARGET_INSTALL] },
904 force => { default => $conf->get_conf('force'), },
905 verbose => { default => $conf->get_conf('verbose'), },
906 format => { default => $conf->get_conf('dist_type'),
907 store => \$format },
908 };
909
910 $args = check( $tmpl, \%hash ) or return;
911 }
912
913
914 ### if this target isn't 'install', we will need to at least 'create'
915 ### every prereq, so it can build
916 ### XXX prereq_target of 'prepare' will do weird things here, and is
917 ### not supported.
918 $args->{'prereq_target'} ||= TARGET_CREATE if $target ne TARGET_INSTALL;
919
920 ### check if it's already upto date ###
921 if( $target eq TARGET_INSTALL and !$args->{'force'} and
922 !$self->package_is_perl_core() and # separate rules apply
923 ( $self->status->installed() or $self->is_uptodate ) and
924 !INSTALL_VIA_PACKAGE_MANAGER->($format)
925 ) {
926 msg(loc("Module '%1' already up to date, won't install without force",
927 $self->module), $args->{'verbose'} );
928 return $self->status->installed(1);
929 }
930
931 # if it's a non-installable core package, abort the install.
932 if( $self->package_is_perl_core() ) {
933 # if the installed is newer, say so.
934 if( $self->installed_version > $self->version ) {
935 error(loc("The core Perl %1 module '%2' (%3) is more ".
936 "recent than the latest release on CPAN (%4). ".
937 "Aborting install.",
938 $], $self->module, $self->installed_version,
939 $self->version ) );
940 # if the installed matches, say so.
941 } elsif( $self->installed_version == $self->version ) {
942 error(loc("The core Perl %1 module '%2' (%3) can only ".
943 "be installed by Perl itself. ".
944 "Aborting install.",
945 $], $self->module, $self->installed_version ) );
946 # otherwise, the installed is older; say so.
947 } else {
948 error(loc("The core Perl %1 module '%2' can only be ".
949 "upgraded from %3 to %4 by Perl itself (%5). ".
950 "Aborting install.",
951 $], $self->module, $self->installed_version,
952 $self->version, $self->package ) );
953 }
954 return;
955
956 ### it might be a known 3rd party module
957 } elsif ( $self->is_third_party ) {
958 my $info = $self->third_party_information;
959 error(loc(
960 "%1 is a known third-party module.\n\n".
961 "As it isn't available on the CPAN, CPANPLUS can't install " .
962 "it automatically. Therefore you need to install it manually " .
963 "before proceeding.\n\n".
964 "%2 is part of %3, published by %4, and should be available ".
965 "for download at the following address:\n\t%5",
966 $self->name, $self->name, $info->{name}, $info->{author},
967 $info->{url}
968 ));
969
970 return;
971 }
972
973 ### fetch it if need be ###
974 unless( $self->status->fetch ) {
975 my $params;
976 for (qw[prefer_bin fetchdir]) {
977 $params->{$_} = $args->{$_} if exists $args->{$_};
978 }
979 for (qw[force verbose]) {
980 $params->{$_} = $args->{$_} if defined $args->{$_};
981 }
982 $self->fetch( %$params ) or return;
983 }
984
985 ### extract it if need be ###
986 unless( $self->status->extract ) {
987 my $params;
988 for (qw[prefer_bin extractdir]) {
989 $params->{$_} = $args->{$_} if exists $args->{$_};
990 }
991 for (qw[force verbose]) {
992 $params->{$_} = $args->{$_} if defined $args->{$_};
993 }
994 $self->extract( %$params ) or return;
995 }
996
997 $format ||= $self->status->installer_type;
998
999 unless( $format ) {
1000 error( loc( "Don't know what installer to use; " .
1001 "Couldn't find either '%1' or '%2' in the extraction " .
1002 "directory '%3' -- will be unable to install",
1003 BUILD_PL->(), MAKEFILE_PL->(), $self->status->extract ) );
1004
1005 $self->status->installed(0);
1006 return;
1007 }
1008
1009
1010 ### do SIGNATURE checks? ###
20afcebf 1011 ### XXX check status and not recheck EVERY time?
6aaee015 1012 if( $conf->get_conf('signature') ) {
1013 unless( $self->check_signature( verbose => $args->{verbose} ) ) {
1014 error( loc( "Signature check failed for module '%1' ".
1015 "-- Not trusting this module, aborting install",
1016 $self->module ) );
1017 $self->status->signature(0);
1018
1019 ### send out test report on broken sig
1020 if( $conf->get_conf('cpantest') ) {
1021 $cb->_send_report(
1022 module => $self,
1023 failed => 1,
1024 buffer => CPANPLUS::Error->stack_as_string,
1025 verbose => $args->{verbose},
1026 force => $args->{force},
1027 ) or error(loc("Failed to send test report for '%1'",
1028 $self->module ) );
1029 }
1030
1031 return;
1032
1033 } else {
1034 ### signature OK ###
1035 $self->status->signature(1);
1036 }
1037 }
1038
1039 ### a target of 'create' basically means not to run make test ###
1040 ### eh, no it /doesn't/.. skiptest => 1 means skiptest => 1.
1041 #$args->{'skiptest'} = 1 if $target eq 'create';
1042
1043 ### bundle rules apply ###
1044 if( $self->is_bundle ) {
1045 ### check what we need to install ###
1046 my @prereqs = $self->bundle_modules();
1047 unless( @prereqs ) {
1048 error( loc( "Bundle '%1' does not specify any modules to install",
1049 $self->module ) );
1050
1051 ### XXX mark an error here? ###
1052 }
1053 }
1054
1055 my $dist = $self->dist( format => $format,
1056 target => $target,
1057 args => $args );
1058 unless( $dist ) {
1059 error( loc( "Unable to create a new distribution object for '%1' " .
1060 "-- cannot continue", $self->module ) );
1061 return;
1062 }
1063
1064 return 1 if $target ne TARGET_INSTALL;
1065
1066 my $ok = $dist->install( %$args ) ? 1 : 0;
1067
1068 $self->status->installed($ok);
1069
1070 return 1 if $ok;
1071 return;
1072}
1073
1074=pod @list = $self->bundle_modules()
1075
1076Returns a list of module objects the Bundle specifies.
1077
1078This requires you to have extracted the bundle already, using the
1079C<extract()> method.
1080
1081Returns false on error.
1082
1083=cut
1084
1085sub bundle_modules {
1086 my $self = shift;
1087 my $cb = $self->parent;
1088
1089 unless( $self->is_bundle ) {
1090 error( loc("'%1' is not a bundle", $self->module ) );
1091 return;
1092 }
1093
6aaee015 1094 my @files;
4443dd53 1095
1096 ### autobundles are special files generated by CPANPLUS. If we can
1097 ### read the file, we can determine the prereqs
1098 if( $self->is_autobundle ) {
1099 my $where;
1100 unless( $where = $self->status->fetch ) {
1101 error(loc("Don't know where '%1' was fetched to", $self->package));
1102 return;
1103 }
1104
1105 push @files, $where
1106
1107 ### regular bundle::* upload
1108 } else {
1109 my $dir;
1110 unless( $dir = $self->status->extract ) {
1111 error(loc("Don't know where '%1' was extracted to", $self->module));
1112 return;
1113 }
1114
1115 find( {
1116 wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i },
1117 no_chdir => 1,
1118 }, $dir );
1119 }
6aaee015 1120
1121 my $prereqs = {}; my @list; my $seen = {};
1122 for my $file ( @files ) {
1123 my $fh = FileHandle->new($file)
1124 or( error(loc("Could not open '%1' for reading: %2",
1125 $file,$!)), next );
1126
1127 my $flag;
4443dd53 1128 while( local $_ = <$fh> ) {
6aaee015 1129 ### quick hack to read past the header of the file ###
1130 last if $flag && m|^=head|i;
1131
1132 ### from perldoc cpan:
1133 ### =head1 CONTENTS
1134 ### In this pod section each line obeys the format
1135 ### Module_Name [Version_String] [- optional text]
1136 $flag = 1 if m|^=head1 CONTENTS|i;
1137
1138 if ($flag && /^(?!=)(\S+)\s*(\S+)?/) {
1139 my $module = $1;
4443dd53 1140 my $version = $cb->_version_to_number( version => $2 );
6aaee015 1141
1142 my $obj = $cb->module_tree($module);
1143
1144 unless( $obj ) {
1145 error(loc("Cannot find bundled module '%1'", $module),
1146 loc("-- it does not seem to exist") );
1147 next;
1148 }
1149
1150 ### make sure we list no duplicates ###
1151 unless( $seen->{ $obj->module }++ ) {
1152 push @list, $obj;
1153 $prereqs->{ $module } =
1154 $cb->_version_to_number( version => $version );
1155 }
1156 }
1157 }
1158 }
1159
1160 ### store the prereqs we just found ###
1161 $self->status->prereqs( $prereqs );
1162
1163 return @list;
1164}
1165
1166=pod
1167
1168=head2 $text = $self->readme
1169
1170Fetches the readme belonging to this module and stores it under
1171C<< $obj->status->readme >>. Returns the readme as a string on
1172success and returns false on failure.
1173
1174=cut
1175
1176sub readme {
1177 my $self = shift;
1178 my $conf = $self->parent->configure_object;
1179
1180 ### did we already dl the readme once? ###
1181 return $self->status->readme() if $self->status->readme();
1182
1183 ### this should be core ###
1184 return unless can_load( modules => { FileHandle => '0.0' },
1185 verbose => 1,
1186 );
1187
1188 ### get a clone of the current object, with a fresh status ###
1189 my $obj = $self->clone or return;
1190
1191 ### munge the package name
1192 my $pkg = README->( $obj );
1193 $obj->package($pkg);
1194
1195 my $file;
1196 { ### disable checksum fetches on readme downloads
1197
1198 my $tmp = $conf->get_conf( 'md5' );
1199 $conf->set_conf( md5 => 0 );
1200
1201 $file = $obj->fetch;
1202
1203 $conf->set_conf( md5 => $tmp );
1204
1205 return unless $file;
1206 }
1207
1208 ### read the file into a scalar, to store in the original object ###
1209 my $fh = new FileHandle;
1210 unless( $fh->open($file) ) {
1211 error( loc( "Could not open file '%1': %2", $file, $! ) );
1212 return;
1213 }
1214
4443dd53 1215 my $in = do{ local $/; <$fh> };
6aaee015 1216 $fh->close;
1217
1218 return $self->status->readme( $in );
1219}
1220
1221=pod
1222
1223=head2 $version = $self->installed_version()
1224
1225Returns the currently installed version of this module, if any.
1226
1227=head2 $where = $self->installed_file()
1228
1229Returns the location of the currently installed file of this module,
1230if any.
1231
4443dd53 1232=head2 $dir = $self->installed_dir()
1233
1234Returns the directory (or more accurately, the C<@INC> handle) from
1235which this module was loaded, if any.
1236
6aaee015 1237=head2 $bool = $self->is_uptodate([version => VERSION_NUMBER])
1238
1239Returns a boolean indicating if this module is uptodate or not.
1240
1241=cut
1242
1243### uptodate/installed functions
1244{ my $map = { # hashkey, alternate rv
1245 installed_version => ['version', 0 ],
1246 installed_file => ['file', ''],
4443dd53 1247 installed_dir => ['dir', ''],
6aaee015 1248 is_uptodate => ['uptodate', 0 ],
1249 };
1250
1251 while( my($method, $aref) = each %$map ) {
1252 my($key,$alt_rv) = @$aref;
1253
1254 no strict 'refs';
1255 *$method = sub {
1256 ### never use the @INC hooks to find installed versions of
1257 ### modules -- they're just there in case they're not on the
1258 ### perl install, but the user shouldn't trust them for *other*
1259 ### modules!
1260 ### XXX CPANPLUS::inc is now obsolete, so this should not
1261 ### be needed anymore
1262 #local @INC = CPANPLUS::inc->original_inc;
1263
1264 my $self = shift;
1265
1266 ### make sure check_install is not looking in %INC, as
1267 ### that may contain some of our sneakily loaded modules
1268 ### that aren't installed as such. -- kane
1269 local $Module::Load::Conditional::CHECK_INC_HASH = 0;
1270 my $href = check_install(
1271 module => $self->module,
1272 version => $self->version,
1273 @_,
1274 );
1275
1276 return $href->{$key} || $alt_rv;
1277 }
1278 }
1279}
1280
1281
1282
1283=pod
1284
1285=head2 $href = $self->details()
1286
1287Returns a hashref with key/value pairs offering more information about
1288a particular module. For example, for C<Time::HiRes> it might look like
1289this:
1290
1291 Author Jarkko Hietaniemi (jhi@iki.fi)
1292 Description High resolution time, sleep, and alarm
1293 Development Stage Released
1294 Installed File /usr/local/perl/lib/Time/Hires.pm
1295 Interface Style plain Functions, no references used
1296 Language Used C and perl, a C compiler will be needed
1297 Package Time-HiRes-1.65.tar.gz
1298 Public License Unknown
1299 Support Level Developer
1300 Version Installed 1.52
1301 Version on CPAN 1.65
1302
1303=cut
1304
1305sub details {
1306 my $self = shift;
1307 my $conf = $self->parent->configure_object();
1308 my $cb = $self->parent;
1309 my %hash = @_;
1310
1311 my $res = {
1312 Author => loc("%1 (%2)", $self->author->author(),
1313 $self->author->email() ),
1314 Package => $self->package,
1315 Description => $self->description || loc('None given'),
1316 'Version on CPAN' => $self->version,
1317 };
1318
1319 ### check if we have the module installed
1320 ### if so, add version have and version on cpan
1321 $res->{'Version Installed'} = $self->installed_version
1322 if $self->installed_version;
1323 $res->{'Installed File'} = $self->installed_file if $self->installed_file;
1324
1325 my $i = 0;
1326 for my $item( split '', $self->dslip ) {
1327 $res->{ $cb->_dslip_defs->[$i]->[0] } =
1328 $cb->_dslip_defs->[$i]->[1]->{$item} || loc('Unknown');
1329 $i++;
1330 }
1331
1332 return $res;
1333}
1334
1335=head2 @list = $self->contains()
1336
1337Returns a list of module objects that represent the modules also
1338present in the package of this module.
1339
1340For example, for C<Archive::Tar> this might return:
1341
1342 Archive::Tar
1343 Archive::Tar::Constant
1344 Archive::Tar::File
1345
1346=cut
1347
1348sub contains {
1349 my $self = shift;
1350 my $cb = $self->parent;
1351 my $pkg = $self->package;
5879cbe1 1352
6aaee015 1353 my @mods = $cb->search( type => 'package', allow => [qr/^$pkg$/] );
1354
1355 return @mods;
1356}
1357
1358=pod
1359
1360=head2 @list_of_hrefs = $self->fetch_report()
1361
1362This function queries the CPAN testers database at
1363I<http://testers.cpan.org/> for test results of specified module
1364objects, module names or distributions.
1365
1366Look at L<CPANPLUS::Internals::Report::_query_report()> for details on
1367the options you can pass and the return value to expect.
1368
1369=cut
1370
1371sub fetch_report {
1372 my $self = shift;
1373 my $cb = $self->parent;
1374
1375 return $cb->_query_report( @_, module => $self );
1376}
1377
1378=pod
1379
1380=head2 $bool = $self->uninstall([type => [all|man|prog])
1381
1382This function uninstalls the specified module object.
1383
1384You can install 2 types of files, either C<man> pages or C<prog>ram
1385files. Alternately you can specify C<all> to uninstall both (which
1386is the default).
1387
1388Returns true on success and false on failure.
1389
1390Do note that this does an uninstall via the so-called C<.packlist>,
1391so if you used a module installer like say, C<ports> or C<apt>, you
1392should not use this, but use your package manager instead.
1393
1394=cut
1395
1396sub uninstall {
1397 my $self = shift;
1398 my $conf = $self->parent->configure_object();
1399 my %hash = @_;
1400
1401 my ($type,$verbose);
1402 my $tmpl = {
1403 type => { default => 'all', allow => [qw|man prog all|],
1404 store => \$type },
1405 verbose => { default => $conf->get_conf('verbose'),
1406 store => \$verbose },
1407 force => { default => $conf->get_conf('force') },
1408 };
1409
1410 ### XXX add a warning here if your default install dist isn't
1411 ### makefile or build -- that means you are using a package manager
1412 ### and this will not do what you think!
1413
1414 my $args = check( $tmpl, \%hash ) or return;
1415
1416 if( $conf->get_conf('dist_type') and (
1417 ($conf->get_conf('dist_type') ne INSTALLER_BUILD) or
1418 ($conf->get_conf('dist_type') ne INSTALLER_MM))
1419 ) {
1420 msg(loc("You have a default installer type set (%1) ".
1421 "-- you should probably use that package manager to " .
1422 "uninstall modules", $conf->get_conf('dist_type')), $verbose);
1423 }
1424
1425 ### check if we even have the module installed -- no point in continuing
1426 ### otherwise
1427 unless( $self->installed_version ) {
1428 error( loc( "Module '%1' is not installed, so cannot uninstall",
1429 $self->module ) );
1430 return;
1431 }
1432
1433 ### nothing to uninstall ###
1434 my $files = $self->files( type => $type ) or return;
1435 my $dirs = $self->directory_tree( type => $type ) or return;
1436 my $sudo = $conf->get_program('sudo');
1437
1438 ### just in case there's no file; M::B doensn't provide .packlists yet ###
1439 my $pack = $self->packlist;
1440 $pack = $pack->[0]->packlist_file() if $pack;
1441
1442 ### first remove the files, then the dirs if they are empty ###
1443 my $flag = 0;
1444 for my $file( @$files, $pack ) {
1445 next unless defined $file && -f $file;
1446
1447 msg(loc("Unlinking '%1'", $file), $verbose);
1448
1449 my @cmd = ($^X, "-eunlink+q[$file]");
1450 unshift @cmd, $sudo if $sudo;
1451
1452 my $buffer;
1453 unless ( run( command => \@cmd,
1454 verbose => $verbose,
1455 buffer => \$buffer )
1456 ) {
1457 error(loc("Failed to unlink '%1': '%2'",$file, $buffer));
1458 $flag++;
1459 }
1460 }
1461
1462 for my $dir ( sort @$dirs ) {
1463 local *DIR;
4443dd53 1464 opendir DIR, $dir or next;
6aaee015 1465 my @count = readdir(DIR);
1466 close DIR;
1467
1468 next unless @count == 2; # . and ..
1469
1470 msg(loc("Removing '%1'", $dir), $verbose);
1471
1472 ### this fails on my win2k machines.. it indeed leaves the
1473 ### dir, but it's not a critical error, since the files have
1474 ### been removed. --kane
1475 #unless( rmdir $dir ) {
1476 # error( loc( "Could not remove '%1': %2", $dir, $! ) )
1477 # unless $^O eq 'MSWin32';
1478 #}
1479
4443dd53 1480 my @cmd = ($^X, "-e", "rmdir q[$dir]");
6aaee015 1481 unshift @cmd, $sudo if $sudo;
1482
1483 my $buffer;
1484 unless ( run( command => \@cmd,
1485 verbose => $verbose,
1486 buffer => \$buffer )
1487 ) {
1488 error(loc("Failed to rmdir '%1': %2",$dir,$buffer));
1489 $flag++;
1490 }
1491 }
1492
1493 $self->status->uninstall(!$flag);
1494 $self->status->installed( $flag ? 1 : undef);
1495
1496 return !$flag;
1497}
1498
1499=pod
1500
1501=head2 @modobj = $self->distributions()
1502
1503Returns a list of module objects representing all releases for this
1504module on success, false on failure.
1505
1506=cut
1507
1508sub distributions {
1509 my $self = shift;
1510 my %hash = @_;
1511
1512 my @list = $self->author->distributions( %hash, module => $self ) or return;
1513
1514 ### it's another release then by the same author ###
1515 return grep { $_->package_name eq $self->package_name } @list;
1516}
1517
1518=pod
1519
1520=head2 @list = $self->files ()
1521
1522Returns a list of files used by this module, if it is installed.
1523
6aaee015 1524=head2 @list = $self->directory_tree ()
1525
1526Returns a list of directories used by this module.
1527
6aaee015 1528=head2 @list = $self->packlist ()
1529
1530Returns the C<ExtUtils::Packlist> object for this module.
1531
6aaee015 1532=head2 @list = $self->validate ()
1533
1534Returns a list of files that are missing for this modules, but
1535are present in the .packlist file.
1536
1537=cut
1538
20afcebf 1539for my $sub (qw[files directory_tree packlist validate]) {
1540 no strict 'refs';
1541 *$sub = sub {
1542 return shift->_extutils_installed( @_, method => $sub );
1543 }
6aaee015 1544}
1545
1546### generic method to call an ExtUtils::Installed method ###
1547sub _extutils_installed {
1548 my $self = shift;
20afcebf 1549 my $cb = $self->parent;
1550 my $conf = $cb->configure_object;
1551 my $home = $cb->_home_dir; # may be needed to fix up prefixes
6aaee015 1552 my %hash = @_;
1553
1554 my ($verbose,$type,$method);
1555 my $tmpl = {
1556 verbose => { default => $conf->get_conf('verbose'),
1557 store => \$verbose, },
1558 type => { default => 'all',
1559 allow => [qw|prog man all|],
1560 store => \$type, },
1561 method => { required => 1,
1562 store => \$method,
1563 allow => [qw|files directory_tree packlist
1564 validate|],
1565 },
1566 };
1567
1568 my $args = check( $tmpl, \%hash ) or return;
1569
1570 ### old versions of cygwin + perl < 5.8 are buggy here. bail out if we
1571 ### find we're being used by them
1572 { my $err = ON_OLD_CYGWIN;
1573 if($err) { error($err); return };
1574 }
1575
1576 return unless can_load(
1577 modules => { 'ExtUtils::Installed' => '0.0' },
1578 verbose => $verbose,
1579 );
1580
20afcebf 1581 my @config_names = (
1582 ### lib
1583 { lib => 'privlib', # perl-only
1584 arch => 'archlib', # compiled code
1585 prefix => 'prefix', # prefix to both
1586 },
1587 ### site
1588 { lib => 'sitelib',
1589 arch => 'sitearch',
1590 prefix => 'siteprefix',
1591 },
1592 ### vendor
1593 { lib => 'vendorlib',
1594 arch => 'vendorarch',
1595 prefix => 'vendorprefix',
1596 },
1597 );
1598
4443dd53 1599 ### search in your regular @INC, and anything you added to your config.
1600 ### this lets EU::Installed find .packlists that are *not* in the standard
1601 ### compiled in @INC path. Requires EU::I 1.42 or up. this addresses #33438
1602 ### make sure the archname path is also added, as that's where the .packlist
1603 ### files are written
1604 my @libs;
1605 for my $lib ( @{ $conf->get_conf('lib') } ) {
1606 require Config;
20afcebf 1607
1608 ### and just the standard dir
1609 push @libs, $lib;
1610
4443dd53 1611 ### figure out what an MM prefix expands to. Basically, it's the
1612 ### site install target from %Config, ie: /opt/lib/perl5/site_perl/5.8.8
1613 ### minus the site wide prefix, ie: /opt
1614 ### this lets users add the dir they have set as their EU::MM PREFIX
1615 ### to our 'lib' config and it Just Works
20afcebf 1616 ### the arch specific dir, ie:
1617 ### /opt/lib/perl5/site_perl/5.8.8/darwin-2level
4443dd53 1618 ### XXX is this the right thing to do?
4443dd53 1619
20afcebf 1620 ### we add all 6 dir combos for prefixes:
1621 ### /foo/lib
1622 ### /foo/lib/arch
1623 ### /foo/site/lib
1624 ### /foo/site/lib/arch
1625 ### /foo/vendor/lib
1626 ### /foo/vendor/lib/arch
1627 for my $href ( @config_names ) {
1628 for my $key ( qw[lib arch] ) {
4443dd53 1629
20afcebf 1630 ### look up the config value -- use EXP for the EXPANDED
1631 ### version, so no ~ etc are found in there
1632 my $dir = $Config::Config{ $href->{ $key } .'exp' } or next;
1633 my $prefix = $Config::Config{ $href->{prefix} };
1634
1635 ### prefix may be relative to home, and contain a ~
1636 ### if so, fix it up.
1637 $prefix =~ s/^~/$home/;
1638
1639 ### remove the prefix from it, so we can append to our $lib
1640 $dir =~ s/^\Q$prefix\E//;
1641
1642 ### do the appending
1643 push @libs, File::Spec->catdir( $lib, $dir );
1644
1645 }
1646 }
4443dd53 1647 }
1648
1649 my $inst;
1650 unless( $inst = ExtUtils::Installed->new( extra_libs => \@libs ) ) {
6aaee015 1651 error( loc("Could not create an '%1' object", 'ExtUtils::Installed' ) );
1652
1653 ### in case it's being used directly... ###
1654 return;
1655 }
1656
1657
1658 { ### EU::Installed can die =/
1659 my @files;
1660 eval { @files = $inst->$method( $self->module, $type ) };
1661
1662 if( $@ ) {
1663 chomp $@;
1664 error( loc("Could not get '%1' for '%2': %3",
1665 $method, $self->module, $@ ) );
1666 return;
1667 }
1668
1669 return wantarray ? @files : \@files;
1670 }
1671}
1672
1673=head2 $bool = $self->add_to_includepath;
1674
1675Adds the current modules path to C<@INC> and C<$PERL5LIB>. This allows
4443dd53 1676you to add the module from its build dir to your path.
6aaee015 1677
4443dd53 1678You can reset C<@INC> and C<$PERL5LIB> to its original state when you
6aaee015 1679started the program, by calling:
1680
1681 $self->parent->flush('lib');
1682
1683=cut
1684
1685sub add_to_includepath {
1686 my $self = shift;
1687 my $cb = $self->parent;
1688
1689 if( my $dir = $self->status->extract ) {
1690
1691 $cb->_add_to_includepath(
1692 directories => [
1693 File::Spec->catdir(BLIB->($dir), LIB),
1694 File::Spec->catdir(BLIB->($dir), ARCH),
1695 BLIB->($dir),
1696 ]
1697 ) or return;
1698
1699 } else {
1700 error(loc( "No extract dir registered for '%1' -- can not add ".
1701 "add builddir to search path!", $self->module ));
1702 return;
1703 }
1704
1705 return 1;
1706
1707}
1708
1709=pod
1710
1711=head2 $path = $self->best_path_to_module_build();
1712
1713B<OBSOLETE>
1714
1715If a newer version of Module::Build is found in your path, it will
1716return this C<special> path. If the newest version of C<Module::Build>
1717is found in your regular C<@INC>, the method will return false. This
1718indicates you do not need to add a special directory to your C<@INC>.
1719
1720Note that this is only relevant if you're building your own
1721C<CPANPLUS::Dist::*> plugin -- the built-in dist types already have
1722this taken care of.
1723
1724=cut
1725
1726### make sure we're always running 'perl Build.PL' and friends
1727### against the highest version of module::build available
1728sub best_path_to_module_build {
1729 my $self = shift;
1730
1731 ### Since M::B will actually shell out and run the Build.PL, we must
1732 ### make sure it refinds the proper version of M::B in the path.
1733 ### that may be either in our cp::inc or in site_perl, or even a
1734 ### new M::B being installed.
1735 ### don't add anything else here, as that might screw up prereq checks
1736
1737 ### XXX this might be needed for Dist::MM too, if a makefile.pl is
1738 ### masquerading as a Build.PL
1739
1740 ### did we find the most recent module::build in our installer path?
1741
1742 ### XXX can't do changes to @INC, they're being ignored by
1743 ### new_from_context when writing a Build script. see ticket:
1744 ### #8826 Module::Build ignores changes to @INC when writing Build
1745 ### from new_from_context
1746 ### XXX applied schwern's patches (as seen on CPANPLUS::Devel 10/12/04)
1747 ### and upped the version to 0.26061 of the bundled version, and things
1748 ### work again
1749
1750 ### this functionality is now obsolete -- prereqs should be installed
1751 ### and we no longer use the CPANPLUS::inc magic.. so comment this out.
1752# require Module::Build;
1753# if( CPANPLUS::inc->path_to('Module::Build') and (
1754# CPANPLUS::inc->path_to('Module::Build') eq
1755# CPANPLUS::inc->installer_path )
1756# ) {
1757#
1758# ### if the module being installed is *not* Module::Build
1759# ### itself -- as that would undoubtedly be newer -- add
1760# ### the path to the installers to @INC
1761# ### if it IS module::build itself, add 'lib' to its path,
1762# ### as the Build.PL would do as well, but the API doesn't.
1763# ### this makes self updates possible
1764# return $self->module eq 'Module::Build'
1765# ? 'lib'
1766# : CPANPLUS::inc->installer_path;
1767# }
1768
1769 ### otherwise, the path was found through a 'normal' way of
1770 ### scanning @INC.
1771 return;
1772}
1773
1774=pod
1775
1776=head1 BUG REPORTS
1777
1778Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
1779
1780=head1 AUTHOR
1781
1782This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
1783
1784=head1 COPYRIGHT
1785
1786The CPAN++ interface (of which this module is a part of) is copyright (c)
17872001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
1788
1789This library is free software; you may redistribute and/or modify it
1790under the same terms as Perl itself.
1791
1792=cut
1793
1794# Local variables:
1795# c-indentation-style: bsd
1796# c-basic-offset: 4
1797# indent-tabs-mode: nil
1798# End:
1799# vim: expandtab shiftwidth=4:
1800
18011;
1802
1803__END__
1804
1805todo:
1806reports();