Commit | Line | Data |
---|---|---|
f9916dde A |
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; |