File Coverage

blib/lib/CPAN/Bundle.pm
Criterion Covered Total %
statement 9 171 5.2
branch 0 94 0.0
condition 0 25 0.0
subroutine 3 23 13.0
pod 0 20 0.0
total 12 333 3.6


line stmt bran cond sub pod time code
1             # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2             # vim: ts=4 sts=4 sw=4:
3             package CPAN::Bundle;
4 13     13   97 use strict;
  13         28  
  13         392  
5 13     13   6530 use CPAN::Module;
  13         41  
  13         607  
6             @CPAN::Bundle::ISA = qw(CPAN::Module);
7              
8 13         31252 use vars qw(
9             $VERSION
10 13     13   89 );
  13         37  
11             $VERSION = "5.5005";
12              
13             sub look {
14 0     0 0   my $self = shift;
15 0           $CPAN::Frontend->myprint($self->as_string);
16             }
17              
18             #-> CPAN::Bundle::undelay
19             sub undelay {
20 0     0 0   my $self = shift;
21 0           delete $self->{later};
22 0           for my $c ( $self->contains ) {
23 0 0         my $obj = CPAN::Shell->expandany($c) or next;
24 0 0         if ($obj->id eq $self->id){
25 0           my $id = $obj->id;
26 0           $CPAN::Frontend->mywarn("$id seems to contain itself, skipping\n");
27 0           next;
28             }
29 0           $obj->undelay;
30             }
31             }
32              
33             # mark as dirty/clean
34             #-> sub CPAN::Bundle::color_cmd_tmps ;
35             sub color_cmd_tmps {
36 0     0 0   my($self) = shift;
37 0   0       my($depth) = shift || 0;
38 0   0       my($color) = shift || 0;
39 0   0       my($ancestors) = shift || [];
40             # a module needs to recurse to its cpan_file, a distribution needs
41             # to recurse into its prereq_pms, a bundle needs to recurse into its modules
42              
43             return if exists $self->{incommandcolor}
44             && $color==1
45 0 0 0       && $self->{incommandcolor}==$color;
      0        
46 0 0         if ($depth>=$CPAN::MAX_RECURSION) {
47 0           my $e = CPAN::Exception::RecursiveDependency->new($ancestors);
48 0 0         if ($e->is_resolvable) {
49 0           return $self->{incommandcolor}=2;
50             } else {
51 0           die $e;
52             }
53             }
54             # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
55              
56 0           for my $c ( $self->contains ) {
57 0 0         my $obj = CPAN::Shell->expandany($c) or next;
58 0 0         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
59 0           $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
60             }
61             # never reached code?
62             #if ($color==0) {
63             #delete $self->{badtestcnt};
64             #}
65 0           $self->{incommandcolor} = $color;
66             }
67              
68             #-> sub CPAN::Bundle::as_string ;
69             sub as_string {
70 0     0 0   my($self) = @_;
71 0           $self->contains;
72             # following line must be "=", not "||=" because we have a moving target
73 0           $self->{INST_VERSION} = $self->inst_version;
74 0           return $self->SUPER::as_string;
75             }
76              
77             #-> sub CPAN::Bundle::contains ;
78             sub contains {
79 0     0 0   my($self) = @_;
80 0   0       my($inst_file) = $self->inst_file || "";
81 0           my($id) = $self->id;
82 0 0         $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
83 0 0 0       if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
84 0           undef $inst_file;
85             }
86 0 0         unless ($inst_file) {
87             # Try to get at it in the cpan directory
88 0 0         $self->debug("no inst_file") if $CPAN::DEBUG;
89 0           my $cpan_file;
90 0 0         $CPAN::Frontend->mydie("I don't know a bundle with ID '$id'\n") unless
91             $cpan_file = $self->cpan_file;
92 0 0         if ($cpan_file eq "N/A") {
93 0           $CPAN::Frontend->mywarn("Bundle '$id' not found on disk and not on CPAN. Maybe stale symlink? Maybe removed during session?\n");
94 0           return;
95             }
96 0           my $dist = $CPAN::META->instance('CPAN::Distribution',
97             $self->cpan_file);
98 0 0         $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
99 0           $dist->get;
100 0 0         $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
101 0           my($todir) = $CPAN::Config->{'cpan_home'};
102 0           my(@me,$from,$to,$me);
103 0           @me = split /::/, $self->id;
104 0           $me[-1] .= ".pm";
105 0           $me = File::Spec->catfile(@me);
106 0           my $build_dir;
107 0 0         unless ($build_dir = $dist->{build_dir}) {
108 0           $CPAN::Frontend->mywarn("Warning: cannot determine bundle content without a build_dir.\n");
109 0           return;
110             }
111 0           $from = $self->find_bundle_file($build_dir,join('/',@me));
112 0           $to = File::Spec->catfile($todir,$me);
113 0           File::Path::mkpath(File::Basename::dirname($to));
114 0 0         File::Copy::copy($from, $to)
115             or Carp::confess("Couldn't copy $from to $to: $!");
116 0           $inst_file = $to;
117             }
118 0           my @result;
119 0           my $fh = FileHandle->new;
120 0           local $/ = "\n";
121 0 0         open($fh,$inst_file) or die "Could not open '$inst_file': $!";
122 0           my $in_cont = 0;
123 0 0         $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
124 0           while (<$fh>) {
125 0 0         $in_cont = m/^=(?!head1\s+(?i-xsm:CONTENTS))/ ? 0 :
    0          
126             m/^=head1\s+(?i-xsm:CONTENTS)/ ? 1 : $in_cont;
127 0 0         next unless $in_cont;
128 0 0         next if /^=/;
129 0           s/\#.*//;
130 0 0         next if /^\s+$/;
131 0           chomp;
132 0           push @result, (split " ", $_, 2)[0];
133             }
134 0           close $fh;
135 0           delete $self->{STATUS};
136 0           $self->{CONTAINS} = \@result;
137 0 0         $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
138 0 0         unless (@result) {
139 0           $CPAN::Frontend->mywarn(qq{
140             The bundle file "$inst_file" may be a broken
141             bundlefile. It seems not to contain any bundle definition.
142             Please check the file and if it is bogus, please delete it.
143             Sorry for the inconvenience.
144             });
145             }
146 0           @result;
147             }
148              
149             #-> sub CPAN::Bundle::find_bundle_file
150             # $where is in local format, $what is in unix format
151             sub find_bundle_file {
152 0     0 0   my($self,$where,$what) = @_;
153 0 0         $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
154             ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
155             ### my $bu = File::Spec->catfile($where,$what);
156             ### return $bu if -f $bu;
157 0           my $manifest = File::Spec->catfile($where,"MANIFEST");
158 0 0         unless (-f $manifest) {
159 0           require ExtUtils::Manifest;
160 0           my $cwd = CPAN::anycwd();
161 0           $self->safe_chdir($where);
162 0           ExtUtils::Manifest::mkmanifest();
163 0           $self->safe_chdir($cwd);
164             }
165 0 0         my $fh = FileHandle->new($manifest)
166             or Carp::croak("Couldn't open $manifest: $!");
167 0           local($/) = "\n";
168 0           my $bundle_filename = $what;
169 0           $bundle_filename =~ s|Bundle.*/||;
170 0           my $bundle_unixpath;
171 0           while (<$fh>) {
172 0 0         next if /^\s*\#/;
173 0           my($file) = /(\S+)/;
174 0 0         if ($file =~ m|\Q$what\E$|) {
175 0           $bundle_unixpath = $file;
176             # return File::Spec->catfile($where,$bundle_unixpath); # bad
177 0           last;
178             }
179             # retry if she managed to have no Bundle directory
180 0 0         $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
181             }
182 0 0         return File::Spec->catfile($where, split /\//, $bundle_unixpath)
183             if $bundle_unixpath;
184 0           Carp::croak("Couldn't find a Bundle file in $where");
185             }
186              
187             # needs to work quite differently from Module::inst_file because of
188             # cpan_home/Bundle/ directory and the possibility that we have
189             # shadowing effect. As it makes no sense to take the first in @INC for
190             # Bundles, we parse them all for $VERSION and take the newest.
191              
192             #-> sub CPAN::Bundle::inst_file ;
193             sub inst_file {
194 0     0 0   my($self) = @_;
195 0           my($inst_file);
196             my(@me);
197 0           @me = split /::/, $self->id;
198 0           $me[-1] .= ".pm";
199 0           my($incdir,$bestv);
200 0           foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
201 0           my $parsefile = File::Spec->catfile($incdir, @me);
202 0 0         CPAN->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
203 0 0         next unless -f $parsefile;
204 0           my $have = eval { MM->parse_version($parsefile); };
  0            
205 0 0         if ($@) {
206 0           $CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n");
207             }
208 0 0 0       if (!$bestv || CPAN::Version->vgt($have,$bestv)) {
209 0           $self->{INST_FILE} = $parsefile;
210 0           $self->{INST_VERSION} = $bestv = $have;
211             }
212             }
213 0           $self->{INST_FILE};
214             }
215              
216             #-> sub CPAN::Bundle::inst_version ;
217             sub inst_version {
218 0     0 0   my($self) = @_;
219 0           $self->inst_file; # finds INST_VERSION as side effect
220 0           $self->{INST_VERSION};
221             }
222              
223             #-> sub CPAN::Bundle::rematein ;
224             sub rematein {
225 0     0 0   my($self,$meth) = @_;
226 0 0         $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
227 0           my($id) = $self->id;
228 0 0 0       Carp::croak( "Can't $meth $id, don't have an associated bundle file. :-(\n" )
229             unless $self->inst_file || $self->cpan_file;
230 0           my($s,%fail);
231 0           for $s ($self->contains) {
232 0 0         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
    0          
233             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
234 0 0         if ($type eq 'CPAN::Distribution') {
235 0           $CPAN::Frontend->mywarn(qq{
236             The Bundle }.$self->id.qq{ contains
237             explicitly a file '$s'.
238             Going to $meth that.
239             });
240 0           $CPAN::Frontend->mysleep(5);
241             }
242             # possibly noisy action:
243 0 0         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
244 0           my $obj = $CPAN::META->instance($type,$s);
245 0           $obj->{reqtype} = $self->{reqtype};
246 0   0       $obj->{viabundle} ||= { id => $id, reqtype => $self->{reqtype}, optional => !$self->{mandatory}};
247             # $obj->$meth();
248             # XXX should optional be based on whether bundle was optional? -- xdg, 2012-04-01
249             # A: Sure, what could demand otherwise? --andk, 2013-11-25
250 0           CPAN::Queue->queue_item(qmod => $obj->id, reqtype => $self->{reqtype}, optional => !$self->{mandatory});
251             }
252             }
253              
254             # If a bundle contains another that contains an xs_file we have here,
255             # we just don't bother I suppose
256             #-> sub CPAN::Bundle::xs_file
257             sub xs_file {
258 0     0 0   return 0;
259             }
260              
261             #-> sub CPAN::Bundle::force ;
262 0     0 0   sub fforce { shift->rematein('fforce',@_); }
263             #-> sub CPAN::Bundle::force ;
264 0     0 0   sub force { shift->rematein('force',@_); }
265             #-> sub CPAN::Bundle::notest ;
266 0     0 0   sub notest { shift->rematein('notest',@_); }
267             #-> sub CPAN::Bundle::get ;
268 0     0 0   sub get { shift->rematein('get',@_); }
269             #-> sub CPAN::Bundle::make ;
270 0     0 0   sub make { shift->rematein('make',@_); }
271             #-> sub CPAN::Bundle::test ;
272             sub test {
273 0     0 0   my $self = shift;
274             # $self->{badtestcnt} ||= 0;
275 0           $self->rematein('test',@_);
276             }
277             #-> sub CPAN::Bundle::install ;
278             sub install {
279 0     0 0   my $self = shift;
280 0           $self->rematein('install',@_);
281             }
282             #-> sub CPAN::Bundle::clean ;
283 0     0 0   sub clean { shift->rematein('clean',@_); }
284              
285             #-> sub CPAN::Bundle::uptodate ;
286             sub uptodate {
287 0     0 0   my($self) = @_;
288 0 0         return 0 unless $self->SUPER::uptodate; # we must have the current Bundle def
289 0           my $c;
290 0           foreach $c ($self->contains) {
291 0           my $obj = CPAN::Shell->expandany($c);
292 0 0         return 0 unless $obj->uptodate;
293             }
294 0           return 1;
295             }
296              
297             #-> sub CPAN::Bundle::readme ;
298             sub readme {
299 0     0 0   my($self) = @_;
300 0 0         my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
301             No File found for bundle } . $self->id . qq{\n}), return;
302 0 0         $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
303 0           $CPAN::META->instance('CPAN::Distribution',$file)->readme;
304             }
305              
306             1;