File Coverage

lib/CPANPLUS/Module.pm
Criterion Covered Total %
statement 317 465 68.1
branch 133 240 55.4
condition 46 85 54.1
subroutine 47 54 87.0
pod 29 29 100.0
total 572 873 65.5


line stmt bran cond sub pod time code
1             package CPANPLUS::Module;
2              
3 20     20   171 use strict;
  20         42  
  20         766  
4 20     20   121 use vars qw[@ISA $VERSION];
  20         56  
  20         1362  
5             $VERSION = "0.9910";
6              
7 20     20   7563 use CPANPLUS::Dist;
  20         62  
  20         592  
8 20     20   143 use CPANPLUS::Error;
  20         43  
  20         1126  
9 20     20   7807 use CPANPLUS::Module::Signature;
  20         56  
  20         634  
10 20     20   7385 use CPANPLUS::Module::Checksums;
  20         63  
  20         652  
11 20     20   135 use CPANPLUS::Internals::Constants;
  20         41  
  20         6642  
12              
13 20     20   164 use FileHandle;
  20         70  
  20         88  
14              
15 20     20   5667 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
  20         42  
  20         89  
16 20     20   5209 use IPC::Cmd qw[can_run run];
  20         39  
  20         1300  
17 20     20   136 use File::Find qw[find];
  20         39  
  20         975  
18 20     20   123 use Params::Check qw[check];
  20         39  
  20         862  
19 20     20   121 use File::Basename qw[dirname];
  20         44  
  20         1486  
20 20     20   160 use Module::Load::Conditional qw[can_load check_install];
  20         54  
  20         3717  
21              
22             $Params::Check::VERBOSE = 1;
23              
24             @ISA = qw[ CPANPLUS::Module::Signature CPANPLUS::Module::Checksums];
25              
26             =pod
27              
28             =head1 NAME
29              
30             CPANPLUS::Module - CPAN module objects for CPANPLUS
31              
32             =head1 SYNOPSIS
33              
34             ### get a module object from the CPANPLUS::Backend object
35             my $mod = $cb->module_tree('Some::Module');
36              
37             ### accessors
38             $mod->version;
39             $mod->package;
40              
41             ### methods
42             $mod->fetch;
43             $mod->extract;
44             $mod->install;
45              
46              
47             =head1 DESCRIPTION
48              
49             C creates objects from the information in the
50             source files. These can then be used to query and perform actions
51             on, like fetching or installing.
52              
53             These objects should only be created internally. For C objects,
54             there's the C class. To obtain a module object
55             consult the C documentation.
56              
57             =cut
58              
59             my $tmpl = {
60             module => { default => '', required => 1 }, # full module name
61             version => { default => '0.0' }, # version number
62             path => { default => '', required => 1 }, # extended path on the
63             # cpan mirror, like
64             # /author/id/K/KA/KANE
65             comment => { default => ''}, # comment on module
66             package => { default => '', required => 1 }, # package name, like
67             # 'bar-baz-1.03.tgz'
68             description => { default => '' }, # description of the
69             # module
70             dslip => { default => EMPTY_DSLIP }, # dslip information
71             _id => { required => 1 }, # id of the Internals
72             # parent object
73             _status => { no_override => 1 }, # stores status object
74             author => { default => '', required => 1,
75             allow => IS_AUTHOBJ }, # module author
76             mtime => { default => '' },
77             };
78              
79             ### some of these will be resolved by wrapper functions that
80             ### do Clever Things to find the actual value, so don't create
81             ### an autogenerated sub for that just here, take an alternate
82             ### name to allow for a wrapper
83             { my %rename = (
84             dslip => '_dslip'
85             );
86              
87             ### autogenerate accessors ###
88             for my $key ( keys %$tmpl ) {
89 20     20   174 no strict 'refs';
  20         50  
  20         11320  
90              
91             my $sub = $rename{$key} || $key;
92              
93             *{__PACKAGE__."::$sub"} = sub {
94 6452 100   6452   61202 $_[0]->{$key} = $_[1] if @_ > 1;
95 6452         40155 return $_[0]->{$key};
96             }
97             }
98             }
99              
100              
101             =pod
102              
103             =head1 CLASS METHODS
104              
105             =head2 accessors ()
106              
107             Returns a list of all accessor methods to the object
108              
109             =cut
110              
111             ### *name is an alias, include it explicitly
112 265     265 1 4500 sub accessors { return ('name', keys %$tmpl) };
113              
114             =head1 ACCESSORS
115              
116             An objects of this class has the following accessors:
117              
118             =over 4
119              
120             =item name
121              
122             Name of the module.
123              
124             =item module
125              
126             Name of the module.
127              
128             =item version
129              
130             Version of the module. Defaults to '0.0' if none was provided.
131              
132             =item path
133              
134             Extended path on the mirror.
135              
136             =item comment
137              
138             Any comment about the module -- largely unused.
139              
140             =item package
141              
142             The name of the package.
143              
144             =item description
145              
146             Description of the module -- only registered modules have this.
147              
148             =item dslip
149              
150             The five character dslip string, that represents meta-data of the
151             module -- again, only registered modules have this.
152              
153             =cut
154              
155             sub dslip {
156 64     64 1 2443 my $self = shift;
157              
158             ### if this module has relevant dslip info, return it
159 64 50       247 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 64         440 for my $mod ( $self->contains ) {
164 313 50       636 return $mod->_dslip if $mod->_dslip ne EMPTY_DSLIP;
165             }
166              
167             ### ok, really no dslip info found, return the default
168 64         410 return EMPTY_DSLIP;
169             }
170              
171              
172             =pod
173              
174             =item status
175              
176             The C object associated with this object.
177             (see below).
178              
179             =item author
180              
181             The C object associated with this object.
182              
183             =item parent
184              
185             The C object that spawned this module object.
186              
187             =back
188              
189             =cut
190              
191             ### Alias ->name to ->module, for human beings.
192             *name = *module;
193              
194             sub parent {
195 809     809 1 9233 my $self = shift;
196 809         2970 my $obj = CPANPLUS::Internals->_retrieve_id( $self->_id );
197              
198 809         3930 return $obj;
199             }
200              
201             =head1 STATUS ACCESSORS
202              
203             C caches a lot of results from method calls and saves data
204             it collected along the road for later reuse.
205              
206             C uses this internally, but it is also available for the end
207             user. You can get a status object by calling:
208              
209             $modobj->status
210              
211             You can then query the object as follows:
212              
213             =over 4
214              
215             =item installer_type
216              
217             The installer type used for this distribution. Will be one of
218             'makemaker' or 'build'. This determines whether C
219             or C will be used to build this distribution.
220              
221             =item dist_cpan
222              
223             The dist object used to do the CPAN-side of the installation. Either
224             a C or C object.
225              
226             =item dist
227              
228             The custom dist object used to do the operating specific side of the
229             installation, if you've chosen to use this. For example, if you've
230             chosen to install using the C format, this may be a
231             C object.
232              
233             Undefined if you didn't specify a separate format to install through.
234              
235             =item prereqs | requires
236              
237             A hashref of prereqs this distribution was found to have. Will look
238             something like this:
239              
240             { Carp => 0.01, strict => 0 }
241              
242             Might be undefined if the distribution didn't have any prerequisites.
243              
244             =item configure_requires
245              
246             Like prereqs, but these are necessary to be installed before the
247             build process can even begin.
248              
249             =item signature
250              
251             Flag indicating, if a signature check was done, whether it was OK or
252             not.
253              
254             =item extract
255              
256             The directory this distribution was extracted to.
257              
258             =item fetch
259              
260             The location this distribution was fetched to.
261              
262             =item readme
263              
264             The text of this distributions README file.
265              
266             =item uninstall
267              
268             Flag indicating if an uninstall call was done successfully.
269              
270             =item created
271              
272             Flag indicating if the C call to your dist object was done
273             successfully.
274              
275             =item installed
276              
277             Flag indicating if the C call to your dist object was done
278             successfully.
279              
280             =item checksums
281              
282             The location of this distributions CHECKSUMS file.
283              
284             =item checksum_ok
285              
286             Flag indicating if the checksums check was done successfully.
287              
288             =item checksum_value
289              
290             The checksum value this distribution is expected to have
291              
292             =back
293              
294             =head1 METHODS
295              
296             =head2 $self = CPANPLUS::Module->new( OPTIONS )
297              
298             This method returns a C object. Normal users
299             should never call this method directly, but instead use the
300             C to obtain module objects.
301              
302             This example illustrates a C call with all required arguments:
303              
304             CPANPLUS::Module->new(
305             module => 'Foo',
306             path => 'authors/id/A/AA/AAA',
307             package => 'Foo-1.0.tgz',
308             author => $author_object,
309             _id => INTERNALS_OBJECT_ID,
310             );
311              
312             Every accessor is also a valid option to pass to C.
313              
314             Returns a module object on success and false on failure.
315              
316             =cut
317              
318              
319             sub new {
320 457     457 1 3482 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 457         1040 local $Params::Check::SANITY_CHECK_TEMPLATE = 0;
325              
326 457 50       1750 my $object = check( $tmpl, \%hash ) or return;
327              
328 457         32563 bless $object, $class;
329              
330 457         2272 return $object;
331             }
332              
333             ### only create status objects when they're actually asked for
334             sub status {
335 1084     1084 1 33756 my $self = shift;
336 1084 100       4154 return $self->_status if $self->_status;
337              
338 125         966 my $acc = Object::Accessor->new;
339 125         2139 $acc->mk_accessors( qw[ installer_type dist_cpan dist prereqs
340             signature extract fetch readme uninstall
341             created installed prepared checksums files
342             checksum_ok checksum_value _fetch_from
343             configure_requires
344             ] );
345              
346             ### create an alias from 'requires' to 'prereqs', so it's more in
347             ### line with 'configure_requires';
348 125         27864 $acc->mk_aliases( requires => 'prereqs' );
349              
350 125         4528 $self->_status( $acc );
351              
352 125         353 return $self->_status;
353             }
354              
355              
356             ### flush the cache of this object ###
357             sub _flush {
358 20     20   28 my $self = shift;
359 20         41 $self->status->mk_flush;
360 20         1083 return 1;
361             }
362              
363             =head2 $mod->package_name( [$package_string] )
364              
365             Returns the name of the package a module is in. For C
366             that might be C.
367              
368             =head2 $mod->package_version( [$package_string] )
369              
370             Returns the version of the package a module is in. For a module
371             in the package C this would be C<1.1>.
372              
373             =head2 $mod->package_extension( [$package_string] )
374              
375             Returns the suffix added by the compression method of a package a
376             certain module is in. For a module in C, this
377             would be C.
378              
379             =head2 $mod->package_is_perl_core
380              
381             Returns a boolean indicating of the package a particular module is in,
382             is actually a core perl distribution.
383              
384             =head2 $mod->module_is_supplied_with_perl_core( [version => $]] )
385              
386             Returns a boolean indicating whether C of this module
387             was supplied with the current running perl's core package.
388              
389             =head2 $mod->is_bundle
390              
391             Returns a boolean indicating if the module you are looking at, is
392             actually a bundle. Bundles are identified as modules whose name starts
393             with C.
394              
395             =head2 $mod->is_autobundle;
396              
397             Returns a boolean indicating if the module you are looking at, is
398             actually an autobundle as generated by C<< $cb->autobundle >>.
399              
400             =head2 $mod->is_third_party
401              
402             Returns a boolean indicating whether the package is a known third-party
403             module (i.e. it's not provided by the standard Perl distribution and
404             is not available on the CPAN, but on a third party software provider).
405             See L for more details.
406              
407             =head2 $mod->third_party_information
408              
409             Returns a reference to a hash with more information about a third-party
410             module. See the documentation about C in
411             L 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 20     20   179 no strict 'refs';
  20         56  
  20         71262  
