Edit: /usr/share/perl5/CPAN/Bundle.pm (9246B)
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Bundle;
use strict;
use CPAN::Module;
@CPAN::Bundle::ISA = qw(CPAN::Module);
use vars qw(
$VERSION
);
$VERSION = "5.5";
sub look {
my $self = shift;
$CPAN::Frontend->myprint($self->as_string);
}
#-> CPAN::Bundle::undelay
sub undelay {
my $self = shift;
delete $self->{later};
for my $c ( $self->contains ) {
my $obj = CPAN::Shell->expandany($c) or next;
$obj->undelay;
}
}
# mark as dirty/clean
#-> sub CPAN::Bundle::color_cmd_tmps ;
sub color_cmd_tmps {
my($self) = shift;
my($depth) = shift || 0;
my($color) = shift || 0;
my($ancestors) = shift || [];
# a module needs to recurse to its cpan_file, a distribution needs
# to recurse into its prereq_pms, a bundle needs to recurse into its modules
return if exists $self->{incommandcolor}
&& $color==1
&& $self->{incommandcolor}==$color;
if ($depth>=$CPAN::MAX_RECURSION) {
die(CPAN::Exception::RecursiveDependency->new($ancestors));
}
# warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
for my $c ( $self->contains ) {
my $obj = CPAN::Shell->expandany($c) or next;
CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
$obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
}
# never reached code?
#if ($color==0) {
#delete $self->{badtestcnt};
#}
$self->{incommandcolor} = $color;
}
#-> sub CPAN::Bundle::as_string ;
sub as_string {
my($self) = @_;
$self->contains;
# following line must be "=", not "||=" because we have a moving target
$self->{INST_VERSION} = $self->inst_version;
return $self->SUPER::as_string;
}
#-> sub CPAN::Bundle::contains ;
sub contains {
my($self) = @_;
my($inst_file) = $self->inst_file || "";
my($id) = $self->id;
$self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
undef $inst_file;
}
unless ($inst_file) {
# Try to get at it in the cpan directory
$self->debug("no inst_file") if $CPAN::DEBUG;
my $cpan_file;
$CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
$cpan_file = $self->cpan_file;
if ($cpan_file eq "N/A") {
$CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
Maybe stale symlink? Maybe removed during session? Giving up.\n");
}
my $dist = $CPAN::META->instance('CPAN::Distribution',
$self->cpan_file);
$self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
$dist->get;
$self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
my($todir) = $CPAN::Config->{'cpan_home'};
my(@me,$from,$to,$me);
@me = split /::/, $self->id;
$me[-1] .= ".pm";
$me = File::Spec->catfile(@me);
$from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
$to = File::Spec->catfile($todir,$me);
File::Path::mkpath(File::Basename::dirname($to));
File::Copy::copy($from, $to)
or Carp::confess("Couldn't copy $from to $to: $!");
$inst_file = $to;
}
my @result;
my $fh = FileHandle->new;
local $/ = "\n";
open($fh,$inst_file) or die "Could not open '$inst_file': $!";
my $in_cont = 0;
$self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
while (<$fh>) {
$in_cont = m/^=(?!head1\s+(?i-xsm:CONTENTS))/ ? 0 :
m/^=head1\s+(?i-xsm:CONTENTS)/ ? 1 : $in_cont;
next unless $in_cont;
next if /^=/;
s/\#.*//;
next if /^\s+$/;
chomp;
push @result, (split " ", $_, 2)[0];
}
close $fh;
delete $self->{STATUS};
$self->{CONTAINS} = \@result;
$self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
unless (@result) {
$CPAN::Frontend->mywarn(qq{
The bundle file "$inst_file" may be a broken
bundlefile. It seems not to contain any bundle definition.
Please check the file and if it is bogus, please delete it.
Sorry for the inconvenience.
});
}
@result;
}
#-> sub CPAN::Bundle::find_bundle_file
# $where is in local format, $what is in unix format
sub find_bundle_file {
my($self,$where,$what) = @_;
$self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
### my $bu = File::Spec->catfile($where,$what);
### return $bu if -f $bu;
my $manifest = File::Spec->catfile($where,"MANIFEST");
unless (-f $manifest) {
require ExtUtils::Manifest;
my $cwd = CPAN::anycwd();
$self->safe_chdir($where);
ExtUtils::Manifest::mkmanifest();
$self->safe_chdir($cwd);
}
my $fh = FileHandle->new($manifest)
or Carp::croak("Couldn't open $manifest: $!");
local($/) = "\n";
my $bundle_filename = $what;
$bundle_filename =~ s|Bundle.*/||;
my $bundle_unixpath;
while (<$fh>) {
next if /^\s*\#/;
my($file) = /(\S+)/;
if ($file =~ m|\Q$what\E$|) {
$bundle_unixpath = $file;
# return File::Spec->catfile($where,$bundle_unixpath); # bad
last;
}
# retry if she managed to have no Bundle directory
$bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
}
return File::Spec->catfile($where, split /\//, $bundle_unixpath)
if $bundle_unixpath;
Carp::croak("Couldn't find a Bundle file in $where");
}
# needs to work quite differently from Module::inst_file because of
# cpan_home/Bundle/ directory and the possibility that we have
# shadowing effect. As it makes no sense to take the first in @INC for
# Bundles, we parse them all for $VERSION and take the newest.
#-> sub CPAN::Bundle::inst_file ;
sub inst_file {
my($self) = @_;
my($inst_file);
my(@me);
@me = split /::/, $self->id;
$me[-1] .= ".pm";
my($incdir,$bestv);
foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
my $parsefile = File::Spec->catfile($incdir, @me);
CPAN->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
next unless -f $parsefile;
my $have = eval { MM->parse_version($parsefile); };
if ($@) {
$CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n");
}
if (!$bestv || CPAN::Version->vgt($have,$bestv)) {
$self->{INST_FILE} = $parsefile;
$self->{INST_VERSION} = $bestv = $have;
}
}
$self->{INST_FILE};
}
#-> sub CPAN::Bundle::inst_version ;
sub inst_version {
my($self) = @_;
$self->inst_file; # finds INST_VERSION as side effect
$self->{INST_VERSION};
}
#-> sub CPAN::Bundle::rematein ;
sub rematein {
my($self,$meth) = @_;
$self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
my($id) = $self->id;
Carp::croak( "Can't $meth $id, don't have an associated bundle file. :-(\n" )
unless $self->inst_file || $self->cpan_file;
my($s,%fail);
for $s ($self->contains) {
my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
$s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
if ($type eq 'CPAN::Distribution') {
$CPAN::Frontend->mywarn(qq{
The Bundle }.$self->id.qq{ contains
explicitly a file '$s'.
Going to $meth that.
});
$CPAN::Frontend->mysleep(5);
}
# possibly noisy action:
$self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
my $obj = $CPAN::META->instance($type,$s);
$obj->{reqtype} = $self->{reqtype};
$obj->$meth();
}
}
# If a bundle contains another that contains an xs_file we have here,
# we just don't bother I suppose
#-> sub CPAN::Bundle::xs_file
sub xs_file {
return 0;
}
#-> sub CPAN::Bundle::force ;
sub fforce { shift->rematein('fforce',@_); }
#-> sub CPAN::Bundle::force ;
sub force { shift->rematein('force',@_); }
#-> sub CPAN::Bundle::notest ;
sub notest { shift->rematein('notest',@_); }
#-> sub CPAN::Bundle::get ;
sub get { shift->rematein('get',@_); }
#-> sub CPAN::Bundle::make ;
sub make { shift->rematein('make',@_); }
#-> sub CPAN::Bundle::test ;
sub test {
my $self = shift;
# $self->{badtestcnt} ||= 0;
$self->rematein('test',@_);
}
#-> sub CPAN::Bundle::install ;
sub install {
my $self = shift;
$self->rematein('install',@_);
}
#-> sub CPAN::Bundle::clean ;
sub clean { shift->rematein('clean',@_); }
#-> sub CPAN::Bundle::uptodate ;
sub uptodate {
my($self) = @_;
return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
my $c;
foreach $c ($self->contains) {
my $obj = CPAN::Shell->expandany($c);
return 0 unless $obj->uptodate;
}
return 1;
}
#-> sub CPAN::Bundle::readme ;
sub readme {
my($self) = @_;
my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
No File found for bundle } . $self->id . qq{\n}), return;
$self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
$CPAN::META->instance('CPAN::Distribution',$file)->readme;
}
1;