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