projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
ExtUtils::MakeMaker 6.54
[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
02f445e1 679 ### XXX duplicated from CPANPLUS::Selfupdate. fix somehow?
a0995fd4 680 if( $type and $type eq INSTALLER_BUILD and (
4443dd53 681 not CPANPLUS::Dist->has_dist_type( INSTALLER_BUILD )
02f445e1 682 or not $cb->module_tree( INSTALLER_BUILD )
683 ->is_uptodate( version => '0.24' )
684 ) ) {
4443dd53 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';
02f445e1 689 ### XXX duplicated from CPANPLUS::Selfupdate. fix somehow?
4443dd53 690 my $href = $self->status->configure_requires || {};
02f445e1 691 my $deps = { INSTALLER_BUILD, '0.24', %$href };
4443dd53 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
6aaee015 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
718Create a distribution object, ready to be installed.
719Distribution type defaults to your config settings
720
721The optional C<args> hashref is passed on to the specific distribution
722types' C<create> method after being dereferenced.
723
724Returns a distribution object on success, false on failure.
725
726See C<CPANPLUS::Dist> for details.
727
728=cut
729
730sub 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
6aaee015 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
4443dd53 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
20afcebf 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
4443dd53 803 : $self->status->installer_type->new( module => $self );
6aaee015 804
20afcebf 805
806 $self->status->dist_cpan( $dist_cpan );
807 }
808
6aaee015 809
810 DIST: {
8bc57f96 811 ### just wanted the $dist object?
812 last DIST if $target eq TARGET_INIT;
813
6aaee015 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
832Convenience method around C<install()> that prepares a module
833without actually building it. This is equivalent to invoking C<install>
834with C<target> set to C<prepare>
835
836Returns true on success, false on failure.
837
838=cut
839
840sub prepare {
841 my $self = shift;
842 return $self->install( @_, target => TARGET_PREPARE );
843}
844
845=head2 $bool = $mod->create( )
846
847Convenience method around C<install()> that creates a module.
848This is equivalent to invoking C<install> with C<target> set to
849C<create>
850
851Returns true on success, false on failure.
852
853=cut
854
855sub create {
856 my $self = shift;
857 return $self->install( @_, target => TARGET_CREATE );
858}
859
860=head2 $bool = $mod->test( )
861
862Convenience wrapper around C<install()> that tests a module, without
863installing it.
864It's the equivalent to invoking C<install()> with C<target> set to
865C<create> and C<skiptest> set to C<0>.
866
867Returns true on success, false on failure.
868
869=cut
870
871sub test {
872 my $self = shift;
873 return $self->install( @_, target => TARGET_CREATE, skiptest => 0 );
874}
875
876=pod
877
8bc57f96 878=head2 $bool = $self->install([ target => 'init|prepare|create|install', format => FORMAT_TYPE, extractdir => DIRECTORY, fetchdir => DIRECTORY, prefer_bin => BOOL, force => BOOL, verbose => BOOL, ..... ]);
6aaee015 879
880Installs the current module. This includes fetching it and extracting
881it, if this hasn't been done yet, as well as creating a distribution
882object for it.
883
884This means you can pass it more arguments than described above, which
885will be passed on to the relevant methods as they are called.
886
887See C<CPANPLUS::Internals::Fetch>, C<CPANPLUS::Internals::Extract> and
888C<CPANPLUS::Dist> for details.
889
890Returns true on success, false on failure.
891
892=cut
893
894sub 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,
8bc57f96 910 TARGET_INSTALL, TARGET_INIT ] },
6aaee015 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? ###
20afcebf 1018 ### XXX check status and not recheck EVERY time?
6aaee015 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
1083Returns a list of module objects the Bundle specifies.
1084
1085This requires you to have extracted the bundle already, using the
1086C<extract()> method.
1087
1088Returns false on error.
1089
1090=cut
1091
1092sub 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
6aaee015 1101 my @files;
4443dd53 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 }
6aaee015 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;
4443dd53 1135 while( local $_ = <$fh> ) {
6aaee015 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;
4443dd53 1147 my $version = $cb->_version_to_number( version => $2 );
6aaee015 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
1177Fetches the readme belonging to this module and stores it under
1178C<< $obj->status->readme >>. Returns the readme as a string on
1179success and returns false on failure.
1180
1181=cut
1182
1183sub 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
4443dd53 1222 my $in = do{ local $/; <$fh> };
6aaee015 1223 $fh->close;
1224
1225 return $self->status->readme( $in );
1226}
1227
1228=pod
1229
1230=head2 $version = $self->installed_version()
1231
1232Returns the currently installed version of this module, if any.
1233
1234=head2 $where = $self->installed_file()
1235
1236Returns the location of the currently installed file of this module,
1237if any.
1238
4443dd53 1239=head2 $dir = $self->installed_dir()
1240
1241Returns the directory (or more accurately, the C<@INC> handle) from
1242which this module was loaded, if any.
1243
6aaee015 1244=head2 $bool = $self->is_uptodate([version => VERSION_NUMBER])
1245
1246Returns 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', ''],
4443dd53 1254 installed_dir => ['dir', ''],
6aaee015 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
1294Returns a hashref with key/value pairs offering more information about
1295a particular module. For example, for C<Time::HiRes> it might look like
1296this:
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
1312sub 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
1344Returns a list of module objects that represent the modules also
1345present in the package of this module.
1346
1347For example, for C<Archive::Tar> this might return:
1348
1349 Archive::Tar
1350 Archive::Tar::Constant
1351 Archive::Tar::File
1352
1353=cut
1354
1355sub contains {
1356 my $self = shift;
1357 my $cb = $self->parent;
1358 my $pkg = $self->package;
5879cbe1 1359
6aaee015 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
1369This function queries the CPAN testers database at
1370I<http://testers.cpan.org/> for test results of specified module
1371objects, module names or distributions.
1372
1373Look at L<CPANPLUS::Internals::Report::_query_report()> for details on
1374the options you can pass and the return value to expect.
1375
1376=cut
1377
1378sub 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
1389This function uninstalls the specified module object.
1390
1391You can install 2 types of files, either C<man> pages or C<prog>ram
1392files. Alternately you can specify C<all> to uninstall both (which
1393is the default).
1394
1395Returns true on success and false on failure.
1396
1397Do note that this does an uninstall via the so-called C<.packlist>,
1398so if you used a module installer like say, C<ports> or C<apt>, you
1399should not use this, but use your package manager instead.
1400
1401=cut
1402
1403sub 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;
4443dd53 1471 opendir DIR, $dir or next;
6aaee015 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
4443dd53 1487 my @cmd = ($^X, "-e", "rmdir q[$dir]");
6aaee015 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
1510Returns a list of module objects representing all releases for this
1511module on success, false on failure.
1512
1513=cut
1514
1515sub 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
1529Returns a list of files used by this module, if it is installed.
1530
6aaee015 1531=head2 @list = $self->directory_tree ()
1532
1533Returns a list of directories used by this module.
1534
6aaee015 1535=head2 @list = $self->packlist ()
1536
1537Returns the C<ExtUtils::Packlist> object for this module.
1538
6aaee015 1539=head2 @list = $self->validate ()
1540
1541Returns a list of files that are missing for this modules, but
1542are present in the .packlist file.
1543
1544=cut
1545
20afcebf 1546for my $sub (qw[files directory_tree packlist validate]) {
1547 no strict 'refs';
1548 *$sub = sub {
1549 return shift->_extutils_installed( @_, method => $sub );
1550 }
6aaee015 1551}
1552
1553### generic method to call an ExtUtils::Installed method ###
1554sub _extutils_installed {
1555 my $self = shift;
20afcebf 1556 my $cb = $self->parent;
1557 my $conf = $cb->configure_object;
1558 my $home = $cb->_home_dir; # may be needed to fix up prefixes
6aaee015 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
20afcebf 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
4443dd53 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;
20afcebf 1614
1615 ### and just the standard dir
1616 push @libs, $lib;
1617
4443dd53 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
20afcebf 1623 ### the arch specific dir, ie:
1624 ### /opt/lib/perl5/site_perl/5.8.8/darwin-2level
4443dd53 1625 ### XXX is this the right thing to do?
4443dd53 1626
20afcebf 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] ) {
4443dd53 1636
20afcebf 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 }
4443dd53 1654 }
1655
1656 my $inst;
1657 unless( $inst = ExtUtils::Installed->new( extra_libs => \@libs ) ) {
6aaee015 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
1682Adds the current modules path to C<@INC> and C<$PERL5LIB>. This allows
4443dd53 1683you to add the module from its build dir to your path.
6aaee015 1684
4443dd53 1685You can reset C<@INC> and C<$PERL5LIB> to its original state when you
6aaee015 1686started the program, by calling:
1687
1688 $self->parent->flush('lib');
1689
1690=cut
1691
1692sub 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
1720B<OBSOLETE>
1721
1722If a newer version of Module::Build is found in your path, it will
1723return this C<special> path. If the newest version of C<Module::Build>
1724is found in your regular C<@INC>, the method will return false. This
1725indicates you do not need to add a special directory to your C<@INC>.
1726
1727Note that this is only relevant if you're building your own
1728C<CPANPLUS::Dist::*> plugin -- the built-in dist types already have
1729this 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
1735sub 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
1785Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
1786
1787=head1 AUTHOR
1788
1789This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
1790
1791=head1 COPYRIGHT
1792
1793The CPAN++ interface (of which this module is a part of) is copyright (c)
17942001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
1795
1796This library is free software; you may redistribute and/or modify it
1797under 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
18081;
1809
1810__END__
1811
1812todo:
1813reports();
Unnamed repository; edit this file to name it for gitweb.