426             *$name = sub {
427 316     316   19899 my $self = shift;
428 316   66     1734 my $val = shift || $self->package;
429 316         1200 my @res = $self->parent->_split_package_string( package => $val );
430              
431             ### return the corresponding index from the result
432 316 100       2636 return $res[$index] if @res;
433 4         26 return;
434             };
435             }
436              
437             sub package_is_perl_core {
438 31     31 1 1803 my $self = shift;
439 31         112 my $cb = $self->parent;
440              
441             ### check if the package looks like a perl core package
442 31 100       155 return 1 if $self->package_name eq PERL_CORE;
443              
444             ### address #44562: ::Module->package_is_perl_code : problem comparing
445             ### version strings -- use $cb->_vcmp to avoid warnings when version
446             ### have _ in them
447              
448 27         189 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 27 50       94 if (defined $core) {
451             ### if the package is newer than installed, then it's dual-lifed
452 0 0       0 return if $cb->_vcmp($self->version, $self->installed_version) > 0;
453              
454             ### if the package is newer or equal to the corelist,
455             ### then it's dual-lifed
456 0 0       0 return if $cb->_vcmp( $self->version, $core ) >= 0;
457              
458             ### otherwise, it's older than corelist, thus unsuitable.
459 0         0 return 1;
460             }
461              
462             ### not in corelist, not a perl core package.
463 27         315 return;
464             }
465              
466             sub module_is_supplied_with_perl_core {
467 32     32 1 109 my $self = shift;
468 32   33     424 my $ver = shift || $];
469              
470             ### allow it to be called as a package function as well like:
471             ### CPANPLUS::Module::module_is_supplied_with_perl_core('Config')
472             ### so that we can check the status of modules that aren't released
473             ### to CPAN, but are part of the core.
474 32 100       255 my $name = ref $self ? $self->module : $self;
475              
476             ### check Module::CoreList to see if it's a core package
477 32         13184 require Module::CoreList;
478              
479             ### Address #41157: Module::module_is_supplied_with_perl_core()
480             ### broken for perl 5.10: Module::CoreList's version key for the
481             ### hash has a different number of trailing zero than $] aka
482             ### $PERL_VERSION.
483              
484 32         429138 my $core;
485              
486 32 100       527 if ( exists $Module::CoreList::version{ 0+$ver }->{ $name } ) {
487 4         80 $core = $Module::CoreList::version{ 0+$ver }->{ $name };
488 4 50       66 $core = 0 unless $core;
489             }
490 32         133 return $core;
491             }
492              
493             ### make sure Bundle-Foo also gets flagged as bundle
494             sub is_bundle {
495 22     22 1 1600 my $self = shift;
496              
497             ### cpan'd bundle
498 22 100       80 return 1 if $self->module =~ /^bundle(?:-|::)/i;
499              
500             ### autobundle
501 20 100       98 return 1 if $self->is_autobundle;
502              
503             ### neither
504 16         66 return;
505             }
506              
507             ### full path to a generated autobundle
508             sub is_autobundle {
509 60     60 1 199 my $self = shift;
510 60         231 my $conf = $self->parent->configure_object;
511 60         667 my $prefix = $conf->_get_build('autobundle_prefix');
512              
513 60 100       363 return 1 if $self->module eq $prefix;
514 50         279 return;
515             }
516              
517             sub is_third_party {
518 44     44 1 609 my $self = shift;
519              
520 44 50       472 return unless can_load( modules => { 'Module::ThirdParty' => 0 } );
521              
522 0         0 return Module::ThirdParty::is_3rd_party( $self->name );
523             }
524              
525             sub third_party_information {
526 0     0 1 0 my $self = shift;
527              
528 0 0       0 return unless $self->is_third_party;
529              
530 0         0 return Module::ThirdParty::module_information( $self->name );
531             }
532             }
533              
534             =pod
535              
536             =head2 $clone = $self->clone
537              
538             Clones the current module object for tinkering with.
539             It will have a clean C object, as well as
540             a fake C object.
541              
542             =cut
543              
544             { ### accessors don't change during run time, so only compute once
545             my @acc = grep !/status/, __PACKAGE__->accessors();
546              
547             sub clone {
548 45     45 1 6318 my $self = shift;
549              
550             ### clone the object ###
551 45         221 my %data = map { $_ => $self->$_ } @acc;
  495         2027  
552              
553 45         814 my $obj = CPANPLUS::Module::Fake->new( %data );
554              
555 45         247 return $obj;
556             }
557             }
558              
559             =pod
560              
561             =head2 $where = $self->fetch
562              
563             Fetches the module from a CPAN mirror.
564             Look at L for details on the
565             options you can pass.
566              
567             =cut
568              
569             sub fetch {
570 54     54 1 5515 my $self = shift;
571 54         327 my $cb = $self->parent;
572              
573             ### custom args
574 54         331 my %args = ( module => $self );
575              
576             ### if a custom fetch location got specified before, add that here
577 54 100       204 $args{fetch_from} = $self->status->_fetch_from
578             if $self->status->_fetch_from;
579              
580 54 50       5547 my $where = $cb->_fetch( @_, %args ) or return;
581              
582             ### do an md5 check ###
583 54 100 100     532 if( !$self->status->_fetch_from and
      100        
584             $cb->configure_object->get_conf('md5') and
585             $self->package ne CHECKSUMS
586             ) {
587 16 50       580 unless( $self->_validate_checksum ) {
588 0         0 error( loc( "Checksum error for '%1' -- will not trust package",
589             $self->package) );
590 0         0 return;
591             }
592             }
593              
594 54         3140 return $where;
595             }
596              
597             =pod
598              
599             =head2 $path = $self->extract
600              
601             Extracts the fetched module.
602             Look at L for details on
603             the options you can pass.
604              
605             =cut
606              
607             sub extract {
608 17     17 1 3190 my $self = shift;
609 17         88 my $cb = $self->parent;
610              
611 17 100       77 unless( $self->status->fetch ) {
612 1         91 error( loc( "You have not fetched '%1' yet -- cannot extract",
613             $self->module) );
614 1         13 return;
615             }
616              
617             ### can't extract these, so just use the basedir for the file
618 16 100       1553 if( $self->is_autobundle ) {
619              
620             ### this is expected to be set after an extract call
621 1         18 $self->get_installer_type;
622              
623 1         103 return $self->status->extract( dirname( $self->status->fetch ) );
624             }
625              
626 15         468 return $cb->_extract( @_, module => $self );
627             }
628              
629             =head2 $type = $self->get_installer_type([prefer_makefile => BOOL])
630              
631             Gets the installer type for this module. This may either be C or
632             C. If C is unavailable or no installer type
633             is available, it will fall back to C. If both are available,
634             it will pick the one indicated by your config, or by the
635             C option you can pass to this function.
636              
637             Returns the installer type on success, and false on error.
638              
639             =cut
640              
641             sub get_installer_type {
642 20     20 1 988 my $self = shift;
643 20         117 my $cb = $self->parent;
644 20         371 my $conf = $cb->configure_object;
645 20         70 my %hash = @_;
646              
647 20         60 my ($prefer_makefile,$verbose);
648 20         536 my $tmpl = {
649             prefer_makefile => { default => $conf->get_conf('prefer_makefile'),
650             store => \$prefer_makefile, allow => BOOLEANS },
651             verbose => { default => $conf->get_conf('verbose'),
652             store => \$verbose },
653             };
654              
655 20 50       145 check( $tmpl, \%hash ) or return;
656              
657 20         1769 my $type;
658              
659             ### autobundles use their own installer, so return that
660 20 100       164 if( $self->is_autobundle ) {
661 2         23 $type = INSTALLER_AUTOBUNDLE;
662              
663             } else {
664 18         82 my $extract = $self->status->extract();
665 18 50       1502 unless( $extract ) {
666 0         0 error(loc(
667             "Cannot determine installer type of unextracted module '%1'",
668             $self->module
669             ));
670 0         0 return;
671             }
672              
673             ### check if it's a makemaker or a module::build type dist ###
674 18         281 my $found_build = -e BUILD_PL->( $extract );
675 18         164 my $found_makefile = -e MAKEFILE_PL->( $extract );
676              
677 18 100 66     289 $type = INSTALLER_BUILD if !$prefer_makefile && $found_build;
678 18 100 66     91 $type = INSTALLER_BUILD if $found_build && !$found_makefile;
679 18 100 100     310 $type = INSTALLER_MM if $prefer_makefile && $found_makefile;
680 18 100 66     188 $type = INSTALLER_MM if $found_makefile && !$found_build;
681             # Special case Module::Build to always use INSTALLER_MM
682 18 50       105 $type = INSTALLER_MM if $self->package =~ m{^Module-Build-\d};
683              
684             }
685              
686             ### ok, so it's a 'build' installer, but you don't /have/ module build
687             ### XXX duplicated from CPANPLUS::Selfupdate. fix somehow?
688 20 100 100     418 if( $type and $type eq INSTALLER_BUILD and (
    100 33        
      66        
689             not CPANPLUS::Dist->has_dist_type( INSTALLER_BUILD )
690             or not $cb->module_tree( INSTALLER_BUILD )
691             ->is_uptodate( version => '0.60' )
692             ) ) {
693              
694             ### XXX this is for recording purposes only. We *have* to install
695             ### these before even creating a dist object, or we'll get an error
696             ### saying 'no such dist type';
697             ### XXX duplicated from CPANPLUS::Selfupdate. fix somehow?
698 1   50     11 my $href = $self->status->configure_requires || {};
699 1         86 my $deps = { INSTALLER_BUILD, '0.60', %$href };
700              
701 1         8 $self->status->configure_requires( $deps );
702              
703 1         117 msg(loc("This module requires '%1' and '%2' to be installed first. ".
704             "Adding these modules to your prerequisites list",
705             'Module::Build', INSTALLER_BUILD
706             ), $verbose );
707              
708              
709             ### ok, actually we found neither ###
710             } elsif ( !$type ) {
711 1         7 error( loc( "Unable to find '%1' or '%2' for '%3'; ".
712             "Will default to '%4' but might be unable ".
713             "to install!", BUILD_PL->(), MAKEFILE_PL->(),
714             $self->module, INSTALLER_MM ) );
715 1         12 $type = INSTALLER_MM;
716             }
717              
718 20 50       153 return $self->status->installer_type( $type ) if $type;
719 0         0 return;
720             }
721              
722             =pod
723              
724             =head2 $dist = $self->dist([target => 'prepare|create', format => DISTRIBUTION_TYPE, args => {key => val}]);
725              
726             Create a distribution object, ready to be installed.
727             Distribution type defaults to your config settings
728              
729             The optional C hashref is passed on to the specific distribution
730             types' C method after being dereferenced.
731              
732             Returns a distribution object on success, false on failure.
733              
734             See C for details.
735              
736             =cut
737              
738             sub dist {
739 19     19 1 1223 my $self = shift;
740 19         79 my $cb = $self->parent;
741 19         86 my $conf = $cb->configure_object;
742 19         289 my %hash = @_;
743              
744             ### have you determined your installer type yet? if not, do it here,
745             ### we need the info
746 19 50       96 $self->get_installer_type unless $self->status->installer_type;
747              
748 19         1646 my($type,$args,$target);
749 19   33     155 my $tmpl = {
750             format => { default => $conf->get_conf('dist_type') ||
751             $self->status->installer_type,
752             store => \$type },
753             target => { default => TARGET_CREATE, store => \$target },
754             args => { default => {}, store => \$args },
755             };
756              
757 19 50       1965 check( $tmpl, \%hash ) or return;
758              
759             ### ok, check for $type. Do we have it?
760 19 100       3031 unless( CPANPLUS::Dist->has_dist_type( $type ) ) {
761              
762             ### ok, we don't have it. Is it C::D::Build? if so we can install the
763             ### whole thing now
764             ### XXX we _could_ do this for any type we don't have actually...
765 1 50       4 if( $type eq INSTALLER_BUILD ) {
766 1         4 msg(loc("Bootstrapping installer '%1'", $type));
767              
768             ### don't propagate the format, it's the one we're trying to
769             ### bootstrap, so it'll be an infinite loop if we do
770              
771             $cb->module_tree( $type )->install( target => $target, %$args ) or
772 1 50       13 do {
773 0         0 error(loc("Could not bootstrap installer '%1' -- ".
774             "can not continue", $type));
775 0         0 return;
776             };
777              
778             ### re-scan for available modules now
779 1         21 CPANPLUS::Dist->rescan_dist_types;
780              
781 1 50       5 unless( CPANPLUS::Dist->has_dist_type( $type ) ) {
782 0         0 error(loc("Newly installed installer type '%1' should be ".
783             "available, but is not! -- aborting", $type));
784 0         0 return;
785             } else {
786 1         9 msg(loc("Installer '%1' successfully bootstrapped", $type));
787             }
788              
789             ### some other plugin you don't have. Abort
790             } else {
791 0         0 error(loc("Installer type '%1' not found. Please verify your ".
792             "installation -- aborting", $type ));
793 0         0 return;
794             }
795             }
796              
797             ### make sure we don't overwrite it, just in case we came
798             ### back from a ->save_state. This allows restoration to
799             ### work correctly
800 19         78 my( $dist, $dist_cpan );
801              
802 19 100       78 unless( $dist = $self->status->dist ) {
803 14 50       1851 $dist = $type->new( module => $self ) or return;
804 13         78 $self->status->dist( $dist );
805             }
806              
807 18 100       1732 unless( $dist_cpan = $self->status->dist_cpan ) {
808              
809 13 100       1091 $dist_cpan = $type eq $self->status->installer_type
810             ? $self->status->dist
811             : $self->status->installer_type->new( module => $self );
812              
813              
814 13         422 $self->status->dist_cpan( $dist_cpan );
815             }
816              
817              
818             DIST: {
819             ### just wanted the $dist object?
820 18 100       1513 last DIST if $target eq TARGET_INIT;
  18         85  
821              
822             ### first prepare the dist
823 17 100       224 $dist->prepare( %$args ) or return;
824 16         3419 $self->status->prepared(1);
825              
826             ### you just wanted us to prepare?
827 16 100       1446 last DIST if $target eq TARGET_PREPARE;
828              
829 14 100       201 $dist->create( %$args ) or return;
830 13         2678 $self->status->created(1);
831             }
832              
833 16         1664 return $dist;
834             }
835              
836             =pod
837              
838             =head2 $bool = $mod->prepare( )
839              
840             Convenience method around C that prepares a module
841             without actually building it. This is equivalent to invoking C
842             with C set to C
843              
844             Returns true on success, false on failure.
845              
846             =cut
847              
848             sub prepare {
849 2     2 1 2606 my $self = shift;
850 2         42 return $self->install( @_, target => TARGET_PREPARE );
851             }
852              
853             =head2 $bool = $mod->create( )
854              
855             Convenience method around C that creates a module.
856             This is equivalent to invoking C with C set to
857             C
858              
859             Returns true on success, false on failure.
860              
861             =cut
862              
863             sub create {
864 3     3 1 3083 my $self = shift;
865 3         68 return $self->install( @_, target => TARGET_CREATE );
866             }
867              
868             =head2 $bool = $mod->test( )
869              
870             Convenience wrapper around C that tests a module, without
871             installing it.
872             It's the equivalent to invoking C with C set to
873             C and C set to C<0>.
874              
875             Returns true on success, false on failure.
876              
877             =cut
878              
879             sub test {
880 1     1 1 915 my $self = shift;
881 1         14 return $self->install( @_, target => TARGET_CREATE, skiptest => 0 );
882             }
883              
884             =pod
885              
886             =head2 $bool = $self->install([ target => 'init|prepare|create|install', format => FORMAT_TYPE, extractdir => DIRECTORY, fetchdir => DIRECTORY, prefer_bin => BOOL, force => BOOL, verbose => BOOL, ..... ]);
887              
888             Installs the current module. This includes fetching it and extracting
889             it, if this hasn't been done yet, as well as creating a distribution
890             object for it.
891              
892             This means you can pass it more arguments than described above, which
893             will be passed on to the relevant methods as they are called.
894              
895             See C, C and
896             C for details.
897              
898             Returns true on success, false on failure.
899              
900             =cut
901              
902             sub install {
903 17     17 1 421 my $self = shift;
904 17         91 my $cb = $self->parent;
905 17         135 my $conf = $cb->configure_object;
906 17         239 my %hash = @_;
907              
908 17         95 my $args; my $target; my $format;
  17         0  
909             { ### so we can use the rest of the args to the create calls etc ###
910 17         47 local $Params::Check::NO_DUPLICATES = 1;
  17         113  
911 17         135 local $Params::Check::ALLOW_UNKNOWN = 1;
912              
913             ### targets 'dist' and 'test' are now completely ignored ###
914 17         502 my $tmpl = {
915             ### match this allow list with Dist->_resolve_prereqs
916             target => { default => TARGET_INSTALL, store => \$target,
917             allow => [TARGET_PREPARE, TARGET_CREATE,
918             TARGET_INSTALL, TARGET_INIT ] },
919             force => { default => $conf->get_conf('force'), },
920             verbose => { default => $conf->get_conf('verbose'), },
921             format => { default => $conf->get_conf('dist_type'),
922             store => \$format },
923             };
924              
925 17 50       134 $args = check( $tmpl, \%hash ) or return;
926             }
927              
928              
929             ### if this target isn't 'install', we will need to at least 'create'
930             ### every prereq, so it can build
931             ### XXX prereq_target of 'prepare' will do weird things here, and is
932             ### not supported.
933 17 100 100     3752 $args->{'prereq_target'} ||= TARGET_CREATE if $target ne TARGET_INSTALL;
934              
935             ### check if it's already uptodate ###
936 17 0 100     198 if( $target eq TARGET_INSTALL and !$args->{'force'} and
      66        
      0        
      33        
      0        
937             !$self->package_is_perl_core() and # separate rules apply
938             ( $self->status->installed() or $self->is_uptodate ) and
939             !INSTALL_VIA_PACKAGE_MANAGER->($format)
940             ) {
941             msg(loc("Module '%1' already up to date, won't install without force",
942 0         0 $self->module), $args->{'verbose'} );
943 0         0 return $self->status->installed(1);
944             }
945              
946             # if it's a non-installable core package, abort the install.
947 17 100       133 if( $self->package_is_perl_core() ) {
    50          
948             # if the installed is newer, say so.
949 1 50       18 if( $self->installed_version > $self->version ) {
    0          
950 1         20 error(loc("The core Perl %1 module '%2' (%3) is more ".
951             "recent than the latest release on CPAN (%4). ".
952             "Aborting install.",
953             $], $self->module, $self->installed_version,
954             $self->version ) );
955             # if the installed matches, say so.
956             } elsif( $self->installed_version == $self->version ) {
957 0         0 error(loc("The core Perl %1 module '%2' (%3) can only ".
958             "be installed by Perl itself. ".
959             "Aborting install.",
960             $], $self->module, $self->installed_version ) );
961             # otherwise, the installed is older; say so.
962             } else {
963 0         0 error(loc("The core Perl %1 module '%2' can only be ".
964             "upgraded from %3 to %4 by Perl itself (%5). ".
965             "Aborting install.",
966             $], $self->module, $self->installed_version,
967             $self->version, $self->package ) );
968             }
969 1         34 return;
970              
971             ### it might be a known 3rd party module
972             } elsif ( $self->is_third_party ) {
973 0         0 my $info = $self->third_party_information;
974             error(loc(
975             "%1 is a known third-party module.\n\n".
976             "As it isn't available on the CPAN, CPANPLUS can't install " .
977             "it automatically. Therefore you need to install it manually " .
978             "before proceeding.\n\n".
979             "%2 is part of %3, published by %4, and should be available ".
980             "for download at the following address:\n\t%5",
981             $self->name, $self->name, $info->{name}, $info->{author},
982             $info->{url}
983 0         0 ));
984              
985 0         0 return;
986             }
987              
988             ### fetch it if need be ###
989 16 100       6165 unless( $self->status->fetch ) {
990 9         869 my $params;
991 9         42 for (qw[prefer_bin fetchdir]) {
992 18 50       63 $params->{$_} = $args->{$_} if exists $args->{$_};
993             }
994 9         29 for (qw[force verbose]) {
995 18 50       83 $params->{$_} = $args->{$_} if defined $args->{$_};
996             }
997 9 50       129 $self->fetch( %$params ) or return;
998             }
999              
1000             ### extract it if need be ###
1001 16 100       886 unless( $self->status->extract ) {
1002 10         1032 my $params;
1003 10         74 for (qw[prefer_bin extractdir]) {
1004 20 50       133 $params->{$_} = $args->{$_} if exists $args->{$_};
1005             }
1006 10         38 for (qw[force verbose]) {
1007 20 50       94 $params->{$_} = $args->{$_} if defined $args->{$_};
1008             }
1009 10 50       117 $self->extract( %$params ) or return;
1010             }
1011              
1012 16 100       2837 $args->{'prereq_format'} = $format if $format;
1013 16   66     223 $format ||= $self->status->installer_type;
1014              
1015 16 50       689 unless( $format ) {
1016 0         0 error( loc( "Don't know what installer to use; " .
1017             "Couldn't find either '%1' or '%2' in the extraction " .
1018             "directory '%3' -- will be unable to install",
1019             BUILD_PL->(), MAKEFILE_PL->(), $self->status->extract ) );
1020              
1021 0         0 $self->status->installed(0);
1022 0         0 return;
1023             }
1024              
1025              
1026             ### do SIGNATURE checks? ###
1027             ### XXX check status and not recheck EVERY time?
1028 16 50       186 if( $conf->get_conf('signature') ) {
1029 0 0       0 unless( $self->check_signature( verbose => $args->{verbose} ) ) {
1030 0         0 error( loc( "Signature check failed for module '%1' ".
1031             "-- Not trusting this module, aborting install",
1032             $self->module ) );
1033 0         0 $self->status->signature(0);
1034              
1035             ### send out test report on broken sig
1036 0 0       0 if( $conf->get_conf('cpantest') ) {
1037             $cb->_send_report(
1038             module => $self,
1039             failed => 1,
1040             buffer => CPANPLUS::Error->stack_as_string,
1041             verbose => $args->{verbose},
1042             force => $args->{force},
1043 0 0       0 ) or error(loc("Failed to send test report for '%1'",
1044             $self->module ) );
1045             }
1046              
1047 0         0 return;
1048              
1049             } else {
1050             ### signature OK ###
1051 0         0 $self->status->signature(1);
1052             }
1053             }
1054              
1055             ### a target of 'create' basically means not to run make test ###
1056             ### eh, no it /doesn't/.. skiptest => 1 means skiptest => 1.
1057             #$args->{'skiptest'} = 1 if $target eq 'create';
1058              
1059             ### bundle rules apply ###
1060 16 100       130 if( $self->is_bundle ) {
1061             ### check what we need to install ###
1062 1         5 my @prereqs = $self->bundle_modules();
1063 1 50       18 unless( @prereqs ) {
1064 0         0 error( loc( "Bundle '%1' does not specify any modules to install",
1065             $self->module ) );
1066              
1067             ### XXX mark an error here? ###
1068             }
1069             }
1070              
1071 16         213 my $dist = $self->dist( format => $format,
1072             target => $target,
1073             args => $args );
1074 15 100       510 unless( $dist ) {
1075 2         8 error( loc( "Unable to create a new distribution object for '%1' " .
1076             "-- cannot continue", $self->module ) );
1077 2         81 return;
1078             }
1079              
1080 13 100       329 return 1 if $target ne TARGET_INSTALL;
1081              
1082 5 100       90 my $ok = $dist->install( %$args ) ? 1 : 0;
1083              
1084 5         1740 $self->status->installed($ok);
1085              
1086 5 100       601 return 1 if $ok;
1087 1         22 return;
1088             }
1089              
1090             =pod
1091              
1092             =head2 @list = $self->bundle_modules()
1093              
1094             Returns a list of module objects the Bundle specifies.
1095              
1096             This requires you to have extracted the bundle already, using the
1097             C method.
1098              
1099             Returns false on error.
1100              
1101             =cut
1102              
1103             sub bundle_modules {
1104 3     3 1 2385 my $self = shift;
1105 3         44 my $cb = $self->parent;
1106              
1107 3 50       31 unless( $self->is_bundle ) {
1108 0         0 error( loc("'%1' is not a bundle", $self->module ) );
1109 0         0 return;
1110             }
1111              
1112 3         12 my @files;
1113              
1114             ### autobundles are special files generated by CPANPLUS. If we can
1115             ### read the file, we can determine the prereqs
1116 3 100       28 if( $self->is_autobundle ) {
1117 2         12 my $where;
1118 2 50       17 unless( $where = $self->status->fetch ) {
1119 0         0 error(loc("Don't know where '%1' was fetched to", $self->package));
1120 0         0 return;
1121             }
1122              
1123 2         184 push @files, $where
1124              
1125             ### regular bundle::* upload
1126             } else {
1127 1         16 my $dir;
1128 1 50       58 unless( $dir = $self->status->extract ) {
1129 0         0 error(loc("Don't know where '%1' was extracted to", $self->module));
1130 0         0 return;
1131             }
1132              
1133             find( {
1134 8 100   8   644 wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i },
1135 1         335 no_chdir => 1,
1136             }, $dir );
1137             }
1138              
1139 3         27 my $prereqs = {}; my @list; my $seen = {};
  3         20  
  3         9  
