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