summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/CPAN/Bundle.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPAN/Bundle.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/CPAN/Bundle.pm287
1 files changed, 287 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Bundle.pm b/Master/tlpkg/tlperl/lib/CPAN/Bundle.pm
new file mode 100644
index 00000000000..e7360f80485
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPAN/Bundle.pm
@@ -0,0 +1,287 @@
+# -*- 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;