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