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		176	use strict;
	20					44
	20					861
4	20			20		128	use vars qw[@ISA $VERSION];
	20					42
	20					1417
5							$VERSION = "0.9914";
6
7	20			20		7403	use CPANPLUS::Dist;
	20					54
	20					680
8	20			20		173	use CPANPLUS::Error;
	20					46
	20					1401
9	20			20		8315	use CPANPLUS::Module::Signature;
	20					62
	20					658
10	20			20		7343	use CPANPLUS::Module::Checksums;
	20					59
	20					743
11	20			20		148	use CPANPLUS::Internals::Constants;
	20					41
	20					7350
12
13	20			20		166	use FileHandle;
	20					42
	20					122
14
15	20			20		6143	use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
	20					43
	20					102
16	20			20		5307	use IPC::Cmd qw[can_run run];
	20					42
	20					1175
17	20			20		151	use File::Find qw[find];
	20					71
	20					1053
18	20			20		138	use Params::Check qw[check];
	20					38
	20					958
19	20			20		143	use File::Basename qw[dirname];
	20					40
	20					1578
20	20			20		160	use Module::Load::Conditional qw[can_load check_install];
	20					57
	20					3864
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		154	no strict 'refs';
	20					41
	20					11688
90
91							my $sub = $rename{$key} \|\| $key;
92
93							*{__PACKAGE__."::$sub"} = sub {
94	6468	100		6468		65084	$_[0]->{$key} = $_[1] if @_ > 1;
95	6468					40353	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	4516	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	2112	my $self = shift;
157
158							### if this module has relevant dslip info, return it
159	64	50				309	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					505	for my $mod ( $self->contains ) {
164	313	50				664	return $mod->_dslip if $mod->_dslip ne EMPTY_DSLIP;
165							}
166
167							### ok, really no dslip info found, return the default
168	64					371	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	9241	my $self = shift;
196	809					2917	my $obj = CPANPLUS::Internals->_retrieve_id( $self->_id );
197
198	809					3398	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	3465	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					972	local $Params::Check::SANITY_CHECK_TEMPLATE = 0;
325
326	457	50				1806	my $object = check( $tmpl, \%hash ) or return;
327
328	457					31890	bless $object, $class;
329
330	457					2325	return $object;
331							}
332
333							### only create status objects when they're actually asked for
334							sub status {
335	1084			1084	1	32173	my $self = shift;
336	1084	100				4145	return $self->_status if $self->_status;
337
338	125					957	my $acc = Object::Accessor->new;
339	125					2251	$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					27364	$acc->mk_aliases( requires => 'prereqs' );
349
350	125					4470	$self->_status( $acc );
351
352	125					337	return $self->_status;
353							}
354
355
356							### flush the cache of this object ###
357							sub _flush {
358	20			20		34	my $self = shift;
359	20					36	$self->status->mk_flush;
360	20					982	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		171	no strict 'refs';
	20					71
	20					73013
426							*$name = sub {
427	316			316		19572	my $self = shift;
428	316		66			1721	my $val = shift \|\| $self->package;
429	316					1167	my @res = $self->parent->_split_package_string( package => $val );
430
431							### return the corresponding index from the result
432	316	100				2447	return $res[$index] if @res;
433	4					21	return;
434							};
435							}
436
437							sub package_is_perl_core {
438	31			31	1	1555	my $self = shift;
439	31					174	my $cb = $self->parent;
440
441							### check if the package looks like a perl core package
442	31	100				174	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					164	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				84	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					332	return;
464							}
465
466							sub module_is_supplied_with_perl_core {
467	32			32	1	111	my $self = shift;
468	32		33			350	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				237	my $name = ref $self ? $self->module : $self;
475
476							### check Module::CoreList to see if it's a core package
477	32					14665	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					435130	my $core;
485
486	32	100				454	if ( exists $Module::CoreList::version{ 0+$ver }->{ $name } ) {
487	4					81	$core = $Module::CoreList::version{ 0+$ver }->{ $name };
488	4	50				68	$core = 0 unless $core;
489							}
490	32					118	return $core;
491							}
492
493							### make sure Bundle-Foo also gets flagged as bundle
494							sub is_bundle {
495	22			22	1	1627	my $self = shift;
496
497							### cpan'd bundle
498	22	100				92	return 1 if $self->module =~ /^bundle(?:-\|::)/i;
499
500							### autobundle
501	20	100				99	return 1 if $self->is_autobundle;
502
503							### neither
504	16					73	return;
505							}
506
507							### full path to a generated autobundle
508							sub is_autobundle {
509	60			60	1	223	my $self = shift;
510	60					272	my $conf = $self->parent->configure_object;
511	60					595	my $prefix = $conf->_get_build('autobundle_prefix');
512
513	60	100				286	return 1 if $self->module eq $prefix;
514	50					259	return;
515							}
516
517							sub is_third_party {
518	44			44	1	131	my $self = shift;
519
520	44	50				416	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	7110	my $self = shift;
549
550							### clone the object ###
551	45					250	my %data = map { $_ => $self->$_ } @acc;
	495					2129
552
553	45					850	my $obj = CPANPLUS::Module::Fake->new( %data );
554
555	45					269	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	5355	my $self = shift;
571	54					784	my $cb = $self->parent;
572
573							### custom args
574	54					324	my %args = ( module => $self );
575
576							### if a custom fetch location got specified before, add that here
577	54	100				217	$args{fetch_from} = $self->status->_fetch_from
578							if $self->status->_fetch_from;
579
580	54	50				5765	my $where = $cb->_fetch( @_, %args ) or return;
581
582							### do an md5 check ###
583	54	100	100			539	if( !$self->status->_fetch_from and
			100
584							$cb->configure_object->get_conf('md5') and
585							$self->package ne CHECKSUMS
586							) {
587	16	50				628	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					3114	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	3200	my $self = shift;
609	17					81	my $cb = $self->parent;
610
611	17	100				91	unless( $self->status->fetch ) {
612	1					94	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				1571	if( $self->is_autobundle ) {
619
620							### this is expected to be set after an extract call
621	1					23	$self->get_installer_type;
622
623	1					108	return $self->status->extract( dirname( $self->status->fetch ) );
624							}
625
626	15					429	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	959	my $self = shift;
643	20					99	my $cb = $self->parent;
644	20					305	my $conf = $cb->configure_object;
645	20					133	my %hash = @_;
646
647	20					68	my ($prefer_makefile,$verbose);
648	20					872	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				170	check( $tmpl, \%hash ) or return;
656
657	20					1625	my $type;
658
659							### autobundles use their own installer, so return that
660	20	100				211	if( $self->is_autobundle ) {
661	2					25	$type = INSTALLER_AUTOBUNDLE;
662
663							} else {
664	18					109	my $extract = $self->status->extract();
665	18	50				1521	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					278	my $found_build = -e BUILD_PL->( $extract );
675	18					246	my $found_makefile = -e MAKEFILE_PL->( $extract );
676
677	18	100	66			235	$type = INSTALLER_BUILD if !$prefer_makefile && $found_build;
678	18	100	66			96	$type = INSTALLER_BUILD if $found_build && !$found_makefile;
679	18	100	100			290	$type = INSTALLER_MM if $prefer_makefile && $found_makefile;
680	18	100	66			202	$type = INSTALLER_MM if $found_makefile && !$found_build;
681							# Special case Module::Build to always use INSTALLER_MM
682	18	50				155	$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			380	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			8	my $href = $self->status->configure_requires \|\| {};
699	1					94	my $deps = { INSTALLER_BUILD, '0.60', %$href };
700
701	1					4	$self->status->configure_requires( $deps );
702
703	1					86	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				177	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	1040	my $self = shift;
740	19					79	my $cb = $self->parent;
741	19					97	my $conf = $cb->configure_object;
742	19					249	my %hash = @_;
743
744							### have you determined your installer type yet? if not, do it here,
745							### we need the info
746	19	50				80	$self->get_installer_type unless $self->status->installer_type;
747
748	19					1636	my($type,$args,$target);
749	19		33			161	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				1803	check( $tmpl, \%hash ) or return;
758
759							### ok, check for $type. Do we have it?
760	19	100				3051	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				6	if( $type eq INSTALLER_BUILD ) {
766	1					11	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				17	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					19	CPANPLUS::Dist->rescan_dist_types;
780
781	1	50				6	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					14	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					84	my( $dist, $dist_cpan );
801
802	19	100				77	unless( $dist = $self->status->dist ) {
803	14	50				1635	$dist = $type->new( module => $self ) or return;
804	13					52	$self->status->dist( $dist );
805							}
806
807	18	100				1583	unless( $dist_cpan = $self->status->dist_cpan ) {
808
809	13	100				1008	$dist_cpan = $type eq $self->status->installer_type
810							? $self->status->dist
811							: $self->status->installer_type->new( module => $self );
812
813
814	13					417	$self->status->dist_cpan( $dist_cpan );
815							}
816
817
818							DIST: {
819							### just wanted the $dist object?
820	18	100				1519	last DIST if $target eq TARGET_INIT;
	18					86
821
822							### first prepare the dist
823	17	100				279	$dist->prepare( %$args ) or return;
824	16					3430	$self->status->prepared(1);
825
826							### you just wanted us to prepare?
827	16	100				1443	last DIST if $target eq TARGET_PREPARE;
828
829	14	100				130	$dist->create( %$args ) or return;
830	13					2718	$self->status->created(1);
831							}
832
833	16					1655	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	2131	my $self = shift;
850	2					49	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	3860	my $self = shift;
865	3					71	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	868	my $self = shift;
881	1					13	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	383	my $self = shift;
904	17					98	my $cb = $self->parent;
905	17					124	my $conf = $cb->configure_object;
906	17					239	my %hash = @_;
907
908	17					96	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					49	local $Params::Check::NO_DUPLICATES = 1;
	17					133
911	17					98	local $Params::Check::ALLOW_UNKNOWN = 1;
912
913							### targets 'dist' and 'test' are now completely ignored ###
914	17					367	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				124	$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			3735	$args->{'prereq_target'} \|\|= TARGET_CREATE if $target ne TARGET_INSTALL;
934
935							### check if it's already uptodate ###
936	17	0	100			182	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				142	if( $self->package_is_perl_core() ) {
		50
948							# if the installed is newer, say so.
949	1	50				13	if( $self->installed_version > $self->version ) {
		0
950	1					5	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					24	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				6176	unless( $self->status->fetch ) {
990	9					946	my $params;
991	9					26	for (qw[prefer_bin fetchdir]) {
992	18	50				62	$params->{$_} = $args->{$_} if exists $args->{$_};
993							}
994	9					28	for (qw[force verbose]) {
995	18	50				93	$params->{$_} = $args->{$_} if defined $args->{$_};
996							}
997	9	50				66	$self->fetch( %$params ) or return;
998							}
999
1000							### extract it if need be ###
1001	16	100				981	unless( $self->status->extract ) {
1002	10					888	my $params;
1003	10					51	for (qw[prefer_bin extractdir]) {
1004	20	50				91	$params->{$_} = $args->{$_} if exists $args->{$_};
1005							}
1006	10					48	for (qw[force verbose]) {
1007	20	50				170	$params->{$_} = $args->{$_} if defined $args->{$_};
1008							}
1009	10	50				156	$self->extract( %$params ) or return;
1010							}
1011
1012	16	100				2711	$args->{'prereq_format'} = $format if $format;
1013	16		66			183	$format \|\|= $self->status->installer_type;
1014
1015	16	50				726	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				193	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				100	if( $self->is_bundle ) {
1061							### check what we need to install ###
1062	1					6	my @prereqs = $self->bundle_modules();
1063	1	50				7	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					239	my $dist = $self->dist( format => $format,
1072							target => $target,
1073							args => $args );
1074	15	100				528	unless( $dist ) {
1075	2					21	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				258	return 1 if $target ne TARGET_INSTALL;
1081
1082	5	100				454	my $ok = $dist->install( %$args ) ? 1 : 0;
1083
1084	5					1352	$self->status->installed($ok);
1085
1086	5	100				619	return 1 if $ok;
1087	1					25	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	2712	my $self = shift;
1105	3					30	my $cb = $self->parent;
1106
1107	3	50				38	unless( $self->is_bundle ) {
1108	0					0	error( loc("'%1' is not a bundle", $self->module ) );
1109	0					0	return;
1110							}
1111
1112	3					14	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				29	if( $self->is_autobundle ) {
1117	2					11	my $where;
1118	2	50				21	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					192	push @files, $where
1124
1125							### regular bundle::* upload
1126							} else {
1127	1					3	my $dir;
1128	1	50				16	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		594	wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i },
1135	1					351	no_chdir => 1,
1136							}, $dir );
1137							}
1138
1139	3					20	my $prereqs = {}; my @list; my $seen = {};
	3					11
	3					16
1140	3					22	for my $file ( @files ) {
1141	3	50				74	my $fh = FileHandle->new($file)
1142							or( error(loc("Could not open '%1' for reading: %2",
1143							$file,$!)), next );
1144
1145	3					448	my $flag;
1146	3					116	while( local $_ = <$fh> ) {
1147							### quick hack to read past the header of the file ###
1148	63	100	100			193	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				143	$flag = 1 if m\|^=head1 CONTENTS\|i;
1155
1156	62	100	100			283	if ($flag && /^(?!=)(\S+)\s*(\S+)?/) {
1157	7					40	my $module = $1;
1158	7					103	my $version = $cb->_version_to_number( version => $2 );
1159
1160	7					42	my $obj = $cb->module_tree($module);
1161
1162	7	50				46	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				24	unless( $seen->{ $obj->module }++ ) {
1170	7					21	push @list, $obj;
1171	7					34	$prereqs->{ $module } =
1172							$cb->_version_to_number( version => $version );
1173							}
1174							}
1175							}
1176							}
1177
1178							### store the prereqs we just found ###
1179	3					41	$self->status->prereqs( $prereqs );
1180
1181	3					331	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	3746	my $self = shift;
1196	3					16	my $conf = $self->parent->configure_object;
1197
1198							### did we already dl the readme once? ###
1199	3	100				23	return $self->status->readme() if $self->status->readme();
1200
1201							### this should be core ###
1202	2	50				220	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				9959	my $obj = $self->clone or return;
1208
1209							### munge the package name
1210	2					29	my $pkg = README->( $obj );
1211	2					12	$obj->package($pkg);
1212
1213	2					5	my $file;
1214							{ ### disable checksum fetches on readme downloads
1215
1216	2					11	my $tmp = $conf->get_conf( 'md5' );
	2					18
1217	2					31	$conf->set_conf( md5 => 0 );
1218
1219	2					22	$file = $obj->fetch;
1220
1221	2					65	$conf->set_conf( md5 => $tmp );
1222
1223	2	50				46	return unless $file;
1224							}
1225
1226							### read the file into a scalar, to store in the original object ###
1227	2					92	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					181	my $in = do{ local $/; <$fh> };
	2					23
	2					89
1234	2					53	$fh->close;
1235
1236	2					100	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		274	no strict 'refs';
	20					49
	20					23938
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		192	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					353	local $Module::Load::Conditional::CHECK_INC_HASH = 0;
1288							### this should all that is required for deprecated core modules
1289	39					259	local $Module::Load::Conditional::DEPRECATED = 1;
1290	39					10215	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			653160	return $alt_rv if defined $href->{dir} && ref $href->{dir};
1299
1300	39		66			974	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	1297	my $self = shift;
1374	65					231	my $cb = $self->parent;
1375	65					249	my $pkg = $self->package;
1376
1377	65					1839	my @mods = $cb->search( type => 'package', allow => [qr/^$pkg$/] );
1378
1379	65					439	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	1376	my $self = shift;
1534	1					5	my %hash = @_;
1535
1536	1	50				6	my @list = $self->author->distributions( %hash, module => $self ) or return;
1537
1538							### it's another release then by the same author ###
1539	1					15	return grep { $_->package_name eq $self->package_name } @list;
	3					18
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		175	no strict 'refs';
	20					49
	20					17407
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