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