File Coverage

lib/CPANPLUS/Module.pm

Criterion	Covered	Total	%
statement	325	391	83.1
branch	119	196	60.7
condition	42	73	57.5
subroutine	51	54	94.4
pod	33	34	97.1
total	570	748	76.2

line	stmt	bran	cond	sub	pod	time	code
1							package CPANPLUS::Module;
2
3	15			15		235	use strict;
	15					219
	15					309
4	15			15		252	use vars qw[@ISA];
	15					135
	15					246
5
6
7	15			15		520	use CPANPLUS::Dist;
	15					146
	15					466
8	15			15		284	use CPANPLUS::Error;
	15					134
	15					288
9	15			15		716	use CPANPLUS::Module::Signature;
	15					164
	15					545
10	15			15		577	use CPANPLUS::Module::Checksums;
	15					179
	15					520
11	15			15		347	use CPANPLUS::Internals::Constants;
	15					206
	15					358
12
13	15			15		459	use FileHandle;
	15					314
	15					356
14
15	15			15		273	use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
	15					142
	15					245
16	15			15		576	use IPC::Cmd qw[can_run run];
	15					152
	15					459
17	15			15		264	use File::Find qw[find];
	15					139
	15					476
18	15			15		243	use Params::Check qw[check];
	15					140
	15					258
19	15			15		308	use Module::Load::Conditional qw[can_load check_install];
	15					138
	15					250