1140 3         25 for my $file ( @files ) {
1141 3 50       63 my $fh = FileHandle->new($file)
1142             or( error(loc("Could not open '%1' for reading: %2",
1143             $file,$!)), next );
1144              
1145 3         419 my $flag;
1146 3         85 while( local $_ = <$fh> ) {
1147             ### quick hack to read past the header of the file ###
1148 63 100 100     197 last if $flag && m|^=head|i;
1149              
1150             ### from perldoc cpan:
1151             ### =head1 CONTENTS
1152             ### In this pod section each line obeys the format
1153             ### Module_Name [Version_String] [- optional text]
1154 62 100       158 $flag = 1 if m|^=head1 CONTENTS|i;
1155              
1156 62 100 100     264 if ($flag && /^(?!=)(\S+)\s*(\S+)?/) {
1157 7         41 my $module = $1;
1158 7         85 my $version = $cb->_version_to_number( version => $2 );
1159              
1160 7         52 my $obj = $cb->module_tree($module);
1161              
1162 7 50       32 unless( $obj ) {
1163 0         0 error(loc("Cannot find bundled module '%1'", $module),
1164             loc("-- it does not seem to exist") );
1165 0         0 next;
1166             }
1167              
1168             ### make sure we list no duplicates ###
1169 7 50       21 unless( $seen->{ $obj->module }++ ) {
1170 7         17 push @list, $obj;
1171 7         29 $prereqs->{ $module } =
1172             $cb->_version_to_number( version => $version );
1173             }
1174             }
1175             }
1176             }
1177              
1178             ### store the prereqs we just found ###
1179 3         31 $self->status->prereqs( $prereqs );
1180              
1181 3         312 return @list;
1182             }
1183              
1184             =pod
1185              
1186             =head2 $text = $self->readme
1187              
1188             Fetches the readme belonging to this module and stores it under
1189             C<< $obj->status->readme >>. Returns the readme as a string on
1190             success and returns false on failure.
1191              
1192             =cut
1193              
1194             sub readme {
1195 3     3 1 3902 my $self = shift;
1196 3         21 my $conf = $self->parent->configure_object;
1197              
1198             ### did we already dl the readme once? ###
1199 3 100       13 return $self->status->readme() if $self->status->readme();
1200              
1201             ### this should be core ###
1202 2 50       395 return unless can_load( modules => { FileHandle => '0.0' },
1203             verbose => 1,
1204             );
1205              
1206             ### get a clone of the current object, with a fresh status ###
1207 2 50       10012 my $obj = $self->clone or return;
1208              
1209             ### munge the package name
1210 2         20 my $pkg = README->( $obj );
1211 2         8 $obj->package($pkg);
1212              
1213 2         4 my $file;
1214             { ### disable checksum fetches on readme downloads
1215              
1216 2         4 my $tmp = $conf->get_conf( 'md5' );
  2         24  
1217 2         29 $conf->set_conf( md5 => 0 );
1218              
1219 2         19 $file = $obj->fetch;
1220              
1221 2         70 $conf->set_conf( md5 => $tmp );
1222              
1223 2 50       48 return unless $file;
1224             }
1225              
1226             ### read the file into a scalar, to store in the original object ###
1227 2         91 my $fh = new FileHandle;
1228 2 50       294 unless( $fh->open($file) ) {
1229 0         0 error( loc( "Could not open file '%1': %2", $file, $! ) );
1230 0         0 return;
1231             }
1232              
1233 2         137 my $in = do{ local $/; <$fh> };
  2         26  
  2         87  
1234 2         44 $fh->close;
1235              
1236 2         58 return $self->status->readme( $in );
1237             }
1238              
1239             =pod
1240              
1241             =head2 $version = $self->installed_version()
1242              
1243             Returns the currently installed version of this module, if any.
1244              
1245             =head2 $where = $self->installed_file()
1246              
1247             Returns the location of the currently installed file of this module,
1248             if any.
1249              
1250             =head2 $dir = $self->installed_dir()
1251              
1252             Returns the directory (or more accurately, the C<@INC> handle) from
1253             which this module was loaded, if any.
1254              
1255             =head2 $bool = $self->is_uptodate([version => VERSION_NUMBER])
1256              
1257             Returns a boolean indicating if this module is uptodate or not.
1258              
1259             =cut
1260              
1261             ### uptodate/installed functions
1262             { my $map = { # hashkey, alternate rv
1263             installed_version => ['version', 0 ],
1264             installed_file => ['file', ''],
1265             installed_dir => ['dir', ''],
1266             is_uptodate => ['uptodate', 0 ],
1267             };
1268              
1269             while( my($method, $aref) = each %$map ) {
1270             my($key,$alt_rv) = @$aref;
1271              
1272 20     20   241 no strict 'refs';
  20         46  
  20         23400  
1273             *$method = sub {
1274             ### never use the @INC hooks to find installed versions of
1275             ### modules -- they're just there in case they're not on the
1276             ### perl install, but the user shouldn't trust them for *other*
1277             ### modules!
1278             ### XXX CPANPLUS::inc is now obsolete, so this should not
1279             ### be needed anymore
1280             #local @INC = CPANPLUS::inc->original_inc;
1281              
1282 39     39   185 my $self = shift;
1283              
1284             ### make sure check_install is not looking in %INC, as
1285             ### that may contain some of our sneakily loaded modules
1286             ### that aren't installed as such. -- kane
1287 39         379 local $Module::Load::Conditional::CHECK_INC_HASH = 0;
1288             ### this should all that is required for deprecated core modules
1289 39         263 local $Module::Load::Conditional::DEPRECATED = 1;
1290 39         241 my $href = check_install(
1291             module => $self->module,
1292             version => $self->version,
1293             @_,
1294             );
1295              
1296             ### Don't trust modules which are the result of @INC hooks
1297             ### FatPacker uses this trickery and it causes WTF moments
1298 39 50 66     576999 return $alt_rv if defined $href->{dir} && ref $href->{dir};
1299              
1300 39   66     1641 return $href->{$key} || $alt_rv;
1301             }
1302             }
1303             }
1304              
1305              
1306              
1307             =pod
1308              
1309             =head2 $href = $self->details()
1310              
1311             Returns a hashref with key/value pairs offering more information about
1312             a particular module. For example, for C it might look like
1313             this:
1314              
1315             Author Jarkko Hietaniemi (jhi@iki.fi)
1316             Description High resolution time, sleep, and alarm
1317             Development Stage Released
1318             Installed File /usr/local/perl/lib/Time/Hires.pm
1319             Interface Style plain Functions, no references used
1320             Language Used C and perl, a C compiler will be needed
1321             Package Time-HiRes-1.65.tar.gz
1322             Public License Unknown
1323             Support Level Developer
1324             Version Installed 1.52
1325             Version on CPAN 1.65
1326              
1327             =cut
1328              
1329             sub details {
1330 0     0 1 0 my $self = shift;
1331 0         0 my $conf = $self->parent->configure_object();
1332 0         0 my $cb = $self->parent;
1333 0         0 my %hash = @_;
1334              
1335 0   0     0 my $res = {
1336             Author => loc("%1 (%2)", $self->author->author(),
1337             $self->author->email() ),
1338             Package => $self->package,
1339             Description => $self->description || loc('None given'),
1340             'Version on CPAN' => $self->version,
1341             };
1342              
1343             ### check if we have the module installed
1344             ### if so, add version have and version on cpan
1345 0 0       0 $res->{'Version Installed'} = $self->installed_version
1346             if $self->installed_version;
1347 0 0       0 $res->{'Installed File'} = $self->installed_file if $self->installed_file;
1348              
1349 0         0 my $i = 0;
1350 0         0 for my $item( split '', $self->dslip ) {
1351             $res->{ $cb->_dslip_defs->[$i]->[0] } =
1352 0   0     0 $cb->_dslip_defs->[$i]->[1]->{$item} || loc('Unknown');
1353 0         0 $i++;
1354             }
1355              
1356 0         0 return $res;
1357             }
1358              
1359             =head2 @list = $self->contains()
1360              
1361             Returns a list of module objects that represent the modules also
1362             present in the package of this module.
1363              
1364             For example, for C this might return:
1365              
1366             Archive::Tar
1367             Archive::Tar::Constant
1368             Archive::Tar::File
1369              
1370             =cut
1371              
1372             sub contains {
1373 65     65 1 1280 my $self = shift;
1374 65         228 my $cb = $self->parent;
1375 65         643 my $pkg = $self->package;
1376              
1377 65         1797 my @mods = $cb->search( type => 'package', allow => [qr/^$pkg$/] );
1378              
1379 65         446 return @mods;
1380             }
1381              
1382             =pod
1383              
1384             =head2 @list_of_hrefs = $self->fetch_report()
1385              
1386             This function queries the CPAN testers database at
1387             I for test results of specified module
1388             objects, module names or distributions.
1389              
1390             Look at L for details on
1391             the options you can pass and the return value to expect.
1392              
1393             =cut
1394              
1395             sub fetch_report {
1396 0     0 1 0 my $self = shift;
1397 0         0 my $cb = $self->parent;
1398              
1399 0         0 return $cb->_query_report( @_, module => $self );
1400             }
1401              
1402             =pod
1403              
1404             =head2 $bool = $self->uninstall([type => [all|man|prog])
1405              
1406             This function uninstalls the specified module object.
1407              
1408             You can install 2 types of files, either C pages or Cram
1409             files. Alternately you can specify C to uninstall both (which
1410             is the default).
1411              
1412             Returns true on success and false on failure.
1413              
1414             Do note that this does an uninstall via the so-called C<.packlist>,
1415             so if you used a module installer like say, C or C, you
1416             should not use this, but use your package manager instead.
1417              
1418             =cut
1419              
1420             sub uninstall {
1421 0     0 1 0 my $self = shift;
1422 0         0 my $conf = $self->parent->configure_object();
1423 0         0 my %hash = @_;
1424              
1425 0         0 my ($type,$verbose);
1426 0         0 my $tmpl = {
1427             type => { default => 'all', allow => [qw|man prog all|],
1428             store => \$type },
1429             verbose => { default => $conf->get_conf('verbose'),
1430             store => \$verbose },
1431             force => { default => $conf->get_conf('force') },
1432             };
1433              
1434             ### XXX add a warning here if your default install dist isn't
1435             ### makefile or build -- that means you are using a package manager
1436             ### and this will not do what you think!
1437              
1438 0 0       0 my $args = check( $tmpl, \%hash ) or return;
1439              
1440 0 0 0     0 if( $conf->get_conf('dist_type') and (
      0        
1441             ($conf->get_conf('dist_type') ne INSTALLER_BUILD) or
1442             ($conf->get_conf('dist_type') ne INSTALLER_MM))
1443             ) {
1444 0         0 msg(loc("You have a default installer type set (%1) ".
1445             "-- you should probably use that package manager to " .
1446             "uninstall modules", $conf->get_conf('dist_type')), $verbose);
1447             }
1448              
1449             ### check if we even have the module installed -- no point in continuing
1450             ### otherwise
1451 0 0       0 unless( $self->installed_version ) {
1452 0         0 error( loc( "Module '%1' is not installed, so cannot uninstall",
1453             $self->module ) );
1454 0         0 return;
1455             }
1456              
1457             ### nothing to uninstall ###
1458 0 0       0 my $files = $self->files( type => $type ) or return;
1459 0 0       0 my $dirs = $self->directory_tree( type => $type ) or return;
1460 0         0 my $sudo = $conf->get_program('sudo');
1461              
1462             ### just in case there's no file; M::B doesn't provide .packlists yet ###
1463 0         0 my $pack = $self->packlist;
1464 0 0       0 $pack = $pack->[0]->packlist_file() if $pack;
1465              
1466             ### first remove the files, then the dirs if they are empty ###
1467 0         0 my $flag = 0;
1468 0         0 for my $file( @$files, $pack ) {
1469 0 0 0     0 next unless defined $file && -f $file;
1470              
1471 0         0 msg(loc("Unlinking '%1'", $file), $verbose);
1472              
1473 0         0 my @cmd = ($^X, "-eunlink+q[$file]");
1474 0 0       0 unshift @cmd, $sudo if $sudo;
1475              
1476 0         0 my $buffer;
1477 0 0       0 unless ( run( command => \@cmd,
1478             verbose => $verbose,
1479             buffer => \$buffer )
1480             ) {
1481 0         0 error(loc("Failed to unlink '%1': '%2'",$file, $buffer));
1482 0         0 $flag++;
1483             }
1484             }
1485              
1486 0         0 for my $dir ( sort @$dirs ) {
1487 0         0 local *DIR;
1488 0 0       0 opendir DIR, $dir or next;
1489 0         0 my @count = readdir(DIR);
1490 0         0 close DIR;
1491              
1492 0 0       0 next unless @count == 2; # . and ..
1493              
1494 0         0 msg(loc("Removing '%1'", $dir), $verbose);
1495              
1496             ### this fails on my win2k machines.. it indeed leaves the
1497             ### dir, but it's not a critical error, since the files have
1498             ### been removed. --kane
1499             #unless( rmdir $dir ) {
1500             # error( loc( "Could not remove '%1': %2", $dir, $! ) )
1501             # unless $^O eq 'MSWin32';
1502             #}
1503              
1504 0         0 my @cmd = ($^X, "-e", "rmdir q[$dir]");
1505 0 0       0 unshift @cmd, $sudo if $sudo;
1506              
1507 0         0 my $buffer;
1508 0 0       0 unless ( run( command => \@cmd,
1509             verbose => $verbose,
1510             buffer => \$buffer )
1511             ) {
1512 0         0 error(loc("Failed to rmdir '%1': %2",$dir,$buffer));
1513 0         0 $flag++;
1514             }
1515             }
1516              
1517 0         0 $self->status->uninstall(!$flag);
1518 0 0       0 $self->status->installed( $flag ? 1 : undef);
1519              
1520 0         0 return !$flag;
1521             }
1522              
1523             =pod
1524              
1525             =head2 @modobj = $self->distributions()
1526              
1527             Returns a list of module objects representing all releases for this
1528             module on success, false on failure.
1529              
1530             =cut
1531              
1532             sub distributions {
1533 1     1 1 1342 my $self = shift;
1534 1         5 my %hash = @_;
1535              
1536 1 50       4 my @list = $self->author->distributions( %hash, module => $self ) or return;
1537              
1538             ### it's another release then by the same author ###
1539 1         4 return grep { $_->package_name eq $self->package_name } @list;
  3         19  
1540             }
1541              
1542             =pod
1543              
1544             =head2 @list = $self->files ()
1545              
1546             Returns a list of files used by this module, if it is installed.
1547              
1548             =head2 @list = $self->directory_tree ()
1549              
1550             Returns a list of directories used by this module.
1551              
1552             =head2 @list = $self->packlist ()
1553              
1554             Returns the C object for this module.
1555              
1556             =head2 @list = $self->validate ()
1557              
1558             Returns a list of files that are missing for this modules, but
1559             are present in the .packlist file.
1560              
1561             =cut
1562              
1563             for my $sub (qw[files directory_tree packlist validate]) {
1564 20     20   180 no strict 'refs';
  20         45  
  20         16390  
1565             *$sub = sub {
1566 0     0   0 return shift->_extutils_installed( @_, method => $sub );
1567             }
1568             }
1569              
1570             ### generic method to call an ExtUtils::Installed method ###
1571             sub _extutils_installed {
1572 0     0   0 my $self = shift;
1573 0         0 my $cb = $self->parent;
1574 0         0 my $conf = $cb->configure_object;
1575 0         0 my $home = $cb->_home_dir; # may be needed to fix up prefixes
1576 0         0 my %hash = @_;
1577              
1578 0         0 my ($verbose,$type,$method);
1579 0         0 my $tmpl = {
1580             verbose => { default => $conf->get_conf('verbose'),
1581             store => \$verbose, },
1582             type => { default => 'all',
1583             allow => [qw|prog man all|],
1584             store => \$type, },
1585             method => { required => 1,
1586             store => \$method,
1587             allow => [qw|files directory_tree packlist
1588             validate|],
1589             },
1590             };
1591              
1592 0 0       0 my $args = check( $tmpl, \%hash ) or return;
1593              
1594             ### old versions of cygwin + perl < 5.8 are buggy here. bail out if we
1595             ### find we're being used by them
1596 0         0 { my $err = ON_OLD_CYGWIN;
  0         0  
1597 0 0       0 if($err) { error($err); return };
  0         0  
  0         0  
1598             }
1599              
1600 0 0       0 return unless can_load(
1601             modules => { 'ExtUtils::Installed' => '0.0' },
1602             verbose => $verbose,
1603             );
1604              
1605 0         0 my @config_names = (
1606             ### lib
1607             { lib => 'privlib', # perl-only
1608             arch => 'archlib', # compiled code
1609             prefix => 'prefix', # prefix to both
1610             },
1611             ### site
1612             { lib => 'sitelib',
1613             arch => 'sitearch',
1614             prefix => 'siteprefix',
1615             },
1616             ### vendor
1617             { lib => 'vendorlib',
1618             arch => 'vendorarch',
1619             prefix => 'vendorprefix',
1620             },
1621             );
1622              
1623             ### search in your regular @INC, and anything you added to your config.
1624             ### this lets EU::Installed find .packlists that are *not* in the standard
1625             ### compiled in @INC path. Requires EU::I 1.42 or up. this addresses #33438
1626             ### make sure the archname path is also added, as that's where the .packlist
1627             ### files are written
1628 0         0 my @libs;
1629 0         0 for my $lib ( @{ $conf->get_conf('lib') } ) {
  0         0  
1630 0         0 require Config;
1631              
1632             ### and just the standard dir
1633 0         0 push @libs, $lib;
1634              
1635             ### figure out what an MM prefix expands to. Basically, it's the
1636             ### site install target from %Config, ie: /opt/lib/perl5/site_perl/5.8.8
1637             ### minus the site wide prefix, ie: /opt
1638             ### this lets users add the dir they have set as their EU::MM PREFIX
1639             ### to our 'lib' config and it Just Works
1640             ### the arch specific dir, ie:
1641             ### /opt/lib/perl5/site_perl/5.8.8/darwin-2level
1642             ### XXX is this the right thing to do?
1643              
1644             ### we add all 6 dir combos for prefixes:
1645             ### /foo/lib
1646             ### /foo/lib/arch
1647             ### /foo/site/lib
1648             ### /foo/site/lib/arch
1649             ### /foo/vendor/lib
1650             ### /foo/vendor/lib/arch
1651 0         0 for my $href ( @config_names ) {
1652 0         0 for my $key ( qw[lib arch] ) {
1653              
1654             ### look up the config value -- use EXP for the EXPANDED
1655             ### version, so no ~ etc are found in there
1656 0 0       0 my $dir = $Config::Config{ $href->{ $key } .'exp' } or next;
1657 0         0 my $prefix = $Config::Config{ $href->{prefix} };
1658              
1659             ### prefix may be relative to home, and contain a ~
1660             ### if so, fix it up.
1661 0         0 $prefix =~ s/^~/$home/;
1662              
1663             ### remove the prefix from it, so we can append to our $lib
1664 0         0 $dir =~ s/^\Q$prefix\E//;
1665              
1666             ### do the appending
1667 0         0 push @libs, File::Spec->catdir( $lib, $dir );
1668              
1669             }
1670             }
1671             }
1672              
1673 0         0 my $inst;
1674 0 0       0 unless( $inst = ExtUtils::Installed->new( extra_libs => \@libs ) ) {
1675 0         0 error( loc("Could not create an '%1' object", 'ExtUtils::Installed' ) );
1676              
1677             ### in case it's being used directly... ###
1678 0         0 return;
1679             }
1680              
1681              
1682             { ### EU::Installed can die =/
1683 0         0 my @files;
  0         0  
1684 0         0 eval { @files = $inst->$method( $self->module, $type ) };
  0         0  
1685              
1686 0 0       0 if( $@ ) {
1687 0         0 chomp $@;
1688 0         0 error( loc("Could not get '%1' for '%2': %3",
1689             $method, $self->module, $@ ) );
1690 0         0 return;
1691             }
1692              
1693 0 0       0 return wantarray ? @files : \@files;
1694             }
1695             }
1696              
1697             =head2 $bool = $self->add_to_includepath;
1698              
1699             Adds the current modules path to C<@INC> and C<$PERL5LIB>. This allows
1700             you to add the module from its build dir to your path.
1701              
1702             It also adds the current modules C and/or C