File Coverage

lib/CPANPLUS/Dist.pm
Criterion Covered Total %
statement 142 151 94.0
branch 43 58 74.1
condition 20 37 54.1
subroutine 15 15 100.0
pod 3 3 100.0
total 223 264 84.5


line stmt bran cond sub pod time code
1             package CPANPLUS::Dist;
2              
3 15     15   222 use strict;
  15         212  
  15         241  
4              
5              
6 15     15   238 use CPANPLUS::Error;
  15         136  
  15         262  
7 15     15   338 use CPANPLUS::Internals::Constants;
  15         143  
  15         533  
8              
9 15     15   403 use Params::Check qw[check];
  15         146  
  15         281  
10 15     15   1139 use Module::Load::Conditional qw[can_load check_install];
  15         1373  
  15         396  
11 15     15   278 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
  15         178  
  15         367  
12 15     15   310 use Object::Accessor;
  15         143  
  15         294  
13              
14             local $Params::Check::VERBOSE = 1;
15              
16             my @methods = qw[status parent];
17             for my $key ( @methods ) {
18 15     15   269     no strict 'refs';
  15         136  
  15         1398  
19                 *{__PACKAGE__."::$key"} = sub {
20 294     294   16924         my $self = shift;
21 294 100       4120         $self->{$key} = $_[0] if @_;
22 294         8426         return $self->{$key};
23                 }
24             }
25              
26             =pod
27            
28             =head1 NAME
29            
30             CPANPLUS::Dist
31            
32             =head1 SYNOPSIS
33            
34             my $dist = CPANPLUS::Dist->new(
35             format => 'build',
36             module => $modobj,
37             );
38            
39             =head1 DESCRIPTION
40            
41             C<CPANPLUS::Dist> is a base class for any type of C<CPANPLUS::Dist::>
42             modules.
43            
44             =head1 ACCESSORS
45            
46             =over 4
47            
48             =item parent()
49            
50             Returns the C<CPANPLUS::Module> object that parented this object.
51            
52             =item status()
53            
54             Returns the C<Object::Accessor> object that keeps the status for
55             this module.
56            
57             =back
58            
59             =head1 STATUS ACCESSORS
60            
61             All accessors can be accessed as follows:
62             $deb->status->ACCESSOR
63            
64             =over 4
65            
66             =item created()
67            
68             Boolean indicating whether the dist was created successfully.
69             Explicitly set to C<0> when failed, so a value of C<undef> may be
70             interpreted as C<not yet attempted>.
71            
72             =item installed()
73            
74             Boolean indicating whether the dist was installed successfully.
75             Explicitly set to C<0> when failed, so a value of C<undef> may be
76             interpreted as C<not yet attempted>.
77            
78             =item uninstalled()
79            
80             Boolean indicating whether the dist was uninstalled successfully.
81             Explicitly set to C<0> when failed, so a value of C<undef> may be
82             interpreted as C<not yet attempted>.
83            
84             =item dist()
85            
86             The location of the final distribution. This may be a file or
87             directory, depending on how your distribution plug in of choice
88             works. This will be set upon a successful create.
89            
90             =cut
91              
92             =head2 $dist = CPANPLUS::Dist->new( module => MODOBJ, [format => DIST_TYPE] );
93            
94             Create a new C<CPANPLUS::Dist> object based on the provided C<MODOBJ>.
95             The optional argument C<format> is used to indicate what type of dist
96             you would like to create (like C<makemaker> for a C<CPANPLUS::Dist::MM>
97             object, C<build> for a C<CPANPLUS::Dist::Build> object, and so on ).
98             If not provided, will default to the setting as specified by your
99             config C<dist_type>.
100            
101             Returns a C<CPANPLUS::Dist> object on success and false on failure.
102            
103             =cut
104              
105             sub new {
106 42     42 1 5887     my $self = shift;
107 42         1185     my %hash = @_;
108              
109 42         469     local $Params::Check::ALLOW_UNKNOWN = 1;
110              
111             ### first verify we got a module object ###
112 42         360     my $mod;
113 42         1090     my $tmpl = {
114                     module => { required => 1, allow => IS_MODOBJ, store => \$mod },
115                 };
116 42 50       669     check( $tmpl, \%hash ) or return;
117              
118             ### get the conf object ###
119 42         1718     my $conf = $mod->parent->configure_object();
120              
121             ### figure out what type of dist object to create ###
122 42         366     my $format;
123 42         6054     my $tmpl2 = {
124                     format => { default => $conf->get_conf('dist_type'),
125                                     allow => [ __PACKAGE__->dist_types ],
126                                     store => \$format },
127                 };
128 42 50       3705     check( $tmpl2, \%hash ) or return;
129              
130              
131 42 50       2999     unless( can_load( modules => { $format => '0.0' }, verbose => 1 ) ) {
132 0         0         error(loc("'%1' not found -- you need '%2' version '%3' or higher ".
133                                 "to detect plugins", $format, 'Module::Pluggable','2.4'));
134 0         0         return;
135                 }
136              
137             ### bless the object in the child class ###
138 42         5426     my $obj = bless { parent => $mod }, $format;
139              
140             ### check if the format is available in this environment ###
141 42 100 100     1165     if( $conf->_get_build('sanity_check') and not $obj->format_available ) {
142 1         211         error( loc( "Format '%1' is not available",$format) );
143 1         41         return;
144                 }
145              
146             ### create a status object ###
147 41         623     { my $acc = Object::Accessor->new;
  41         1163  
148 41         3646         $obj->status($acc);
149              
150             ### add minimum supported accessors
151 41         678         $acc->mk_accessors( qw[prepared created installed uninstalled
152             distdir dist] );
153                 }
154              
155             ### now initialize it or admit failure
156 41 100       773     unless( $obj->init ) {
157 1         51         error(loc("Dist initialization of '%1' failed for '%2'",
158                                 $format, $mod->module));
159 1         13         return;
160                 }
161              
162             ### return the object
163 40         1149     return $obj;
164             }
165              
166             =head2 @dists = CPANPLUS::Dist->dist_types;
167            
168             Returns a list of the CPANPLUS::Dist::* classes available
169            
170             =cut
171              
172             ### returns a list of dist_types we support
173             ### will get overridden by Module::Pluggable if loaded
174             ### XXX add support for 'plugin' dir in config as well
175             {   my $Loaded;
176                 my @Dists = (INSTALLER_MM);
177                 my @Ignore = ();
178              
179             ### backdoor method to add more dist types
180 1     1   11     sub _add_dist_types { my $self = shift; push @Dists, @_ };
  1         12  
181                 
182             ### backdoor method to exclude dist types
183 1     1   47     sub _ignore_dist_types { my $self = shift; push @Ignore, @_ };
  1         13  
184              
185             ### locally add the plugins dir to @INC, so we can find extra plugins
186             #local @INC = @INC, File::Spec->catdir(
187             # $conf->get_conf('base'),
188             # $conf->_get_build('plugins') );
189              
190             ### load any possible plugins
191                 sub dist_types {
192              
193 65 100 66 65 1 2471         if ( !$Loaded++ and check_install( module => 'Module::Pluggable',
194                                                         version => '2.4')
195                     ) {
196 3         92             require Module::Pluggable;
197              
198 3         35             my $only_re = __PACKAGE__ . '::\w+$';
199              
200 3         480             Module::Pluggable->import(
201                                         sub_name => '_dist_types',
202                                         search_path => __PACKAGE__,
203                                         only => qr/$only_re/,
204                                         except => [ INSTALLER_MM,
205                                                          INSTALLER_SAMPLE,
206                                                          INSTALLER_BASE,
207                                                     ]
208                                     );
209 3         32             my %ignore = map { $_ => $_ } @Ignore;
  1         14  
210                                     
211 3         48             push @Dists, grep { not $ignore{$_} } __PACKAGE__->_dist_types;
  4         115  
212                     }
213              
214 65         3877         return @Dists;
215                 }
216             }
217              
218             =head2 prereq_satisfied( modobj => $modobj, version => $version_spec )
219            
220             Returns true if this prereq is satisfied. Returns false if it's not.
221             Also issues an error if it seems "unsatisfiable," i.e. if it can't be
222             found on CPAN or the latest CPAN version doesn't satisfy it.
223            
224             =cut
225              
226             sub prereq_satisfied {
227 17     17 1 271     my $dist = shift;
228 17         226     my $cb = $dist->parent->parent;
229 17         257     my %hash = @_;
230               
231 17         147     my($mod,$ver);
232 17         356     my $tmpl = {
233                     version => { required => 1, store => \$ver },
234                     modobj => { required => 1, store => \$mod, allow => IS_MODOBJ },
235                 };
236                 
237 17 50       280     check( $tmpl, \%hash ) or return;
238               
239 17 50       673     return 1 if $mod->is_uptodate( version => $ver );
240               
241 17 100       260     if ( $cb->_vcmp( $ver, $mod->version ) > 0 ) {
242              
243 15         212         error(loc(
244                             "This distribution depends on %1, but the latest version".
245                             " of %2 on CPAN (%3) doesn't satisfy the specific version".
246                             " dependency (%4). You may have to resolve this dependency ".
247                             "manually.",
248                             $mod->module, $mod->module, $mod->version, $ver ));
249               
250                 }
251              
252 17         794     return;
253             }
254              
255             =head2 _resolve_prereqs
256            
257             Makes sure prerequisites are resolved
258            
259             XXX Need docs, internal use only
260            
261             =cut
262              
263             sub _resolve_prereqs {
264 20     20   2042     my $dist = shift;
265 20         438     my $self = $dist->parent;
266 20         486     my $cb = $self->parent;
267 20         788     my $conf = $cb->configure_object;
268 20         2024     my %hash = @_;
269              
270 20         296     my ($prereqs, $format, $verbose, $target, $force, $prereq_build);
271 20         772     my $tmpl = {
272             ### XXX perhaps this should not be required, since it may not be
273             ### packaged, just installed...
274             ### Let it be empty as well -- that means the $modobj->install
275             ### routine will figure it out, which is fine if we didn't have any
276             ### very specific wishes (it will even detect the favourite
277             ### dist_type).
278                     format => { required => 1, store => \$format,
279                                             allow => ['',__PACKAGE__->dist_types], },
280                     prereqs => { required => 1, default => { },
281                                             strict_type => 1, store => \$prereqs },
282                     verbose => { default => $conf->get_conf('verbose'),
283                                             store => \$verbose },
284                     force => { default => $conf->get_conf('force'),
285                                             store => \$force },
286             ### make sure allow matches with $mod->install's list
287                     target => { default => '', store => \$target,
288                                             allow => ['',qw[create ignore install]] },
289                     prereq_build => { default => 0, store => \$prereq_build },
290                 };
291              
292 20 50       413     check( $tmpl, \%hash ) or return;
293              
294             ### so there are no prereqs? then don't even bother
295 20 100       1003     return 1 unless keys %$prereqs;
296              
297             ### so you didn't provide an explicit target.
298             ### maybe your config can tell us what to do.
299 16   50     1290     $target ||= {
      66        
300                     PREREQ_ASK, TARGET_INSTALL, # we'll bail out if the user says no
301                     PREREQ_BUILD, TARGET_CREATE,
302                     PREREQ_IGNORE, TARGET_IGNORE,
303                     PREREQ_INSTALL, TARGET_INSTALL,
304                 }->{ $conf->get_conf('prereqs') } || '';
305                 
306             ### XXX BIG NASTY HACK XXX FIXME at some point.
307             ### when installing Bundle::CPANPLUS::Dependencies, we want to
308             ### install all packages matching 'cpanplus' to be installed last,
309             ### as all CPANPLUS' prereqs are being installed as well, but are
310             ### being loaded for bootstrapping purposes. This means CPANPLUS
311             ### can find them, but for example cpanplus::dist::build won't,
312             ### which gets messy FAST. So, here we sort our prereqs only IF
313             ### the parent module is Bundle::CPANPLUS::Dependencies.
314             ### Really, we would wnat some sort of sorted prereq mechanism,
315             ### but Bundle:: doesn't support it, and we flatten everything
316             ### to a hash internally. A sorted hash *might* do the trick if
317             ### we got a transparent implementation.. that would mean we would
318             ### just have to remove the 'sort' here, and all will be well
319 16         292     my @sorted_prereqs;
320                 
321             ### use regex, could either be a module name, or a package name
322 16 50       1343     if( $self->module =~ /^Bundle(::|-)CPANPLUS(::|-)Dependencies/ ) {
323 0         0         my (@first, @last);
324 0         0         for my $mod ( sort keys %$prereqs ) {
325 0 0       0             $mod =~ /CPANPLUS/
326                             ? push @last, $mod
327                             : push @first, $mod;
328                     }
329 0         0         @sorted_prereqs = (@first, @last);
330                 } else {
331 16         416         @sorted_prereqs = sort keys %$prereqs;
332                 }
333              
334             ### first, transfer this key/value pairing into a
335             ### list of module objects + desired versions
336 16         479     my @install_me;
337                 
338 16         620     for my $mod ( @sorted_prereqs ) {
339 18         486         my $version = $prereqs->{$mod};
340 18         595         my $modobj = $cb->module_tree($mod);
341              
342             #### XXX we ignore the version, and just assume that the latest
343             #### version from cpan will meet your requirements... dodgy =/
344 18 100       668         unless( $modobj ) {
345 4         245             error( loc( "No such module '%1' found on CPAN", $mod ) );
346 4         195             next;
347                     }
348              
349             ### it's not uptodate, we need to install it
350 14 50 0     445         if( !$dist->prereq_satisfied(modobj => $modobj, version => $version)) {
    0 0        
351 14         227             msg(loc("Module '%1' requires '%2' version '%3' to be installed ",
352                                 $self->module, $modobj->module, $version), $verbose );
353              
354 14         504             push @install_me, [$modobj, $version];
355              
356             ### it's not an MM or Build format, that means it's a package
357             ### manager... we'll need to install it as well, via the PM
358                     } elsif ( INSTALL_VIA_PACKAGE_MANAGER->($format) and
359                                 !$modobj->package_is_perl_core and
360                                 ($target ne TARGET_IGNORE)
361                     ) {
362 0         0             msg(loc("Module '%1' depends on '%2', may need to build a '%3' ".
363                                 "package for it as well", $self->module, $modobj->module,
364                                 $format));
365 0         0             push @install_me, [$modobj, $version];
366                     }
367                 }
368              
369              
370              
371             ### so you just want to ignore prereqs? ###
372 16 100       263     if( $target eq TARGET_IGNORE ) {
373              
374             ### but you have modules you need to install
375 2 50       166         if( @install_me ) {
376 2         184             msg(loc("Ignoring prereqs, this may mean your install will fail"),
377                             $verbose);
378 2         195             msg(loc("'%1' listed the following dependencies:", $self->module),
379                             $verbose);
380              
381 2         127             for my $aref (@install_me) {
382 2         118                 my ($mod,$version) = @$aref;
383              
384 2         108                 my $str = sprintf "\t%-35s %8s\n", $mod->module, $version;
385 2         77                 msg($str,$verbose);
386                         }
387              
388 2         160             return;
389              
390             ### ok, no problem, you have all needed prereqs anyway
391                     } else {
392 0         0             return 1;
393                     }
394                 }
395              
396 14         139     my $flag;
397 14         219     for my $aref (@install_me) {
398 12         124         my($modobj,$version) = @$aref;
399              
400             ### another prereq may have already installed this one...
401             ### so dont ask again if the module turns out to be uptodate
402             ### see bug [#11840]
403             ### if either force or prereq_build are given, the prereq
404             ### should be built anyway
405 12 50 33     159         next if (!$force and !$prereq_build) &&
      33        
406                             $dist->prereq_satisfied(modobj => $modobj, version => $version);
407              
408             ### either we're told to ignore the prereq,
409             ### or the user wants us to ask him
410 12 100 100     216         if( ( $conf->get_conf('prereqs') == PREREQ_ASK and not
411                           $cb->_callbacks->install_prerequisite->($self, $modobj)
412                         )
413                     ) {
414 1         30             msg(loc("Will not install prerequisite '%1' -- Note " .
415                                 "that the overall install may fail due to this",
416                                 $modobj->module), $verbose);
417 1         31             next;
418                     }
419              
420             ### value set and false -- means failure ###
421 11 100 66     554         if( defined $modobj->status->installed
422                         && !$modobj->status->installed
423                     ) {
424 1         60             error( loc( "Prerequisite '%1' failed to install before in " .
425                                     "this session", $modobj->module ) );
426 1         102             $flag++;
427 1         49             last;
428                     }
429              
430             ### part of core?
431 10 100       580         if( $modobj->package_is_perl_core ) {
432 1         102             error(loc("Prerequisite '%1' is perl-core (%2) -- not ".
433                                   "installing that. Aborting install",
434                                   $modobj->module, $modobj->package ) );
435 1         487             $flag++;
436 1         64             last;
437                     }
438              
439             ### circular dependency code ###
440 9   100     178         my $pending = $cb->_status->pending_prereqs || {};
441              
442             ### recursive dependency ###
443 9 100       119         if ( $pending->{ $modobj->module } ) {
444 1         88             error( loc( "Recursive dependency detected (%1) -- skipping",
445                                     $modobj->module ) );
446 1         123             next;
447                     }
448              
449             ### register this dependency as pending ###
450 8         165         $pending->{ $modobj->module } = $modobj;
451 8         107         $cb->_status->pending_prereqs( $pending );
452              
453              
454             ### call $modobj->install rather than doing
455             ### CPANPLUS::Dist->new and the like ourselves,
456             ### since ->install will take care of fetch &&
457             ### extract as well
458 8   50     109         my $pa = $dist->status->_prepare_args || {};
459 8   50     93         my $ca = $dist->status->_create_args || {};
460 8   50     102         my $ia = $dist->status->_install_args || {};
461              
462 8 100       350         unless( $modobj->install( %$pa, %$ca, %$ia,
463                                                 force => $force,
464                                                 verbose => $verbose,
465                                                 format => $format,
466                                                 target => $target )
467                     ) {
468 3         43             error(loc("Failed to install '%1' as prerequisite " .
469                                   "for '%2'", $modobj->module, $self->module ) );
470 3         155             $flag++;
471                     }
472              
473             ### unregister the pending dependency ###
474 8         122         $pending->{ $modobj->module } = 0;
475 8         135         $cb->_status->pending_prereqs( $pending );
476              
477 8 100       266         last if $flag;
478              
479             ### don't want us to install? ###
480 5 100       495         if( $target ne TARGET_INSTALL ) {
481 2 50       112             my $dir = $modobj->status->extract
482                                     or error(loc("No extraction dir for '%1' found ".
483                                                  "-- weird", $modobj->module));
484              
485 2         183             $modobj->add_to_includepath();
486                         
487 2         173             next;
488                     }
489                 }
490              
491             ### reset the $prereqs iterator, in case we bailed out early ###
492 14         318     keys %$prereqs;
493              
494 14 100       2120     return 1 unless $flag;
495 5         939     return;
496             }
497              
498             1;
499              
500             # Local variables:
501             # c-indentation-style: bsd
502             # c-basic-offset: 4
503             # indent-tabs-mode: nil
504             # End:
505             # vim: expandtab shiftwidth=4:
506