20
21							$Params::Check::VERBOSE = 1;
22
23							@ISA = qw[ CPANPLUS::Module::Signature CPANPLUS::Module::Checksums];
24
25							=pod
26
27							=head1 NAME
28
29							CPANPLUS::Module
30
31							=head1 SYNOPSIS
32
33							### get a module object from the CPANPLUS::Backend object
34							my $mod = $cb->module_tree('Some::Module');
35
36							### accessors
37							$mod->version;
38							$mod->package;
39
40							### methods
41							$mod->fetch;
42							$mod->extract;
43							$mod->install;
44
45
46							=head1 DESCRIPTION
47
48							C<CPANPLUS::Module> creates objects from the information in the
49							source files. These can then be used to query and perform actions
50							on, like fetching or installing.
51
52							These objects should only be created internally. For C<fake> objects,
53							there's the C<CPANPLUS::Module::Fake> class. To obtain a module object
54							consult the C<CPANPLUS::Backend> documentation.
55
56							=cut
57
58							my $tmpl = {
59							module => { default => '', required => 1 }, # full module name
60							version => { default => '0.0' }, # version number
61							path => { default => '', required => 1 }, # extended path on the
62							# cpan mirror, like
63							# /author/id/K/KA/KANE
64							comment => { default => ''}, # comment on module
65							package => { default => '', required => 1 }, # package name, like
66							# 'bar-baz-1.03.tgz'
67							description => { default => '' }, # description of the
68							# module
69							dslip => { default => ' ' }, # dslip information
70							_id => { required => 1 }, # id of the Internals
71							# parent object
72							_status => { no_override => 1 }, # stores status object
73							author => { default => '', required => 1,
74							allow => IS_AUTHOBJ }, # module author
75							};
76
77							### autogenerate accessors ###
78							for my $key ( keys %$tmpl ) {
79	15			15		355	no strict 'refs';
	15					179
	15					1133
80							*{__PACKAGE__."::$key"} = sub {
81	3215	100		3215		58359	$_[0]->{$key} = $_[1] if @_ > 1;
82	3215					136837	return $_[0]->{$key};
83							}
84							}
85
86							=pod
87
88							=head1 CLASS METHODS
89
90							=head2 accessors ()
91
92							Returns a list of all accessor methods to the object
93
94							=cut
95
96	66			66	1	5627	sub accessors { return keys %$tmpl };
97
98							=head1 ACCESSORS
99
100							An objects of this class has the following accessors:
101
102							=over 4
103
104							=item name
105
106							Name of the module.
107
108							=item module
109
110							Name of the module.
111
112							=item version
113
114							Version of the module. Defaults to '0.0' if none was provided.
115
116							=item path
117
118							Extended path on the mirror.
119
120							=item comment
121
122							Any comment about the module -- largely unused.
123
124							=item package
125
126							The name of the package.
127
128							=item description
129
130							Description of the module -- only registered modules have this.
131
132							=item dslip
133
134							The five character dslip string, that represents meta-data of the
135							module -- again, only registered modules have this.
136
137							=item status
138
139							The C<CPANPLUS::Module::Status> object associated with this object.
140							(see below).
141
142							=item author
143
144							The C<CPANPLUS::Module::Author> object associated with this object.
145
146							=item parent
147
148							The C<CPANPLUS::Internals> object that spawned this module object.
149
150							=back
151
152							=cut
153
154							### Alias ->name to ->module, for human beings.
155							name = module;
156
157							sub parent {
158	261			261	1	3694	my $self = shift;
159	261					8592	my $obj = CPANPLUS::Internals->_retrieve_id( $self->_id );
160
161	261					5783	return $obj;
162							}
163
164							=head1 STATUS ACCESSORS
165
166							C<CPANPLUS> caches a lot of results from method calls and saves data
167							it collected along the road for later reuse.
168
169							C<CPANPLUS> uses this internally, but it is also available for the end
170							user. You can get a status object by calling:
171
172							$modobj->status
173
174							You can then query the object as follows:
175
176							=over 4
177
178							=item installer_type
179
180							The installer type used for this distribution. Will be one of
181							'makemaker' or 'build'. This determines whether C<CPANPLUS::Dist::MM>
182							or C<CPANPLUS::Dist::Build> will be used to build this distribution.
183
184							=item dist_cpan
185
186							The dist object used to do the CPAN-side of the installation. Either
187							a C<CPANPLUS::Dist::MM> or C<CPANPLUS::Dist::Build> object.
188
189							=item dist
190
191							The custom dist object used to do the operating specific side of the
192							installation, if you've chosen to use this. For example, if you've
193							chosen to install using the C<ports> format, this may be a
194							C<CPANPLUS::Dist::Ports> object.
195
196							Undefined if you didn't specify a separate format to install through.
197
198							=item prereqs
199
200							A hashref of prereqs this distribution was found to have. Will look
201							something like this:
202
203							{ Carp => 0.01, strict => 0 }
204
205							Might be undefined if the distribution didn't have any prerequisites.
206
207							=item signature
208
209							Flag indicating, if a signature check was done, whether it was OK or
210							not.
211
212							=item extract
213
214							The directory this distribution was extracted to.
215
216							=item fetch
217
218							The location this distribution was fetched to.
219
220							=item readme
221
222							The text of this distributions README file.
223
224							=item uninstall
225
226							Flag indicating if an uninstall call was done successfully.
227
228							=item created
229
230							Flag indicating if the C<create> call to your dist object was done
231							successfully.
232
233							=item installed
234
235							Flag indicating if the C<install> call to your dist object was done
236							successfully.
237
238							=item checksums
239
240							The location of this distributions CHECKSUMS file.
241
242							=item checksum_ok
243
244							Flag indicating if the checksums check was done successfully.
245
246							=item checksum_value
247
248							The checksum value this distribution is expected to have
249
250							=back
251
252							=head1 METHODS
253
254							=head2 $self = CPANPLUS::Module::new( OPTIONS )
255
256							This method returns a C<CPANPLUS::Module> object. Normal users
257							should never call this method directly, but instead use the
258							C<CPANPLUS::Backend> to obtain module objects.
259
260							This example illustrates a C<new()> call with all required arguments:
261
262							CPANPLUS::Module->new(
263							module => 'Foo',
264							path => 'authors/id/A/AA/AAA',
265							package => 'Foo-1.0.tgz',
266							author => $author_object,
267							_id => INTERNALS_OBJECT_ID,
268							);
269
270							Every accessor is also a valid option to pass to C<new>.
271
272							Returns a module object on success and false on failure.
273
274							=cut
275
276
277							sub new {
278	256			256	1	8405	my($class, %hash) = @_;
279
280							### don't check the template for sanity
281							### -- we know it's good and saves a lot of performance
282	256					3278	local $Params::Check::SANITY_CHECK_TEMPLATE = 0;
283
284	256	50				4233	my $object = check( $tmpl, \%hash ) or return;
285
286	256					6840	bless $object, $class;
287
288	256					6711	return $object;
289							}
290
291							### only create status objects when they're actually asked for
292							sub status {
293	774			774	1	42261	my $self = shift;
294	774	100				22584	return $self->_status if $self->_status;
295
296	70					2786	my $acc = Object::Accessor->new;
297	70					6309	$acc->mk_accessors( qw[ installer_type dist_cpan dist prereqs
298							signature extract fetch readme uninstall
299							created installed prepared checksums files
300							checksum_ok checksum_value _fetch_from] );
301
302	70					3584	$self->_status( $acc );
303
304	70					921	return $self->_status;
305							}
306
307
308							### flush the cache of this object ###
309							sub _flush {
310	18			18		154	my $self = shift;
311	18					237	$self->status->mk_flush;
312	18					5505	return 1;
313							}
314
315							=head2 $mod->package_name
316
317							Returns the name of the package a module is in. For C<Acme::Bleach>
318							that might be C<Acme-Bleach>.
319
320							=head2 $mod->package_version
321
322							Returns the version of the package a module is in. For a module
323							in the package C<Acme-Bleach-1.1.tar.gz> this would be C<1.1>.
324
325							=head2 $mod->package_extension
326
327							Returns the suffix added by the compression method of a package a
328							certain module is in. For a module in C<Acme-Bleach-1.1.tar.gz>, this
329							would be C<tar.gz>.
330
331							=head2 $mod->package_is_perl_core
332
333							Returns a boolean indicating of the package a particular module is in,
334							is actually a core perl distribution.
335
336							=head2 $mod->module_is_supplied_with_perl_core( [version => $]] )
337
338							Returns a boolean indicating whether C<ANY VERSION> of this module
339							was supplied with the current running perl's core package.
340
341							=head2 $mod->is_bundle
342
343							Returns a boolean indicating if the module you are looking at, is
344							actually a bundle. Bundles are identified as modules whose name starts
345							with C<Bundle::>.
346
347							=head2 $mod->is_third_party
348
349							Returns a boolean indicating whether the package is a known third-party
350							module (i.e. it's not provided by the standard Perl distribution and
351							is not available on the CPAN, but on a third party software provider).
352							See L<Module::ThirdParty> for more details.
353
354							=head2 $mod->third_party_information
355
356							Returns a reference to a hash with more information about a third-party
357							module. See the documentation about C<module_information()> in
358							L<Module::ThirdParty> for more details.
359
360							=cut
361
362							{
363							my $regex = qr/^(.+)-(.+)\.((?:tar\.gz\|zip\|tgz))/i;
364
365							### fetches the test reports for a certain module ###
366							sub package_name {
367	58	50		58	1	2174	return $1 if shift->package() =~ $regex;
368							}
369
370							sub package_version {
371	22	50		22	1	1040	return $2 if shift->package() =~ $regex;
372							}
373
374							sub package_extension {
375	10	50		10	1	109	return $3 if shift->package() =~ $regex;
376							}
377
378							sub package_is_perl_core {
379	26			26	1	259	my $self = shift;
380
381							### check if the package looks like a perl core package
382	26	100				460	return 1 if $self->package_name eq PERL_CORE;
383
384	22					565	my $core = $self->module_is_supplied_with_perl_core;
385							### ok, so it's found in the core, BUT it could be dual-lifed
386	22	50				400	if ($core) {
387							### if the package is newer than installed, then it's dual-lifed
388	0	0				0	return if $self->version > $self->installed_version;
389
390							### if the package is newer than corelist, then it's dual-lifed
391	0	0				0	return if $self->version > $core;
392
393							### otherwise, it's older than corelist, thus unsuitable.
394	0					0	return 1;
395							}
396
397							### not in corelist, not a perl core package.
398	22					4217	return;
399							}
400
401							sub module_is_supplied_with_perl_core {
402	24			24	1	258	my $self = shift;
403	24		33			676	my $ver = shift \|\| $];
404
405							### check Module::CoreList to see if it's a core package
406	24					1031	require Module::CoreList;
407	24					717	my $core = $Module::CoreList::version{ $ver }->{ $self->module };
408
409	24					408	return $core;
410							}
411
412							### make sure Bundle-Foo also gets flagged as bundle
413							sub is_bundle {
414	15	100		15	1	223	return shift->module =~ /^bundle(?:-\|::)/i ? 1 : 0;
415							}
416
417							sub is_third_party {
418	27			27	1	245	my $self = shift;
419
420	27	50				850	return unless can_load( modules => { 'Module::ThirdParty' => 0 } );
421
422	0					0	return Module::ThirdParty::is_3rd_party( $self->name );
423							}
424
425							sub third_party_information {
426	0			0	1	0	my $self = shift;
427
428	0	0				0	return unless $self->is_third_party;
429
430	0					0	return Module::ThirdParty::module_information( $self->name );
431							}
432							}
433
434							=pod
435
436							=head2 $clone = $self->clone
437
438							Clones the current module object for tinkering with.
439							It will have a clean C<CPANPLUS::Module::Status> object, as well as
440							a fake C<CPANPLUS::Module::Author> object.
441
442							=cut
443
444							sub clone {
445	33			33	1	4045	my $self = shift;
446
447							### clone the object ###
448	33					356	my %data;
449	33					1642	for my $acc ( grep !/status/, __PACKAGE__->accessors() ) {
450	297					7342	$data{$acc} = $self->$acc();
451							}
452
453	33					3367	my $obj = CPANPLUS::Module::Fake->new( %data );
454
455	33					693	return $obj;
456							}
457
458							=pod
459
460							=head2 $where = $self->fetch
461
462							Fetches the module from a CPAN mirror.
463							Look at L<CPANPLUS::Internals::Fetch::_fetch()> for details on the
464							options you can pass.
465
466							=cut
467
468							sub fetch {
469	49			49	1	971	my $self = shift;
470	49					1308	my $cb = $self->parent;
471
472							### custom args
473	49					1080	my %args = ( module => $self );
474
475							### if a custom fetch location got specified before, add that here
476	49	100				785	$args{fetch_from} = $self->status->_fetch_from
477							if $self->status->_fetch_from;
478
479	49	50				3459	my $where = $cb->_fetch( @_, %args ) or return;
480
481							### do an md5 check ###
482	49	100	100			2368	if( !$self->status->_fetch_from and
			100
483							$cb->configure_object->get_conf('md5') and
484							$self->package ne CHECKSUMS
485							) {
486	13	50				2187	unless( $self->_validate_checksum ) {
487	0					0	error( loc( "Checksum error for '%1' -- will not trust package",
488							$self->package) );
489	0					0	return;
490							}
491							}
492
493	49					12505	return $where;
494							}
495
496							=pod
497
498							=head2 $path = $self->extract
499
500							Extracts the fetched module.
501							Look at L<CPANPLUS::Internals::Extract::_extract()> for details on
502							the options you can pass.
503
504							=cut
505
506							sub extract {
507	14			14	1	376	my $self = shift;
508	14					186	my $cb = $self->parent;
509
510	14	100				179	unless( $self->status->fetch ) {
511	1					13	error( loc( "You have not fetched '%1' yet -- cannot extract",
512							$self->module) );
513	1					40	return;
514							}
515
516	13					1798	return $cb->_extract( @_, module => $self );
517							}
518
519							=head2 $type = $self->get_installer_type([prefer_makefile => BOOL])
520
521							Gets the installer type for this module. This may either be C<build> or
522							C<makemaker>. If C<Module::Build> is unavailable or no installer type
523							is available, it will fall back to C<makemaker>. If both are available,
524							it will pick the one indicated by your config, or by the
525							C<prefer_makefile> option you can pass to this function.
526
527							Returns the installer type on success, and false on error.
528
529							=cut
530
531							sub get_installer_type {
532	15			15	1	424	my $self = shift;
533	15					608	my $cb = $self->parent;
534	15					2942	my $conf = $cb->configure_object;
535	15					767	my %hash = @_;
536
537	15					218	my $prefer_makefile;
538	15					2143	my $tmpl = {
539							prefer_makefile => { default => $conf->get_conf('prefer_makefile'),
540							store => \$prefer_makefile, allow => BOOLEANS },
541							};
542
543	15	50				357	check( $tmpl, \%hash ) or return;
544
545	15					277	my $extract = $self->status->extract();
546	15	50				214	unless( $extract ) {
547	0					0	error(loc("Cannot determine installer type of unextracted module '%1'",
548							$self->module));
549	0					0	return;
550							}
551
552
553							### check if it's a makemaker or a module::build type dist ###
554	15					1390	my $found_build = -e BUILD_PL->( $extract );
555	15					1111	my $found_makefile = -e MAKEFILE_PL->( $extract );
556
557	15					167	my $type;
558	15	100	66			7295	$type = INSTALLER_BUILD if !$prefer_makefile && $found_build;
559	15	50	66			333	$type = INSTALLER_BUILD if $found_build && !$found_makefile;
560	15	100	66			709	$type = INSTALLER_MM if $prefer_makefile && $found_makefile;
561	15	100	66			832	$type = INSTALLER_MM if $found_makefile && !$found_build;
562
563							### ok, so it's a 'build' installer, but you don't /have/ module build
564	15	100	66			401	if( $type eq INSTALLER_BUILD and (
	1	50				15
565							not grep { $_ eq INSTALLER_BUILD } CPANPLUS::Dist->dist_types )
566							) {
567	1					50	error( loc( "This module requires '%1' and '%2' to be installed, ".
568							"but you don't have it! Will fall back to ".
569							"'%3', but might not be able to install!",
570							'Module::Build', INSTALLER_BUILD, INSTALLER_MM ) );
571	1					29	$type = INSTALLER_MM;
572
573							### ok, actually we found neither ###
574							} elsif ( !$type ) {
575	0					0	error( loc( "Unable to find '%1' or '%2' for '%3'; ".
576							"Will default to '%4' but might be unable ".
577							"to install!", BUILD_PL->(), MAKEFILE_PL->(),
578							$self->module, INSTALLER_MM ) );
579	0					0	$type = INSTALLER_MM;
580							}
581
582	15	50				372	return $self->status->installer_type( $type ) if $type;
583	0					0	return;
584							}
585
586							=pod
587
588							=head2 $dist = $self->dist([target => 'prepare\|create', format => DISTRIBUTION_TYPE, args => {key => val}]);
589
590							Create a distribution object, ready to be installed.
591							Distribution type defaults to your config settings
592
593							The optional C<args> hashref is passed on to the specific distribution
594							types' C<create> method after being dereferenced.
595
596							Returns a distribution object on success, false on failure.
597
598							See C<CPANPLUS::Dist> for details.
599
600							=cut
601
602							sub dist {
603	14			14	1	329	my $self = shift;
604	14					370	my $cb = $self->parent;
605	14					541	my $conf = $cb->configure_object;
606	14					911	my %hash = @_;
607
608							### have you determined your installer type yet? if not, do it here,
609							### we need the info
610	14	50				183	$self->get_installer_type unless $self->status->installer_type;
611
612
613	14					140	my($type,$args,$target);
614	14		33			690	my $tmpl = {
615							format => { default => $conf->get_conf('dist_type') \|\|
616							$self->status->installer_type,
617							store => \$type },
618							target => { default => TARGET_CREATE, store => \$target },
619							args => { default => {}, store => \$args },
620							};
621
622	14	50				403	check( $tmpl, \%hash ) or return;
623
624	14	50				2015	my $dist = CPANPLUS::Dist->new(
625							format => $type,
626							module => $self
627							) or return;
628
629	14	100				181	my $dist_cpan = $type eq $self->status->installer_type
630							? $dist
631							: CPANPLUS::Dist->new(
632							format => $self->status->installer_type,
633							module => $self,
634							);
635
636							### store the dists
637	14					186	$self->status->dist_cpan( $dist_cpan );
638	14					170	$self->status->dist( $dist );
639
640	14	100				464	DIST: {
641							### first prepare the dist
642	14					130	$dist->prepare( %$args ) or return;
643	13					478	$self->status->prepared(1);
644
645							### you just wanted us to prepare?
646	13	100				462	last DIST if $target eq TARGET_PREPARE;
647
648	12	100				512	$dist->create( %$args ) or return;
649	11					849	$self->status->created(1);
650							}
651
652	12					2497	return $dist;
653							}
654
655							=pod
656
657							=head2 $bool = $mod->prepare( )
658
659							Convenience method around C<install()> that prepares a module
660							without actually building it. This is equivalent to invoking C<install>
661							with C<target> set to C<prepare>
662
663							Returns true on success, false on failure.
664
665							=cut
666
667							sub prepare {
668	1			1	1	12	my $self = shift;
669	1					45	return $self->install( @_, target => TARGET_PREPARE );
670							}
671
672							=head2 $bool = $mod->create( )
673
674							Convenience method around C<install()> that creates a module.
675							This is equivalent to invoking C<install> with C<target> set to
676							C<create>
677
678							Returns true on success, false on failure.
679
680							=cut
681
682							sub create {
683	1			1	1	31	my $self = shift;
684	1					81	return $self->install( @_, target => TARGET_CREATE );
685							}
686
687							=head2 $bool = $mod->test( )
688
689							Convenience wrapper around C<install()> that tests a module, without
690							installing it.
691							It's the equivalent to invoking C<install()> with C<target> set to
692							C<create> and C<skiptest> set to C<0>.
693
694							Returns true on success, false on failure.
695
696							=cut
697
698							sub test {
699	1			1	1	14	my $self = shift;
700	1					48	return $self->install( @_, target => TARGET_CREATE, skiptest => 0 );
701							}
702
703							=pod
704
705							=head2 $bool = $self->install([ target => 'prepare\|create\|install', format => FORMAT_TYPE, extractdir => DIRECTORY, fetchdir => DIRECTORY, prefer_bin => BOOL, force => BOOL, verbose => BOOL, ..... ]);
706
707							Installs the current module. This includes fetching it and extracting
708							it, if this hasn't been done yet, as well as creating a distribution
709							object for it.
710
711							This means you can pass it more arguments than described above, which
712							will be passed on to the relevant methods as they are called.
713
714							See C<CPANPLUS::Internals::Fetch>, C<CPANPLUS::Internals::Extract> and
715							C<CPANPLUS::Dist> for details.
716
717							Returns true on success, false on failure.
718
719							=cut
720
721							sub install {
722	13			13	1	219	my $self = shift;
723	13					257	my $cb = $self->parent;
724	13					329	my $conf = $cb->configure_object;
725	13					376	my %hash = @_;
726
727	13					112	my $args; my $target; my $format;
	13					107
	13					134
728							{ ### so we can use the rest of the args to the create calls etc ###
729	13					131	local $Params::Check::NO_DUPLICATES = 1;
	13					123
730	13					176	local $Params::Check::ALLOW_UNKNOWN = 1;
731
732							### targets 'dist' and 'test' are now completely ignored ###
733	13					423	my $tmpl = {
734							### match this allow list with Dist->_resolve_prereqs
735							target => { default => TARGET_INSTALL, store => \$target,
736							allow => [TARGET_PREPARE, TARGET_CREATE,
737							TARGET_INSTALL] },
738							force => { default => $conf->get_conf('force'), },
739							verbose => { default => $conf->get_conf('verbose'), },
740							format => { default => $conf->get_conf('dist_type'),
741							store => \$format },
742							};
743
744	13	50				206	$args = check( $tmpl, \%hash ) or return;
745							}
746
747							### if this target isn't 'install', we will need to at least 'create'
748							### every prereq, so it can build
749							### XXX prereq_target of 'prepare' will do weird things here, and is
750							### not supported.
751	13	100	50			299	$args->{'prereq_target'} \|\|= TARGET_CREATE if $target ne TARGET_INSTALL;
752
753							### check if it's already upto date ###
754	13	50	100			571	if( $target eq TARGET_INSTALL and !$args->{'force'} and
			66
			0
			33
			33
755							!$self->package_is_perl_core() and # separate rules apply
756							( $self->status->installed() or $self->is_uptodate ) and
757							!INSTALL_VIA_PACKAGE_MANAGER->($format)
758							) {
759	0					0	msg(loc("Module '%1' already up to date, won't install without force",
760							$self->module), $args->{'verbose'} );
761	0					0	return $self->status->installed(1);
762							}
763
764							# if it's a non-installable core package, abort the install.
765	13	100				246	if( $self->package_is_perl_core() ) {
		50
766							# if the installed is newer, say so.
767	1	50				57	if( $self->installed_version > $self->version ) {
		0
768	1					14	error(loc("The core Perl %1 module '%2' (%3) is more ".
769							"recent than the latest release on CPAN (%4). ".
770							"Aborting install.",
771							$], $self->module, $self->installed_version,
772							$self->version ) );
773							# if the installed matches, say so.
774							} elsif( $self->installed_version == $self->version ) {
775	0					0	error(loc("The core Perl %1 module '%2' (%3) can only ".
776							"be installed by Perl itself. ".
777							"Aborting install.",
778							$], $self->module, $self->installed_version ) );
779							# otherwise, the installed is older; say so.
780							} else {
781	0					0	error(loc("The core Perl %1 module '%2' can only be ".
782							"upgraded from %3 to %4 by Perl itself (%5). ".
783							"Aborting install.",
784							$], $self->module, $self->installed_version,
785							$self->version, $self->package ) );
786							}
787	1					39	return;
788
789							### it might be a known 3rd party module
790							} elsif ( $self->is_third_party ) {
791	0					0	my $info = $self->third_party_information;
792	0					0	error(loc(
793							"%1 is a known third-party module.\n\n".
794							"As it isn't available on the CPAN, CPANPLUS can't install " .
795							"it automatically. Therefore you need to install it manually " .
796							"before proceeding.\n\n".
797							"%2 is part of %3, published by %4, and should be available ".
798							"for download at the following address:\n\t%5",
799							$self->name, $self->name, $info->{name}, $info->{author},
800							$info->{url}
801							));
802
803	0					0	return;
804							}
805
806							### fetch it if need be ###
807	12	100				3400	unless( $self->status->fetch ) {
808	8					67	my $params;
809	8					79	for (qw[prefer_bin fetchdir]) {
810	16	50				181	$params->{$_} = $args->{$_} if exists $args->{$_};
811							}
812	8					76	for (qw[force verbose]) {
813	16	50				210	$params->{$_} = $args->{$_} if defined $args->{$_};
814							}
815	8	50				385	$self->fetch( %$params ) or return;
816							}
817
818							### extract it if need be ###
819	12	100				288	unless( $self->status->extract ) {
820	8					67	my $params;
821	8					76	for (qw[prefer_bin extractdir]) {
822	16	50				182	$params->{$_} = $args->{$_} if exists $args->{$_};
823							}
824	8					78	for (qw[force verbose]) {
825	16	50				206	$params->{$_} = $args->{$_} if defined $args->{$_};
826							}
827	8	50				142	$self->extract( %$params ) or return;
828							}
829
830	12		66			547	$format \|\|= $self->status->installer_type;
831
832	12	50				131	unless( $format ) {
833	0					0	error( loc( "Don't know what installer to use; " .
834							"Couldn't find either '%1' or '%2' in the extraction " .
835							"directory '%3' -- will be unable to install",
836							BUILD_PL->(), MAKEFILE_PL->(), $self->status->extract ) );
837
838	0					0	$self->status->installed(0);
839	0					0	return;
840							}
841
842
843							### do SIGNATURE checks? ###
844	12	100				469	if( $conf->get_conf('signature') ) {
845	4	50				490	unless( $self->check_signature( verbose => $args->{verbose} ) ) {
846	0					0	error( loc( "Signature check failed for module '%1' ".
847							"-- Not trusting this module, aborting install",
848							$self->module ) );
849	0					0	$self->status->signature(0);
850
851							### send out test report on broken sig
852	0	0				0	if( $conf->get_conf('cpantest') ) {
853	0	0				0	$cb->_send_report(
854							module => $self,
855							failed => 1,
856							buffer => CPANPLUS::Error->stack_as_string,
857							verbose => $args->{verbose},
858							force => $args->{force},
859							) or error(loc("Failed to send test report for '%1'",
860							$self->module ) );
861							}
862
863	0					0	return;
864
865							} else {
866							### signature OK ###
867	4					516	$self->status->signature(1);
868							}
869							}
870
871							### a target of 'create' basically means not to run make test ###
872							### eh, no it /doesn't/.. skiptest => 1 means skiptest => 1.
873							#$args->{'skiptest'} = 1 if $target eq 'create';
874
875							### bundle rules apply ###
876	12	50				576	if( $self->is_bundle ) {
877							### check what we need to install ###
878	0					0	my @prereqs = $self->bundle_modules();
879	0	0				0	unless( @prereqs ) {
880	0					0	error( loc( "Bundle '%1' does not specify any modules to install",
881							$self->module ) );
882
883							### XXX mark an error here? ###
884							}
885							}
886
887	12					577	my $dist = $self->dist( format => $format,
888							target => $target,
889							args => $args );
890	12	100				349	unless( $dist ) {
891	2					26	error( loc( "Unable to create a new distribution object for '%1' " .
892							"-- cannot continue", $self->module ) );
893	2					240	return;
894							}
895
896	10	100				1092	return 1 if $target ne TARGET_INSTALL;
897
898	5	100				407	my $ok = $dist->install( %$args ) ? 1 : 0;
899
900	5					290	$self->status->installed($ok);
901
902	5	100				676	return 1 if $ok;
903	1					85	return;
904							}
905
906							=pod @list = $self->bundle_modules()
907
908							Returns a list of module objects the Bundle specifies.
909
910							This requires you to have extracted the bundle already, using the
911							C<extract()> method.
912
913							Returns false on error.
914
915							=cut
916
917							sub bundle_modules {
918	1			1	0	66	my $self = shift;
919	1					64	my $cb = $self->parent;
920
921	1	50				101	unless( $self->is_bundle ) {
922	0					0	error( loc("'%1' is not a bundle", $self->module ) );
923	0					0	return;
924							}
925
926	1					29	my $dir;
927	1	50				68	unless( $dir = $self->status->extract ) {
928	0					0	error( loc("Don't know where '%1' was extracted to", $self->module ) );
929	0					0	return;
930							}
931
932	1					65	my @files;
933							find( {
934	5	100		5		1879	wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i; },
935	1					82	no_chdir => 1,
936							}, $dir );
937
938	1					70	my $prereqs = {}; my @list; my $seen = {};
	1					11
	1					33
