lib/CPAN/Bundle.pm

   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;