939	1					43	for my $file ( @files ) {
940	1	50				169	my $fh = FileHandle->new($file)
941							or( error(loc("Could not open '%1' for reading: %2",
942							$file,$!)), next );
943
944	1					764	my $flag;
945	1					261	while(<$fh>) {
946							### quick hack to read past the header of the file ###
947	27	100	100			1062	last if $flag && m\|^=head\|i;
948
949							### from perldoc cpan:
950							### =head1 CONTENTS
951							### In this pod section each line obeys the format
952							### Module_Name [Version_String] [- optional text]
953	26	100				255	$flag = 1 if m\|^=head1 CONTENTS\|i;
954
955	26	100	100			456	if ($flag && /^(?!=)(\S+)\s*(\S+)?/) {
956	4					51	my $module = $1;
957	4		50			91	my $version = $2 \|\| '0';
958
959	4					67	my $obj = $cb->module_tree($module);
960
961	4	50				44	unless( $obj ) {
962	0					0	error(loc("Cannot find bundled module '%1'", $module),
963							loc("-- it does not seem to exist") );
964	0					0	next;
965							}
966
967							### make sure we list no duplicates ###
968	4	50				46	unless( $seen->{ $obj->module }++ ) {
969	4					36	push @list, $obj;
970	4					449	$prereqs->{ $module } =
971							$cb->_version_to_number( version => $version );
972							}
973							}
974							}
975							}
976
977							### store the prereqs we just found ###
978	1					93	$self->status->prereqs( $prereqs );
979
980	1					42	return @list;
981							}
982
983							=pod
984
985							=head2 $text = $self->readme
986
987							Fetches the readme belonging to this module and stores it under
988							C<< $obj->status->readme >>. Returns the readme as a string on
989							success and returns false on failure.
990
991							=cut
992
993							sub readme {
994	3			3	1	65	my $self = shift;
995	3					87	my $conf = $self->parent->configure_object;
996
997							### did we already dl the readme once? ###
998	3	100				37	return $self->status->readme() if $self->status->readme();
999
1000							### this should be core ###
1001	2	50				117	return unless can_load( modules => { FileHandle => '0.0' },
1002							verbose => 1,
1003							);
1004
1005							### get a clone of the current object, with a fresh status ###
1006	2	50				211	my $obj = $self->clone or return;
1007
1008							### munge the package name
1009	2					165	my $pkg = README->( $obj );
1010	2					25	$obj->package($pkg);
1011
1012	2					18	my $file;
1013							{ ### disable checksum fetches on readme downloads
1014
1015	2					19	my $tmp = $conf->get_conf( 'md5' );
	2					51
1016	2					46	$conf->set_conf( md5 => 0 );
1017
1018	2					85	$file = $obj->fetch;
1019
1020	2					151	$conf->set_conf( md5 => $tmp );
1021
1022	2	50				125	return unless $file;
1023							}
1024
1025							### read the file into a scalar, to store in the original object ###
1026	2					340	my $fh = new FileHandle;
1027	2	50				1283	unless( $fh->open($file) ) {
1028	0					0	error( loc( "Could not open file '%1': %2", $file, $! ) );
1029	0					0	return;
1030							}
1031
1032	2					631	my $in;
1033	2					39	{ local $/; $in = <$fh> };
	2					79
	2					9073
1034	2					204	$fh->close;
1035
1036	2					212	return $self->status->readme( $in );
1037							}
1038
1039							=pod
1040
1041							=head2 $version = $self->installed_version()
1042
1043							Returns the currently installed version of this module, if any.
1044
1045							=head2 $where = $self->installed_file()
1046
1047							Returns the location of the currently installed file of this module,
1048							if any.
1049
1050							=head2 $bool = $self->is_uptodate([version => VERSION_NUMBER])
1051
1052							Returns a boolean indicating if this module is uptodate or not.
1053
1054							=cut
1055
1056							### uptodate/installed functions
1057							{ my $map = { # hashkey, alternate rv
1058							installed_version => ['version', 0 ],
1059							installed_file => ['file', ''],
1060							is_uptodate => ['uptodate', 0 ],
1061							};
1062
1063							while( my($method, $aref) = each %$map ) {
1064							my($key,$alt_rv) = @$aref;
1065
1066	15			15		398	no strict 'refs';
	15					176
	15					309
1067							*$method = sub {
1068							### never use the @INC hooks to find installed versions of
1069							### modules -- they're just there in case they're not on the
1070							### perl install, but the user shouldn't trust them for other
1071							### modules!
1072							### XXX CPANPLUS::inc is now obsolete, so this should not
1073							### be needed anymore
1074							#local @INC = CPANPLUS::inc->original_inc;
1075
1076	23			23		246	my $self = shift;
1077
1078							### make sure check_install is not looking in %INC, as
1079							### that may contain some of our sneakily loaded modules
1080							### that aren't installed as such. -- kane
1081	23					682	local $Module::Load::Conditional::CHECK_INC_HASH = 0;
1082	23					291	my $href = check_install(
1083							module => $self->module,
1084							version => $self->version,
1085							@_,
1086							);
1087
1088	23		66			2418	return $href->{$key} \|\| $alt_rv;
1089							}
1090							}
1091							}
1092
1093
1094
1095							=pod
1096
1097							=head2 $href = $self->details()
1098
1099							Returns a hashref with key/value pairs offering more information about
1100							a particular module. For example, for C<Time::HiRes> it might look like
1101							this:
1102
1103							Author Jarkko Hietaniemi (jhi@iki.fi)
1104							Description High resolution time, sleep, and alarm
1105							Development Stage Released
1106							Interface Style plain Functions, no references used
1107							Language Used C and perl, a C compiler will be needed
1108							Package Time-HiRes-1.65.tar.gz
1109							Support Level Developer
1110							Version Installed 1.52
1111							Version on CPAN 1.65
1112
1113							=cut
1114
1115							sub details {
1116	1			1	1	11	my $self = shift;
1117	1					13	my $conf = $self->parent->configure_object();
1118	1					12	my $cb = $self->parent;
1119	1					11	my %hash = @_;
1120
1121	1		33			28	my $res = {
1122							Author => loc("%1 (%2)", $self->author->author(),
1123							$self->author->email() ),
1124							Package => $self->package,
1125							Description => $self->description \|\| loc('None given'),
1126							'Version on CPAN' => $self->version,
1127							};
1128
1129							### check if we have the module installed
1130							### if so, add version have and version on cpan
1131	1	50				124	$res->{'Version Installed'} = $self->installed_version
1132							if $self->installed_version;
1133
1134	1					11	my $i = 0;
1135	1					15	for my $item( split '', $self->dslip ) {
1136	5		66			239	$res->{ $cb->_dslip_defs->[$i]->[0] } =
1137							$cb->_dslip_defs->[$i]->[1]->{$item} \|\| loc('Unknown');
1138	5					200	$i++;
1139							}
1140
1141	1					16	return $res;
1142							}
1143
1144							=head2 @list = $self->contains()
1145
1146							Returns a list of module objects that represent the modules also
1147							present in the package of this module.
1148
1149							For example, for C<Archive::Tar> this might return:
1150
1151							Archive::Tar
1152							Archive::Tar::Constant
1153							Archive::Tar::File
1154
1155							=cut
1156
1157							sub contains {
1158	1			1	1	10	my $self = shift;
1159	1					12	my $cb = $self->parent;
1160	1					13	my $pkg = $self->package;
1161
1162	1					72	my @mods = $cb->search( type => 'package', allow => [qr/^$pkg$/] );
1163
1164	1					46	return @mods;
1165							}
1166
1167							=pod
1168
1169							=head2 @list_of_hrefs = $self->fetch_report()
1170
1171							This function queries the CPAN testers database at
1172							I<http://testers.cpan.org/> for test results of specified module
1173							objects, module names or distributions.
1174
1175							Look at L<CPANPLUS::Internals::Report::_query_report()> for details on
1176							the options you can pass and the return value to expect.
1177
1178							=cut
1179
1180							sub fetch_report {
1181	0			0	1	0	my $self = shift;
1182	0					0	my $cb = $self->parent;
1183
1184	0					0	return $cb->_query_report( @_, module => $self );
1185							}
1186
1187							=pod
1188
1189							=head2 $bool = $self->uninstall([type => [all\|man\|prog])
1190
1191							This function uninstalls the specified module object.
1192
1193							You can install 2 types of files, either C<man> pages or C<prog>ram
1194							files. Alternately you can specify C<all> to uninstall both (which
1195							is the default).
1196
1197							Returns true on success and false on failure.
1198
1199							Do note that this does an uninstall via the so-called C<.packlist>,
1200							so if you used a module installer like say, C<ports> or C<apt>, you
1201							should not use this, but use your package manager instead.
1202
1203							=cut
1204
1205							sub uninstall {
1206	1			1	1	651	my $self = shift;
1207	1					14	my $conf = $self->parent->configure_object();
1208	1					157	my %hash = @_;
1209
1210	1					12	my ($type,$verbose);
1211	1					35	my $tmpl = {
1212							type => { default => 'all', allow => [qw\|man prog all\|],
1213							store => \$type },
1214							verbose => { default => $conf->get_conf('verbose'),
1215							store => \$verbose },
1216							force => { default => $conf->get_conf('force') },
1217							};
1218
1219							### XXX add a warning here if your default install dist isn't
1220							### makefile or build -- that means you are using a package manager
1221							### and this will not do what you think!
1222
1223	1	50				17	my $args = check( $tmpl, \%hash ) or return;
1224
1225	1	50	0			17	if( $conf->get_conf('dist_type') and (
			33
1226							($conf->get_conf('dist_type') ne INSTALLER_BUILD) or
1227							($conf->get_conf('dist_type') ne INSTALLER_MM))
1228							) {
1229	0					0	msg(loc("You have a default installer type set (%1) ".
1230							"-- you should probably use that package manager to " .
1231							"uninstall modules", $conf->get_conf('dist_type')), $verbose);
1232							}
1233
1234							### check if we even have the module installed -- no point in continuing
1235							### otherwise
1236	1	50				13	unless( $self->installed_version ) {
1237	0					0	error( loc( "Module '%1' is not installed, so cannot uninstall",
1238							$self->module ) );
1239	0					0	return;
1240							}
1241
1242							### nothing to uninstall ###
1243	1	50				21	my $files = $self->files( type => $type ) or return;
1244	1	50				58	my $dirs = $self->directory_tree( type => $type ) or return;
1245	1					77	my $sudo = $conf->get_program('sudo');
1246
1247							### just in case there's no file; M::B doensn't provide .packlists yet ###
1248	1					14	my $pack = $self->packlist;
1249	1	50				62	$pack = $pack->[0]->packlist_file() if $pack;
1250
1251							### first remove the files, then the dirs if they are empty ###
1252	1					11	my $flag = 0;
1253	1					67	for my $file( @$files, $pack ) {
1254	3	50	33			3556	next unless defined $file && -f $file;
1255
1256	3					225	msg(loc("Unlinking '%1'", $file), $verbose);
1257
1258	3					276	my @cmd = ($^X, "-eunlink+q[$file]");
1259	3	50				34	unshift @cmd, $sudo if $sudo;
1260
1261	3					66	my $buffer;
1262	3	50				50	unless ( run( command => \@cmd,
1263							verbose => $verbose,
1264							buffer => \$buffer )
1265							) {
1266	0					0	error(loc("Failed to unlink '%1': '%2'",$file, $buffer));
1267	0					0	$flag++;
1268							}
1269							}
1270
1271	1					1210	for my $dir ( sort @$dirs ) {
1272	14					254	local *DIR;
1273	14	50				1205	open DIR, $dir or next;
1274	14					157	my @count = readdir(DIR);
1275	14					324	close DIR;
1276
1277	14	50				470	next unless @count == 2; # . and ..
1278
1279	0					0	msg(loc("Removing '%1'", $dir), $verbose);
1280
1281							### this fails on my win2k machines.. it indeed leaves the
1282							### dir, but it's not a critical error, since the files have
1283							### been removed. --kane
1284							#unless( rmdir $dir ) {
1285							# error( loc( "Could not remove '%1': %2", $dir, $! ) )
1286							# unless $^O eq 'MSWin32';
1287							#}
1288
1289	0					0	my @cmd = ($^X, "-ermdir+q[$dir]");
1290	0	0				0	unshift @cmd, $sudo if $sudo;
1291
1292	0					0	my $buffer;
1293	0	0				0	unless ( run( command => \@cmd,
1294							verbose => $verbose,
1295							buffer => \$buffer )
1296							) {
1297	0					0	error(loc("Failed to rmdir '%1': %2",$dir,$buffer));
1298	0					0	$flag++;
1299							}
1300							}
1301
1302	1					167	$self->status->uninstall(!$flag);
1303	1	50				72	$self->status->installed( $flag ? 1 : undef);
1304
1305	1					895	return !$flag;
1306							}
1307
1308							=pod
1309
1310							=head2 @modobj = $self->distributions()
1311
1312							Returns a list of module objects representing all releases for this
1313							module on success, false on failure.
1314
1315							=cut
1316
1317							sub distributions {
1318	1			1	1	27	my $self = shift;
1319	1					27	my %hash = @_;
1320
1321	1	50				13	my @list = $self->author->distributions( %hash, module => $self ) or return;
1322
1323							### it's another release then by the same author ###
1324	1					203	return grep { $_->package_name eq $self->package_name } @list;
	2					54
1325							}
1326
1327							=pod
1328
1329							=head2 @list = $self->files ()
1330
1331							Returns a list of files used by this module, if it is installed.
1332
1333							=cut
1334
1335							sub files {
1336	2			2	1	909	return shift->_extutils_installed( @_, method => 'files' );
1337							}
1338
1339							=pod
1340
1341							=head2 @list = $self->directory_tree ()
1342
1343							Returns a list of directories used by this module.
1344
1345							=cut
1346
1347							sub directory_tree {
1348	2			2	1	110	return shift->_extutils_installed( @_, method => 'directory_tree' );
1349							}
1350
1351							=pod
1352
1353							=head2 @list = $self->packlist ()
1354
1355							Returns the C<ExtUtils::Packlist> object for this module.
1356
1357							=cut
1358
1359							sub packlist {
1360	2			2	1	2011	return shift->_extutils_installed( @_, method => 'packlist' );
1361							}
1362
1363							=pod
1364
1365							=head2 @list = $self->validate ()
1366
1367							Returns a list of files that are missing for this modules, but
1368							are present in the .packlist file.
1369
1370							=cut
1371
1372							sub validate {
1373	1			1	1	137	return shift->_extutils_installed( method => 'validate' );
1374							}
1375
1376							### generic method to call an ExtUtils::Installed method ###
1377							sub _extutils_installed {
1378	7			7		99	my $self = shift;
1379	7					120	my $conf = $self->parent->configure_object();
1380	7					114	my %hash = @_;
1381
1382	7					66	my ($verbose,$type,$method);
1383	7					230	my $tmpl = {
1384							verbose => { default => $conf->get_conf('verbose'),
1385							store => \$verbose, },
1386							type => { default => 'all',
1387							allow => [qw\|prog man all\|],
1388							store => \$type, },
1389							method => { required => 1,
1390							store => \$method,
1391							allow => [qw\|files directory_tree packlist
1392							validate\|],
1393							},
1394							};
1395
1396	7	50				110	my $args = check( $tmpl, \%hash ) or return;
1397
1398							### old versions of cygwin + perl < 5.8 are buggy here. bail out if we
1399							### find we're being used by them
1400	7					68	{ my $err = ON_OLD_CYGWIN;
	7					86
1401	7	50				71	if($err) { error($err); return };
	0					0
	0					0
1402							}
1403
1404	7	50				305	return unless can_load(
1405							modules => { 'ExtUtils::Installed' => '0.0' },
1406							verbose => $verbose,
1407							);
1408
1409	7					464	my $inst;
1410	7	50				126	unless( $inst = ExtUtils::Installed->new() ) {
1411	0					0	error( loc("Could not create an '%1' object", 'ExtUtils::Installed' ) );
1412
1413							### in case it's being used directly... ###
1414	0					0	return;
1415							}
1416
1417
1418							{ ### EU::Installed can die =/
1419	7					191	my @files;
	7					66
1420	7					69	eval { @files = $inst->$method( $self->module, $type ) };
	7					113
1421
1422	7	50				97	if( $@ ) {
1423	0					0	chomp $@;
1424	0					0	error( loc("Could not get '%1' for '%2': %3",
1425							$method, $self->module, $@ ) );
1426	0					0	return;
1427							}
1428
1429	7	100				83	return wantarray ? @files : \@files;
1430							}
1431							}
1432
1433							=head2 $bool = $self->add_to_includepath;
1434
1435							Adds the current modules path to C<@INC> and C<$PERL5LIB>. This allows
1436							you to add the module from it's build dir to your path.
1437