summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
committerNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
commite0c6872cf40896c7be36b11dcc744620f10adf1d (patch)
tree60335e10d2f4354b0674ec22d7b53f0f8abee672 /systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN
Initial commit
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN')
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/API/HOWTO.pod44
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Author.pm236
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Bundle.pm300
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/CacheMgr.pm249
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Complete.pm175
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Debug.pm83
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/DeferredCode.pm16
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Distribution.pm4476
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Distroprefs.pm481
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Distrostatus.pm45
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Exception/RecursiveDependency.pm113
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Exception/blocked_urllist.pm46
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Exception/yaml_not_installed.pm23
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Exception/yaml_process_error.pm53
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/FTP.pm1146
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/FTP/netrc.pm62
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/FirstTime.pm2117
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/HTTP/Client.pm254
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/HTTP/Credentials.pm91
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/HandleConfig.pm800
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Index.pm626
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/InfoObj.pm224
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Kwalify.pm136
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Kwalify/distroprefs.dd150
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Kwalify/distroprefs.yml92
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/LWP/UserAgent.pm62
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta.pm1176
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Converter.pm1657
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Feature.pm153
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History.pm320
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_0.pod247
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_1.pod309
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_2.pod712
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_3.pod741
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_4.pod765
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Merge.pm351
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Prereqs.pm481
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Requirements.pm1194
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Spec.pm1244
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Validator.pm1214
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/YAML.pm951
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Mirrors.pm589
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Module.pm702
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Nox.pm52
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Plugin.pm145
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Plugin/Specfile.pm258
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Prompt.pm29
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Queue.pm223
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Shell.pm2071
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Tarzip.pm474
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/URL.pm31
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Version.pm177
52 files changed, 28366 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/API/HOWTO.pod b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/API/HOWTO.pod
new file mode 100644
index 0000000000..e65a4bc931
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/API/HOWTO.pod
@@ -0,0 +1,44 @@
+=head1 NAME
+
+CPAN::API::HOWTO - a recipe book for programming with CPAN.pm
+
+=head1 RECIPES
+
+All of these recipes assume that you have put "use CPAN" at the top of
+your program.
+
+=head2 What distribution contains a particular module?
+
+ my $distribution = CPAN::Shell->expand(
+ "Module", "Data::UUID"
+ )->distribution()->pretty_id();
+
+This returns a string of the form "AUTHORID/TARBALL". If you want the
+full path and filename to this distribution on a CPAN mirror, then it is
+C<.../authors/id/A/AU/AUTHORID/TARBALL>.
+
+=head2 What modules does a particular distribution contain?
+
+ CPAN::Index->reload();
+ my @modules = CPAN::Shell->expand(
+ "Distribution", "JHI/Graph-0.83.tar.gz"
+ )->containsmods();
+
+You may also refer to a distribution in the form A/AU/AUTHORID/TARBALL.
+
+=head1 SEE ALSO
+
+the main CPAN.pm documentation
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=head1 AUTHOR
+
+David Cantrell
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Author.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Author.pm
new file mode 100644
index 0000000000..572f3ab31d
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Author.pm
@@ -0,0 +1,236 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Author;
+use strict;
+
+use CPAN::InfoObj;
+@CPAN::Author::ISA = qw(CPAN::InfoObj);
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5002";
+
+package CPAN::Author;
+use strict;
+
+#-> sub CPAN::Author::force
+sub force {
+ my $self = shift;
+ $self->{force}++;
+}
+
+#-> sub CPAN::Author::force
+sub unforce {
+ my $self = shift;
+ delete $self->{force};
+}
+
+#-> sub CPAN::Author::id
+sub id {
+ my $self = shift;
+ my $id = $self->{ID};
+ $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
+ $id;
+}
+
+#-> sub CPAN::Author::as_glimpse ;
+sub as_glimpse {
+ my($self) = @_;
+ my(@m);
+ my $class = ref($self);
+ $class =~ s/^CPAN:://;
+ push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
+ $class,
+ $self->{ID},
+ $self->fullname,
+ $self->email);
+ join "", @m;
+}
+
+#-> sub CPAN::Author::fullname ;
+sub fullname {
+ shift->ro->{FULLNAME};
+}
+*name = \&fullname;
+
+#-> sub CPAN::Author::email ;
+sub email { shift->ro->{EMAIL}; }
+
+#-> sub CPAN::Author::ls ;
+sub ls {
+ my $self = shift;
+ my $glob = shift || "";
+ my $silent = shift || 0;
+ my $id = $self->id;
+
+ # adapted from CPAN::Distribution::verifyCHECKSUM ;
+ my(@csf); # chksumfile
+ @csf = $self->id =~ /(.)(.)(.*)/;
+ $csf[1] = join "", @csf[0,1];
+ $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
+ my(@dl);
+ @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
+ unless (grep {$_->[2] eq $csf[1]} @dl) {
+ $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
+ return;
+ }
+ @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
+ unless (grep {$_->[2] eq $csf[2]} @dl) {
+ $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
+ return;
+ }
+ @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
+ if ($glob) {
+ if ($CPAN::META->has_inst("Text::Glob")) {
+ $glob =~ s|/$|/*|;
+ my $rglob = Text::Glob::glob_to_regex($glob);
+ CPAN->debug("glob[$glob]rglob[$rglob]dl[@dl]") if $CPAN::DEBUG;
+ my @tmpdl = grep { $_->[2] =~ /$rglob/ } @dl;
+ if (1==@tmpdl && $tmpdl[0][0]==0) {
+ $rglob = Text::Glob::glob_to_regex("$glob/*");
+ @dl = grep { $_->[2] =~ /$rglob/ } @dl;
+ } else {
+ @dl = @tmpdl;
+ }
+ CPAN->debug("rglob[$rglob]dl[@dl]") if $CPAN::DEBUG;
+ } else {
+ $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
+ }
+ }
+ unless ($silent >= 2) {
+ $CPAN::Frontend->myprint
+ (
+ join "",
+ map {
+ sprintf
+ (
+ "%8d %10s %s/%s%s\n",
+ $_->[0],
+ $_->[1],
+ $id,
+ $_->[2],
+ 0==$_->[0]?"/":"",
+ )
+ } sort { $a->[2] cmp $b->[2] } @dl
+ );
+ }
+ @dl;
+}
+
+# returns an array of arrays, the latter contain (size,mtime,filename)
+#-> sub CPAN::Author::dir_listing ;
+sub dir_listing {
+ my $self = shift;
+ my $chksumfile = shift;
+ my $recursive = shift;
+ my $may_ftp = shift;
+
+ my $lc_want =
+ File::Spec->catfile($CPAN::Config->{keep_source_where},
+ "authors", "id", @$chksumfile);
+
+ my $fh;
+
+ CPAN->debug("chksumfile[@$chksumfile]recursive[$recursive]may_ftp[$may_ftp]") if $CPAN::DEBUG;
+ # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
+ # hazard. (Without GPG installed they are not that much better,
+ # though.)
+ $fh = FileHandle->new;
+ if (open($fh, $lc_want)) {
+ my $line = <$fh>; close $fh;
+ unlink($lc_want) unless $line =~ /PGP/;
+ }
+
+ local($") = "/";
+ # connect "force" argument with "index_expire".
+ my $force = $self->{force};
+ if (my @stat = stat $lc_want) {
+ $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
+ }
+ my $lc_file;
+ if ($may_ftp) {
+ $lc_file = eval {
+ CPAN::FTP->localize
+ (
+ "authors/id/@$chksumfile",
+ $lc_want,
+ $force,
+ );
+ };
+ unless ($lc_file) {
+ $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
+ $chksumfile->[-1] .= ".gz";
+ $lc_file = eval {
+ CPAN::FTP->localize
+ ("authors/id/@$chksumfile",
+ "$lc_want.gz",
+ 1,
+ );
+ };
+ if ($lc_file) {
+ $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
+ eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
+ } else {
+ return;
+ }
+ }
+ } else {
+ $lc_file = $lc_want;
+ # we *could* second-guess and if the user has a file: URL,
+ # then we could look there. But on the other hand, if they do
+ # have a file: URL, why did they choose to set
+ # $CPAN::Config->{show_upload_date} to false?
+ }
+
+ # adapted from CPAN::Distribution::CHECKSUM_check_file ;
+ $fh = FileHandle->new;
+ my($cksum);
+ if (open $fh, $lc_file) {
+ local($/);
+ my $eval = <$fh>;
+ $eval =~ s/\015?\012/\n/g;
+ close $fh;
+ my($compmt) = Safe->new();
+ $cksum = $compmt->reval($eval);
+ if ($@) {
+ rename $lc_file, "$lc_file.bad";
+ Carp::confess($@) if $@;
+ }
+ } elsif ($may_ftp) {
+ Carp::carp ("Could not open '$lc_file' for reading.");
+ } else {
+ # Maybe should warn: "You may want to set show_upload_date to a true value"
+ return;
+ }
+ my(@result,$f);
+ for $f (sort keys %$cksum) {
+ if (exists $cksum->{$f}{isdir}) {
+ if ($recursive) {
+ my(@dir) = @$chksumfile;
+ pop @dir;
+ push @dir, $f, "CHECKSUMS";
+ push @result, [ 0, "-", $f ];
+ push @result, map {
+ [$_->[0], $_->[1], "$f/$_->[2]"]
+ } $self->dir_listing(\@dir,1,$may_ftp);
+ } else {
+ push @result, [ 0, "-", $f ];
+ }
+ } else {
+ push @result, [
+ ($cksum->{$f}{"size"}||0),
+ $cksum->{$f}{"mtime"}||"---",
+ $f
+ ];
+ }
+ }
+ @result;
+}
+
+#-> sub CPAN::Author::reports
+sub reports {
+ $CPAN::Frontend->mywarn("reports on authors not implemented.
+Please file a bugreport if you need this.\n");
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Bundle.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Bundle.pm
new file mode 100644
index 0000000000..3b4e93d8bf
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Bundle.pm
@@ -0,0 +1,300 @@
+# -*- 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.5003";
+
+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;
+ if ($obj->id eq $self->id){
+ my $id = $obj->id;
+ $CPAN::Frontend->mywarn("$id seems to contain itself, skipping\n");
+ 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) {
+ my $e = CPAN::Exception::RecursiveDependency->new($ancestors);
+ if ($e->is_resolvable) {
+ return $self->{incommandcolor}=2;
+ } else {
+ die $e;
+ }
+ }
+ # 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();
+ # XXX should optional be based on whether bundle was optional? -- xdg, 2012-04-01
+ # A: Sure, what could demand otherwise? --andk, 2013-11-25
+ CPAN::Queue->queue_item(qmod => $obj->id, reqtype => $self->{reqtype}, optional => !$self->{mandatory});
+ }
+}
+
+# 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 must 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;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/CacheMgr.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/CacheMgr.pm
new file mode 100644
index 0000000000..144efd62b3
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/CacheMgr.pm
@@ -0,0 +1,249 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::CacheMgr;
+use strict;
+use CPAN::InfoObj;
+@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
+use Cwd qw(chdir);
+use File::Find;
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5002";
+
+package CPAN::CacheMgr;
+use strict;
+
+#-> sub CPAN::CacheMgr::as_string ;
+sub as_string {
+ eval { require Data::Dumper };
+ if ($@) {
+ return shift->SUPER::as_string;
+ } else {
+ return Data::Dumper::Dumper(shift);
+ }
+}
+
+#-> sub CPAN::CacheMgr::cachesize ;
+sub cachesize {
+ shift->{DU};
+}
+
+#-> sub CPAN::CacheMgr::tidyup ;
+sub tidyup {
+ my($self) = @_;
+ return unless $CPAN::META->{LOCK};
+ return unless -d $self->{ID};
+ my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}};
+ for my $current (0..$#toremove) {
+ my $toremove = $toremove[$current];
+ $CPAN::Frontend->myprint(sprintf(
+ "DEL(%d/%d): %s \n",
+ $current+1,
+ scalar @toremove,
+ $toremove,
+ )
+ );
+ return if $CPAN::Signal;
+ $self->_clean_cache($toremove);
+ return if $CPAN::Signal;
+ }
+ $self->{FIFO} = [];
+}
+
+#-> sub CPAN::CacheMgr::dir ;
+sub dir {
+ shift->{ID};
+}
+
+#-> sub CPAN::CacheMgr::entries ;
+sub entries {
+ my($self,$dir) = @_;
+ return unless defined $dir;
+ $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
+ $dir ||= $self->{ID};
+ my($cwd) = CPAN::anycwd();
+ chdir $dir or Carp::croak("Can't chdir to $dir: $!");
+ my $dh = DirHandle->new(File::Spec->curdir)
+ or Carp::croak("Couldn't opendir $dir: $!");
+ my(@entries);
+ for ($dh->read) {
+ next if $_ eq "." || $_ eq "..";
+ if (-f $_) {
+ push @entries, File::Spec->catfile($dir,$_);
+ } elsif (-d _) {
+ push @entries, File::Spec->catdir($dir,$_);
+ } else {
+ $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
+ }
+ }
+ chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
+ sort { -M $a <=> -M $b} @entries;
+}
+
+#-> sub CPAN::CacheMgr::disk_usage ;
+sub disk_usage {
+ my($self,$dir,$fast) = @_;
+ return if exists $self->{SIZE}{$dir};
+ return if $CPAN::Signal;
+ my($Du) = 0;
+ if (-e $dir) {
+ if (-d $dir) {
+ unless (-x $dir) {
+ unless (chmod 0755, $dir) {
+ $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
+ "permission to change the permission; cannot ".
+ "estimate disk usage of '$dir'\n");
+ $CPAN::Frontend->mysleep(5);
+ return;
+ }
+ }
+ } elsif (-f $dir) {
+ # nothing to say, no matter what the permissions
+ }
+ } else {
+ $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
+ return;
+ }
+ if ($fast) {
+ $Du = 0; # placeholder
+ } else {
+ find(
+ sub {
+ $File::Find::prune++ if $CPAN::Signal;
+ return if -l $_;
+ if ($^O eq 'MacOS') {
+ require Mac::Files;
+ my $cat = Mac::Files::FSpGetCatInfo($_);
+ $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
+ } else {
+ if (-d _) {
+ unless (-x _) {
+ unless (chmod 0755, $_) {
+ $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
+ "the permission to change the permission; ".
+ "can only partially estimate disk usage ".
+ "of '$_'\n");
+ $CPAN::Frontend->mysleep(5);
+ return;
+ }
+ }
+ } else {
+ $Du += (-s _);
+ }
+ }
+ },
+ $dir
+ );
+ }
+ return if $CPAN::Signal;
+ $self->{SIZE}{$dir} = $Du/1024/1024;
+ unshift @{$self->{FIFO}}, $dir;
+ $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
+ $self->{DU} += $Du/1024/1024;
+ $self->{DU};
+}
+
+#-> sub CPAN::CacheMgr::_clean_cache ;
+sub _clean_cache {
+ my($self,$dir) = @_;
+ return unless -e $dir;
+ unless (File::Spec->canonpath(File::Basename::dirname($dir))
+ eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
+ $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
+ "will not remove\n");
+ $CPAN::Frontend->mysleep(5);
+ return;
+ }
+ $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
+ if $CPAN::DEBUG;
+ File::Path::rmtree($dir);
+ my $id_deleted = 0;
+ if ($dir !~ /\.yml$/ && -f "$dir.yml") {
+ my $yaml_module = CPAN::_yaml_module();
+ if ($CPAN::META->has_inst($yaml_module)) {
+ my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); };
+ if ($@) {
+ $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
+ unlink "$dir.yml" or
+ $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
+ return;
+ } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
+ $CPAN::META->delete("CPAN::Distribution", $id);
+
+ # XXX we should restore the state NOW, otherwise this
+ # distro does not exist until we read an index. BUG ALERT(?)
+
+ # $CPAN::Frontend->mywarn (" +++\n");
+ $id_deleted++;
+ }
+ }
+ unlink "$dir.yml"; # may fail
+ unless ($id_deleted) {
+ CPAN->debug("no distro found associated with '$dir'");
+ }
+ }
+ $self->{DU} -= $self->{SIZE}{$dir};
+ delete $self->{SIZE}{$dir};
+}
+
+#-> sub CPAN::CacheMgr::new ;
+sub new {
+ my($class,$phase) = @_;
+ $phase ||= "atstart";
+ my $time = time;
+ my($debug,$t2);
+ $debug = "";
+ my $self = {
+ ID => $CPAN::Config->{build_dir},
+ MAX => $CPAN::Config->{'build_cache'},
+ SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
+ DU => 0
+ };
+ $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
+ unless $self->{SCAN} =~ /never|atstart|atexit/;
+ File::Path::mkpath($self->{ID});
+ my $dh = DirHandle->new($self->{ID});
+ bless $self, $class;
+ $self->scan_cache($phase);
+ $t2 = time;
+ $debug .= "timing of CacheMgr->new: ".($t2 - $time);
+ $time = $t2;
+ CPAN->debug($debug) if $CPAN::DEBUG;
+ $self;
+}
+
+#-> sub CPAN::CacheMgr::scan_cache ;
+sub scan_cache {
+ my ($self, $phase) = @_;
+ $phase = '' unless defined $phase;
+ return unless $phase eq $self->{SCAN};
+ return unless $CPAN::META->{LOCK};
+ $CPAN::Frontend->myprint(
+ sprintf("Scanning cache %s for sizes\n",
+ $self->{ID}));
+ my $e;
+ my @entries = $self->entries($self->{ID});
+ my $i = 0;
+ my $painted = 0;
+ for $e (@entries) {
+ my $symbol = ".";
+ if ($self->{DU} > $self->{MAX}) {
+ $symbol = "-";
+ $self->disk_usage($e,1);
+ } else {
+ $self->disk_usage($e);
+ }
+ $i++;
+ while (($painted/76) < ($i/@entries)) {
+ $CPAN::Frontend->myprint($symbol);
+ $painted++;
+ }
+ return if $CPAN::Signal;
+ }
+ $CPAN::Frontend->myprint("DONE\n");
+ $self->tidyup;
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Complete.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Complete.pm
new file mode 100644
index 0000000000..588e6e6c2c
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Complete.pm
@@ -0,0 +1,175 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Complete;
+use strict;
+@CPAN::Complete::ISA = qw(CPAN::Debug);
+# Q: where is the "How do I add a new command" HOWTO?
+# A: git log -p -1 355c44e9caaec857e4b12f51afb96498833c3e36 where andk added the report command
+@CPAN::Complete::COMMANDS = sort qw(
+ ? ! a b d h i m o q r u
+ autobundle
+ bye
+ clean
+ cvs_import
+ dump
+ exit
+ failed
+ force
+ fforce
+ hosts
+ install
+ install_tested
+ is_tested
+ look
+ ls
+ make
+ mkmyconfig
+ notest
+ perldoc
+ quit
+ readme
+ recent
+ recompile
+ reload
+ report
+ reports
+ scripts
+ smoke
+ test
+ upgrade
+);
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5001";
+
+package CPAN::Complete;
+use strict;
+
+sub gnu_cpl {
+ my($text, $line, $start, $end) = @_;
+ my(@perlret) = cpl($text, $line, $start);
+ # find longest common match. Can anybody show me how to peruse
+ # T::R::Gnu to have this done automatically? Seems expensive.
+ return () unless @perlret;
+ my($newtext) = $text;
+ for (my $i = length($text)+1;;$i++) {
+ last unless length($perlret[0]) && length($perlret[0]) >= $i;
+ my $try = substr($perlret[0],0,$i);
+ my @tries = grep {substr($_,0,$i) eq $try} @perlret;
+ # warn "try[$try]tries[@tries]";
+ if (@tries == @perlret) {
+ $newtext = $try;
+ } else {
+ last;
+ }
+ }
+ ($newtext,@perlret);
+}
+
+#-> sub CPAN::Complete::cpl ;
+sub cpl {
+ my($word,$line,$pos) = @_;
+ $word ||= "";
+ $line ||= "";
+ $pos ||= 0;
+ CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
+ $line =~ s/^\s*//;
+ if ($line =~ s/^((?:notest|f?force)\s*)//) {
+ $pos -= length($1);
+ }
+ my @return;
+ if ($pos == 0 || $line =~ /^(?:h(?:elp)?|\?)\s/) {
+ @return = grep /^\Q$word\E/, @CPAN::Complete::COMMANDS;
+ } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
+ @return = ();
+ } elsif ($line =~ /^a\s/) {
+ @return = cplx('CPAN::Author',uc($word));
+ } elsif ($line =~ /^ls\s/) {
+ my($author,$rest) = $word =~ m|([^/]+)/?(.*)|;
+ @return = $rest ? () : map {"$_/"} cplx('CPAN::Author',uc($author||""));
+ if (0 && 1==@return) { # XXX too slow and even wrong when there is a * already
+ @return = grep /^\Q$word\E/, map {"$author/$_->[2]"} CPAN::Shell->expand("Author",$author)->ls("$rest*","2");
+ }
+ } elsif ($line =~ /^b\s/) {
+ CPAN::Shell->local_bundles;
+ @return = cplx('CPAN::Bundle',$word);
+ } elsif ($line =~ /^d\s/) {
+ @return = cplx('CPAN::Distribution',$word);
+ } elsif ($line =~ m/^(
+ [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
+ )\s/x ) {
+ if ($word =~ /^Bundle::/) {
+ CPAN::Shell->local_bundles;
+ }
+ @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
+ } elsif ($line =~ /^i\s/) {
+ @return = cpl_any($word);
+ } elsif ($line =~ /^reload\s/) {
+ @return = cpl_reload($word,$line,$pos);
+ } elsif ($line =~ /^o\s/) {
+ @return = cpl_option($word,$line,$pos);
+ } elsif ($line =~ m/^\S+\s/ ) {
+ # fallback for future commands and what we have forgotten above
+ @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
+ } else {
+ @return = ();
+ }
+ return @return;
+}
+
+#-> sub CPAN::Complete::cplx ;
+sub cplx {
+ my($class, $word) = @_;
+ if (CPAN::_sqlite_running()) {
+ $CPAN::SQLite->search($class, "^\Q$word\E");
+ }
+ my $method = "id";
+ $method = "pretty_id" if $class eq "CPAN::Distribution";
+ sort grep /^\Q$word\E/, map { $_->$method() } $CPAN::META->all_objects($class);
+}
+
+#-> sub CPAN::Complete::cpl_any ;
+sub cpl_any {
+ my($word) = shift;
+ return (
+ cplx('CPAN::Author',$word),
+ cplx('CPAN::Bundle',$word),
+ cplx('CPAN::Distribution',$word),
+ cplx('CPAN::Module',$word),
+ );
+}
+
+#-> sub CPAN::Complete::cpl_reload ;
+sub cpl_reload {
+ my($word,$line,$pos) = @_;
+ $word ||= "";
+ my(@words) = split " ", $line;
+ CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
+ my(@ok) = qw(cpan index);
+ return @ok if @words == 1;
+ return grep /^\Q$word\E/, @ok if @words == 2 && $word;
+}
+
+#-> sub CPAN::Complete::cpl_option ;
+sub cpl_option {
+ my($word,$line,$pos) = @_;
+ $word ||= "";
+ my(@words) = split " ", $line;
+ CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
+ my(@ok) = qw(conf debug);
+ return @ok if @words == 1;
+ return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
+ if (0) {
+ } elsif ($words[1] eq 'index') {
+ return ();
+ } elsif ($words[1] eq 'conf') {
+ return CPAN::HandleConfig::cpl(@_);
+ } elsif ($words[1] eq 'debug') {
+ return sort grep /^\Q$word\E/i,
+ sort keys %CPAN::DEBUG, 'all';
+ }
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Debug.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Debug.pm
new file mode 100644
index 0000000000..48e394bd41
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Debug.pm
@@ -0,0 +1,83 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+package CPAN::Debug;
+use strict;
+use vars qw($VERSION);
+
+$VERSION = "5.5001";
+# module is internal to CPAN.pm
+
+%CPAN::DEBUG = qw[
+ CPAN 1
+ Index 2
+ InfoObj 4
+ Author 8
+ Distribution 16
+ Bundle 32
+ Module 64
+ CacheMgr 128
+ Complete 256
+ FTP 512
+ Shell 1024
+ Eval 2048
+ HandleConfig 4096
+ Tarzip 8192
+ Version 16384
+ Queue 32768
+ FirstTime 65536
+];
+
+$CPAN::DEBUG ||= 0;
+
+#-> sub CPAN::Debug::debug ;
+sub debug {
+ my($self,$arg) = @_;
+
+ my @caller;
+ my $i = 0;
+ while () {
+ my(@c) = (caller($i))[0 .. ($i ? 3 : 2)];
+ last unless defined $c[0];
+ push @caller, \@c;
+ for (0,3) {
+ last if $_ > $#c;
+ $c[$_] =~ s/.*:://;
+ }
+ for (1) {
+ $c[$_] =~ s|.*/||;
+ }
+ last if ++$i>=3;
+ }
+ pop @caller;
+ if ($CPAN::DEBUG{$caller[0][0]} & $CPAN::DEBUG) {
+ if ($arg and ref $arg) {
+ eval { require Data::Dumper };
+ if ($@) {
+ $CPAN::Frontend->myprint("Debug(\n" . $arg->as_string . ")\n");
+ } else {
+ $CPAN::Frontend->myprint("Debug(\n" . Data::Dumper::Dumper($arg) . ")\n");
+ }
+ } else {
+ my $outer = "";
+ local $" = ",";
+ if (@caller>1) {
+ $outer = ",[@{$caller[1]}]";
+ }
+ $CPAN::Frontend->myprint("Debug(@{$caller[0]}$outer): $arg\n");
+ }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::Debug - internal debugging for CPAN.pm
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/DeferredCode.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/DeferredCode.pm
new file mode 100644
index 0000000000..0db37a6485
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/DeferredCode.pm
@@ -0,0 +1,16 @@
+package CPAN::DeferredCode;
+
+use strict;
+use vars qw/$VERSION/;
+
+use overload fallback => 1, map { ($_ => 'run') } qw/
+ bool "" 0+
+/;
+
+$VERSION = "5.50";
+
+sub run {
+ $_[0]->();
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Distribution.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Distribution.pm
new file mode 100644
index 0000000000..72101afc7b
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Distribution.pm
@@ -0,0 +1,4476 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Distribution;
+use strict;
+use Cwd qw(chdir);
+use CPAN::Distroprefs;
+use CPAN::InfoObj;
+use File::Path ();
+@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
+use vars qw($VERSION);
+$VERSION = "2.19";
+
+# no prepare, because prepare is not a command on the shell command line
+# TODO: clear instance cache on reload
+my %instance;
+for my $method (qw(get make test install)) {
+ no strict 'refs';
+ for my $prefix (qw(pre post)) {
+ my $hookname = sprintf "%s_%s", $prefix, $method;
+ *$hookname = sub {
+ my($self) = @_;
+ for my $plugin (@{$CPAN::Config->{plugin_list}}) {
+ my($plugin_proper,$args) = split /=/, $plugin, 2;
+ $args = "" unless defined $args;
+ if ($CPAN::META->has_inst($plugin_proper)){
+ my @args = split /,/, $args;
+ $instance{$plugin} ||= $plugin_proper->new(@args);
+ if ($instance{$plugin}->can($hookname)) {
+ $instance{$plugin}->$hookname($self);
+ }
+ } else {
+ $CPAN::Frontend->mydie("Plugin '$plugin_proper' not found");
+ }
+ }
+ };
+ }
+}
+
+# Accessors
+sub cpan_comment {
+ my $self = shift;
+ my $ro = $self->ro or return;
+ $ro->{CPAN_COMMENT}
+}
+
+#-> CPAN::Distribution::undelay
+sub undelay {
+ my $self = shift;
+ for my $delayer (
+ "configure_requires_later",
+ "configure_requires_later_for",
+ "later",
+ "later_for",
+ ) {
+ delete $self->{$delayer};
+ }
+}
+
+#-> CPAN::Distribution::is_dot_dist
+sub is_dot_dist {
+ my($self) = @_;
+ return substr($self->id,-1,1) eq ".";
+}
+
+# add the A/AN/ stuff
+#-> CPAN::Distribution::normalize
+sub normalize {
+ my($self,$s) = @_;
+ $s = $self->id unless defined $s;
+ if (substr($s,-1,1) eq ".") {
+ # using a global because we are sometimes called as static method
+ if (!$CPAN::META->{LOCK}
+ && !$CPAN::Have_warned->{"$s is unlocked"}++
+ ) {
+ $CPAN::Frontend->mywarn("You are visiting the local directory
+ '$s'
+ without lock, take care that concurrent processes do not do likewise.\n");
+ $CPAN::Frontend->mysleep(1);
+ }
+ if ($s eq ".") {
+ $s = "$CPAN::iCwd/.";
+ } elsif (File::Spec->file_name_is_absolute($s)) {
+ } elsif (File::Spec->can("rel2abs")) {
+ $s = File::Spec->rel2abs($s);
+ } else {
+ $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
+ }
+ CPAN->debug("s[$s]") if $CPAN::DEBUG;
+ unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
+ for ($CPAN::META->instance("CPAN::Distribution", $s)) {
+ $_->{build_dir} = $s;
+ $_->{archived} = "local_directory";
+ $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
+ }
+ }
+ } elsif (
+ $s =~ tr|/|| == 1
+ or
+ $s !~ m|[A-Z]/[A-Z-0-9]{2}/[A-Z-0-9]{2,}/|
+ ) {
+ return $s if $s =~ m:^N/A|^Contact Author: ;
+ $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4|;
+ CPAN->debug("s[$s]") if $CPAN::DEBUG;
+ }
+ $s;
+}
+
+#-> sub CPAN::Distribution::author ;
+sub author {
+ my($self) = @_;
+ my($authorid);
+ if (substr($self->id,-1,1) eq ".") {
+ $authorid = "LOCAL";
+ } else {
+ ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
+ }
+ CPAN::Shell->expand("Author",$authorid);
+}
+
+# tries to get the yaml from CPAN instead of the distro itself:
+# EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
+sub fast_yaml {
+ my($self) = @_;
+ my $meta = $self->pretty_id;
+ $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
+ my(@ls) = CPAN::Shell->globls($meta);
+ my $norm = $self->normalize($meta);
+
+ my($local_file);
+ my($local_wanted) =
+ File::Spec->catfile(
+ $CPAN::Config->{keep_source_where},
+ "authors",
+ "id",
+ split(/\//,$norm)
+ );
+ $self->debug("Doing localize") if $CPAN::DEBUG;
+ unless ($local_file =
+ CPAN::FTP->localize("authors/id/$norm",
+ $local_wanted)) {
+ $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
+ }
+ my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
+}
+
+#-> sub CPAN::Distribution::cpan_userid
+sub cpan_userid {
+ my $self = shift;
+ if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
+ return $1;
+ }
+ return $self->SUPER::cpan_userid;
+}
+
+#-> sub CPAN::Distribution::pretty_id
+sub pretty_id {
+ my $self = shift;
+ my $id = $self->id;
+ return $id unless $id =~ m|^./../|;
+ substr($id,5);
+}
+
+#-> sub CPAN::Distribution::base_id
+sub base_id {
+ my $self = shift;
+ my $id = $self->pretty_id();
+ my $base_id = File::Basename::basename($id);
+ $base_id =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i;
+ return $base_id;
+}
+
+#-> sub CPAN::Distribution::tested_ok_but_not_installed
+sub tested_ok_but_not_installed {
+ my $self = shift;
+ return (
+ $self->{make_test}
+ && $self->{build_dir}
+ && (UNIVERSAL::can($self->{make_test},"failed") ?
+ ! $self->{make_test}->failed :
+ $self->{make_test} =~ /^YES/
+ )
+ && (
+ !$self->{install}
+ ||
+ $self->{install}->failed
+ )
+ );
+}
+
+
+# mark as dirty/clean for the sake of recursion detection. $color=1
+# means "in use", $color=0 means "not in use anymore". $color=2 means
+# we have determined prereqs now and thus insist on passing this
+# through (at least) once again.
+
+#-> sub CPAN::Distribution::color_cmd_tmps ;
+sub color_cmd_tmps {
+ my($self) = shift;
+ my($depth) = shift || 0;
+ my($color) = shift || 0;
+ my($ancestors) = shift || [];
+ # a distribution needs to recurse into its prereq_pms
+ $self->debug("color_cmd_tmps[$depth,$color,@$ancestors]") if $CPAN::DEBUG;
+
+ return if exists $self->{incommandcolor}
+ && $color==1
+ && $self->{incommandcolor}==$color;
+ $CPAN::MAX_RECURSION||=0; # silence 'once' warnings
+ if ($depth>=$CPAN::MAX_RECURSION) {
+ my $e = CPAN::Exception::RecursiveDependency->new($ancestors);
+ if ($e->is_resolvable) {
+ return $self->{incommandcolor}=2;
+ } else {
+ die $e;
+ }
+ }
+ # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
+ my $prereq_pm = $self->prereq_pm;
+ if (defined $prereq_pm) {
+ # XXX also optional_req & optional_breq? -- xdg, 2012-04-01
+ # A: no, optional deps may recurse -- ak, 2014-05-07
+ PREREQ: for my $pre (sort(
+ keys %{$prereq_pm->{requires}||{}},
+ keys %{$prereq_pm->{build_requires}||{}},
+ )) {
+ next PREREQ if $pre eq "perl";
+ my $premo;
+ unless ($premo = CPAN::Shell->expand("Module",$pre)) {
+ $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
+ $CPAN::Frontend->mysleep(0.2);
+ next PREREQ;
+ }
+ $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
+ }
+ }
+ if ($color==0) {
+ delete $self->{sponsored_mods};
+
+ # as we are at the end of a command, we'll give up this
+ # reminder of a broken test. Other commands may test this guy
+ # again. Maybe 'badtestcnt' should be renamed to
+ # 'make_test_failed_within_command'?
+ delete $self->{badtestcnt};
+ }
+ $self->{incommandcolor} = $color;
+}
+
+#-> sub CPAN::Distribution::as_string ;
+sub as_string {
+ my $self = shift;
+ $self->containsmods;
+ $self->upload_date;
+ $self->SUPER::as_string(@_);
+}
+
+#-> sub CPAN::Distribution::containsmods ;
+sub containsmods {
+ my $self = shift;
+ return sort keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
+ my $dist_id = $self->{ID};
+ for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
+ my $mod_file = $mod->cpan_file or next;
+ my $mod_id = $mod->{ID} or next;
+ # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
+ # sleep 1;
+ if ($CPAN::Signal) {
+ delete $self->{CONTAINSMODS};
+ return;
+ }
+ $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
+ }
+ sort keys %{$self->{CONTAINSMODS}||={}};
+}
+
+#-> sub CPAN::Distribution::upload_date ;
+sub upload_date {
+ my $self = shift;
+ return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
+ my(@local_wanted) = split(/\//,$self->id);
+ my $filename = pop @local_wanted;
+ push @local_wanted, "CHECKSUMS";
+ my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
+ return unless $author;
+ my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
+ return unless @dl;
+ my($dirent) = grep { $_->[2] eq $filename } @dl;
+ # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
+ return unless $dirent->[1];
+ return $self->{UPLOAD_DATE} = $dirent->[1];
+}
+
+#-> sub CPAN::Distribution::uptodate ;
+sub uptodate {
+ my($self) = @_;
+ my $c;
+ foreach $c ($self->containsmods) {
+ my $obj = CPAN::Shell->expandany($c);
+ unless ($obj->uptodate) {
+ my $id = $self->pretty_id;
+ $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
+ return 0;
+ }
+ }
+ return 1;
+}
+
+#-> sub CPAN::Distribution::called_for ;
+sub called_for {
+ my($self,$id) = @_;
+ $self->{CALLED_FOR} = $id if defined $id;
+ return $self->{CALLED_FOR};
+}
+
+#-> sub CPAN::Distribution::shortcut_get ;
+# return values: undef means don't shortcut; 0 means shortcut as fail;
+# and 1 means shortcut as success
+sub shortcut_get {
+ my ($self) = @_;
+
+ if (my $why = $self->check_disabled) {
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
+ # XXX why is this goodbye() instead of just print/warn?
+ # Alternatively, should other print/warns here be goodbye()?
+ # -- xdg, 2012-04-05
+ return $self->goodbye("[disabled] -- NA $why");
+ }
+
+ $self->debug("checking already unwrapped[$self->{ID}]") if $CPAN::DEBUG;
+ if (exists $self->{build_dir} && -d $self->{build_dir}) {
+ # this deserves print, not warn:
+ return $self->success("Has already been unwrapped into directory ".
+ "$self->{build_dir}"
+ );
+ }
+
+ # XXX I'm not sure this should be here because it's not really
+ # a test for whether get should continue or return; this is
+ # a side effect -- xdg, 2012-04-05
+ $self->debug("checking missing build_dir[$self->{ID}]") if $CPAN::DEBUG;
+ if (exists $self->{build_dir} && ! -d $self->{build_dir}){
+ # we have lost it.
+ $self->fforce(""); # no method to reset all phases but not set force (dodge)
+ return undef; # no shortcut
+ }
+
+ # although we talk about 'force' we shall not test on
+ # force directly. New model of force tries to refrain from
+ # direct checking of force.
+ $self->debug("checking unwrapping error[$self->{ID}]") if $CPAN::DEBUG;
+ if ( exists $self->{unwrapped} and (
+ UNIVERSAL::can($self->{unwrapped},"failed") ?
+ $self->{unwrapped}->failed :
+ $self->{unwrapped} =~ /^NO/ )
+ ) {
+ return $self->goodbye("Unwrapping had some problem, won't try again without force");
+ }
+
+ return undef; # no shortcut
+}
+
+#-> sub CPAN::Distribution::get ;
+sub get {
+ my($self) = @_;
+
+ $self->pre_get();
+
+ $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
+ if (my $goto = $self->prefs->{goto}) {
+ return $self->goto($goto);
+ }
+
+ if ( defined( my $sc = $self->shortcut_get) ) {
+ return $sc;
+ }
+
+ local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
+ ? $ENV{PERL5LIB}
+ : ($ENV{PERLLIB} || "");
+ local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
+ # local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # get
+ $CPAN::META->set_perl5lib;
+ local $ENV{MAKEFLAGS}; # protect us from outer make calls
+
+ my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
+
+ my($local_file);
+ # XXX I don't think this check needs to be here, as it
+ # is already checked in shortcut_get() -- xdg, 2012-04-05
+ unless ($self->{build_dir} && -d $self->{build_dir}) {
+ $self->get_file_onto_local_disk;
+ return if $CPAN::Signal;
+ $self->check_integrity;
+ return if $CPAN::Signal;
+ (my $packagedir,$local_file) = $self->run_preps_on_packagedir;
+ # XXX why is this check here? -- xdg, 2012-04-08
+ if (exists $self->{writemakefile} && ref $self->{writemakefile}
+ && $self->{writemakefile}->can("failed") &&
+ $self->{writemakefile}->failed) {
+ #
+ return;
+ }
+ $packagedir ||= $self->{build_dir};
+ $self->{build_dir} = $packagedir;
+ }
+
+ # XXX should this move up to after run_preps_on_packagedir?
+ # Otherwise, failing writemakefile can return without
+ # a $CPAN::Signal check -- xdg, 2012-04-05
+ if ($CPAN::Signal) {
+ $self->safe_chdir($sub_wd);
+ return;
+ }
+ return unless $self->patch;
+ $self->store_persistent_state;
+
+ $self->post_get();
+
+ return 1; # success
+}
+
+#-> CPAN::Distribution::get_file_onto_local_disk
+sub get_file_onto_local_disk {
+ my($self) = @_;
+
+ return if $self->is_dot_dist;
+ my($local_file);
+ my($local_wanted) =
+ File::Spec->catfile(
+ $CPAN::Config->{keep_source_where},
+ "authors",
+ "id",
+ split(/\//,$self->id)
+ );
+
+ $self->debug("Doing localize") if $CPAN::DEBUG;
+ unless ($local_file =
+ CPAN::FTP->localize("authors/id/$self->{ID}",
+ $local_wanted)) {
+ my $note = "";
+ if ($CPAN::Index::DATE_OF_02) {
+ $note = "Note: Current database in memory was generated ".
+ "on $CPAN::Index::DATE_OF_02\n";
+ }
+ $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
+ }
+
+ $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
+ $self->{localfile} = $local_file;
+}
+
+
+#-> CPAN::Distribution::check_integrity
+sub check_integrity {
+ my($self) = @_;
+
+ return if $self->is_dot_dist;
+ if ($CPAN::META->has_inst("Digest::SHA")) {
+ $self->debug("Digest::SHA is installed, verifying");
+ $self->verifyCHECKSUM;
+ } else {
+ $self->debug("Digest::SHA is NOT installed");
+ }
+}
+
+#-> CPAN::Distribution::run_preps_on_packagedir
+sub run_preps_on_packagedir {
+ my($self) = @_;
+ return if $self->is_dot_dist;
+
+ $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
+ my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
+ $self->safe_chdir($builddir);
+ $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
+ File::Path::rmtree("tmp-$$");
+ unless (mkdir "tmp-$$", 0755) {
+ $CPAN::Frontend->unrecoverable_error(<<EOF);
+Couldn't mkdir '$builddir/tmp-$$': $!
+
+Cannot continue: Please find the reason why I cannot make the
+directory
+$builddir/tmp-$$
+and fix the problem, then retry.
+
+EOF
+ }
+ if ($CPAN::Signal) {
+ return;
+ }
+ $self->safe_chdir("tmp-$$");
+
+ #
+ # Unpack the goods
+ #
+ my $local_file = $self->{localfile};
+ my $ct = eval{CPAN::Tarzip->new($local_file)};
+ unless ($ct) {
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO");
+ delete $self->{build_dir};
+ return;
+ }
+ if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i) {
+ $self->{was_uncompressed}++ unless eval{$ct->gtest()};
+ $self->untar_me($ct);
+ } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
+ $self->unzip_me($ct);
+ } else {
+ $self->{was_uncompressed}++ unless $ct->gtest();
+ $local_file = $self->handle_singlefile($local_file);
+ }
+
+ # we are still in the tmp directory!
+ # Let's check if the package has its own directory.
+ my $dh = DirHandle->new(File::Spec->curdir)
+ or Carp::croak("Couldn't opendir .: $!");
+ my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
+ if (grep { $_ eq "pax_global_header" } @readdir) {
+ $CPAN::Frontend->mywarn("Your (un)tar seems to have extracted a file named 'pax_global_header'
+from the tarball '$local_file'.
+This is almost certainly an error. Please upgrade your tar.
+I'll ignore this file for now.
+See also http://rt.cpan.org/Ticket/Display.html?id=38932\n");
+ $CPAN::Frontend->mysleep(5);
+ @readdir = grep { $_ ne "pax_global_header" } @readdir;
+ }
+ $dh->close;
+ my $tdir_base;
+ my $from_dir;
+ my @dirents;
+ if (@readdir == 1 && -d $readdir[0]) {
+ $tdir_base = $readdir[0];
+ $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
+ my $dh2;
+ unless ($dh2 = DirHandle->new($from_dir)) {
+ my($mode) = (stat $from_dir)[2];
+ my $why = sprintf
+ (
+ "Couldn't opendir '%s', mode '%o': %s",
+ $from_dir,
+ $mode,
+ $!,
+ );
+ $CPAN::Frontend->mywarn("$why\n");
+ $self->{writemakefile} = CPAN::Distrostatus->new("NO -- $why");
+ return;
+ }
+ @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
+ } else {
+ my $userid = $self->cpan_userid;
+ CPAN->debug("userid[$userid]");
+ if (!$userid or $userid eq "N/A") {
+ $userid = "anon";
+ }
+ $tdir_base = $userid;
+ $from_dir = File::Spec->curdir;
+ @dirents = @readdir;
+ }
+ eval { File::Path::mkpath $builddir; };
+ if ($@) {
+ $CPAN::Frontend->mydie("Cannot create directory $builddir: $@");
+ }
+ my $packagedir;
+ my $eexist = $CPAN::META->has_usable("Errno") ? &Errno::EEXIST : undef;
+ for(my $suffix = 0; ; $suffix++) {
+ $packagedir = File::Spec->catdir($builddir, "$tdir_base-$suffix");
+ my $parent = $builddir;
+ mkdir($packagedir, 0777) and last;
+ if((defined($eexist) && $! != $eexist) || $suffix == 999) {
+ $CPAN::Frontend->mydie("Cannot create directory $packagedir: $!\n");
+ }
+ }
+ my $f;
+ for $f (@dirents) { # is already without "." and ".."
+ my $from = File::Spec->catfile($from_dir,$f);
+ my $to = File::Spec->catfile($packagedir,$f);
+ unless (File::Copy::move($from,$to)) {
+ my $err = $!;
+ $from = File::Spec->rel2abs($from);
+ $CPAN::Frontend->mydie(
+ "Couldn't move $from to $to: $err; #82295? ".
+ "CPAN::VERSION=$CPAN::VERSION; ".
+ "File::Copy::VERSION=$File::Copy::VERSION; ".
+ "$from " . (-e $from ? "exists; " : "does not exist; ").
+ "$to " . (-e $to ? "exists; " : "does not exist; ").
+ "cwd=" . CPAN::anycwd() . ";"
+ );
+ }
+ }
+ $self->{build_dir} = $packagedir;
+ $self->safe_chdir($builddir);
+ File::Path::rmtree("tmp-$$");
+
+ $self->safe_chdir($packagedir);
+ $self->_signature_business();
+ $self->safe_chdir($builddir);
+
+ return($packagedir,$local_file);
+}
+
+#-> sub CPAN::Distribution::pick_meta_file ;
+sub pick_meta_file {
+ my($self, $filter) = @_;
+ $filter = '.' unless defined $filter;
+
+ my $build_dir;
+ unless ($build_dir = $self->{build_dir}) {
+ # maybe permission on build_dir was missing
+ $CPAN::Frontend->mywarn("Warning: cannot determine META.yml without a build_dir.\n");
+ return;
+ }
+
+ my $has_cm = $CPAN::META->has_usable("CPAN::Meta");
+ my $has_pcm = $CPAN::META->has_usable("Parse::CPAN::Meta");
+
+ my @choices;
+ push @choices, 'MYMETA.json' if $has_cm;
+ push @choices, 'MYMETA.yml' if $has_cm || $has_pcm;
+ push @choices, 'META.json' if $has_cm;
+ push @choices, 'META.yml' if $has_cm || $has_pcm;
+
+ for my $file ( grep { /$filter/ } @choices ) {
+ my $path = File::Spec->catfile( $build_dir, $file );
+ return $path if -f $path
+ }
+
+ return;
+}
+
+#-> sub CPAN::Distribution::parse_meta_yml ;
+sub parse_meta_yml {
+ my($self, $yaml) = @_;
+ $self->debug(sprintf("parse_meta_yml[%s]",$yaml||'undef')) if $CPAN::DEBUG;
+ my $build_dir = $self->{build_dir} or die "PANIC: cannot parse yaml without a build_dir";
+ $yaml ||= File::Spec->catfile($build_dir,"META.yml");
+ $self->debug("meta[$yaml]") if $CPAN::DEBUG;
+ return unless -f $yaml;
+ my $early_yaml;
+ eval {
+ $CPAN::META->has_inst("Parse::CPAN::Meta") or die;
+ die "Parse::CPAN::Meta yaml too old" unless $Parse::CPAN::Meta::VERSION >= "1.40";
+ # P::C::M returns last document in scalar context
+ $early_yaml = Parse::CPAN::Meta::LoadFile($yaml);
+ };
+ unless ($early_yaml) {
+ eval { $early_yaml = CPAN->_yaml_loadfile($yaml)->[0]; };
+ }
+ $self->debug(sprintf("yaml[%s]", $early_yaml || 'UNDEF')) if $CPAN::DEBUG;
+ $self->debug($early_yaml) if $CPAN::DEBUG && $early_yaml;
+ if (!ref $early_yaml or ref $early_yaml ne "HASH"){
+ # fix rt.cpan.org #95271
+ $CPAN::Frontend->mywarn("The content of '$yaml' is not a HASH reference. Cannot use it.\n");
+ return {};
+ }
+ return $early_yaml || undef;
+}
+
+#-> sub CPAN::Distribution::satisfy_requires ;
+# return values: 1 means requirements are satisfied;
+# and 0 means not satisfied (and maybe queued)
+sub satisfy_requires {
+ my ($self) = @_;
+ $self->debug("Entering satisfy_requires") if $CPAN::DEBUG;
+ if (my @prereq = $self->unsat_prereq("later")) {
+ if ($CPAN::DEBUG){
+ require Data::Dumper;
+ my $prereq = Data::Dumper->new(\@prereq)->Terse(1)->Indent(0)->Dump;
+ $self->debug("unsatisfied[$prereq]");
+ }
+ if ($prereq[0][0] eq "perl") {
+ my $need = "requires perl '$prereq[0][1]'";
+ my $id = $self->pretty_id;
+ $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
+ $self->{make} = CPAN::Distrostatus->new("NO $need");
+ $self->store_persistent_state;
+ die "[prereq] -- NOT OK\n";
+ } else {
+ my $follow = eval { $self->follow_prereqs("later",@prereq); };
+ if (0) {
+ } elsif ($follow) {
+ return; # we need deps
+ } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
+ $CPAN::Frontend->mywarn($@);
+ die "[depend] -- NOT OK\n";
+ }
+ }
+ }
+ return 1;
+}
+
+#-> sub CPAN::Distribution::satisfy_configure_requires ;
+# return values: 1 means configure_require is satisfied;
+# and 0 means not satisfied (and maybe queued)
+sub satisfy_configure_requires {
+ my($self) = @_;
+ $self->debug("Entering satisfy_configure_requires") if $CPAN::DEBUG;
+ my $enable_configure_requires = 1;
+ if (!$enable_configure_requires) {
+ return 1;
+ # if we return 1 here, everything is as before we introduced
+ # configure_requires that means, things with
+ # configure_requires simply fail, all others succeed
+ }
+ my @prereq = $self->unsat_prereq("configure_requires_later");
+ $self->debug(sprintf "configure_requires[%s]", join(",",map {join "/",@$_} @prereq)) if $CPAN::DEBUG;
+ return 1 unless @prereq;
+ $self->debug(\@prereq) if $CPAN::DEBUG;
+ if ($self->{configure_requires_later}) {
+ for my $k (sort keys %{$self->{configure_requires_later_for}||{}}) {
+ if ($self->{configure_requires_later_for}{$k}>1) {
+ my $type = "";
+ for my $p (@prereq) {
+ if ($p->[0] eq $k) {
+ $type = $p->[1];
+ }
+ }
+ $type = " $type" if $type;
+ $CPAN::Frontend->mywarn("Warning: unmanageable(?) prerequisite $k$type");
+ sleep 1;
+ }
+ }
+ }
+ if ($prereq[0][0] eq "perl") {
+ my $need = "requires perl '$prereq[0][1]'";
+ my $id = $self->pretty_id;
+ $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
+ $self->{make} = CPAN::Distrostatus->new("NO $need");
+ $self->store_persistent_state;
+ return $self->goodbye("[prereq] -- NOT OK");
+ } else {
+ my $follow = eval {
+ $self->follow_prereqs("configure_requires_later", @prereq);
+ };
+ if (0) {
+ } elsif ($follow) {
+ return; # we need deps
+ } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
+ $CPAN::Frontend->mywarn($@);
+ return $self->goodbye("[depend] -- NOT OK");
+ }
+ else {
+ return $self->goodbye("[configure_requires] -- NOT OK");
+ }
+ }
+ die "never reached";
+}
+
+#-> sub CPAN::Distribution::choose_MM_or_MB ;
+sub choose_MM_or_MB {
+ my($self) = @_;
+ $self->satisfy_configure_requires() or return;
+ my $local_file = $self->{localfile};
+ my($mpl) = File::Spec->catfile($self->{build_dir},"Makefile.PL");
+ my($mpl_exists) = -f $mpl;
+ unless ($mpl_exists) {
+ # NFS has been reported to have racing problems after the
+ # renaming of a directory in some environments.
+ # This trick helps.
+ $CPAN::Frontend->mysleep(1);
+ my $mpldh = DirHandle->new($self->{build_dir})
+ or Carp::croak("Couldn't opendir $self->{build_dir}: $!");
+ $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
+ $mpldh->close;
+ }
+ my $prefer_installer = "eumm"; # eumm|mb
+ if (-f File::Spec->catfile($self->{build_dir},"Build.PL")) {
+ if ($mpl_exists) { # they *can* choose
+ if ($CPAN::META->has_inst("Module::Build")) {
+ $prefer_installer = CPAN::HandleConfig->prefs_lookup(
+ $self, q{prefer_installer}
+ );
+ # M::B <= 0.35 left a DATA handle open that
+ # causes problems upgrading M::B on Windows
+ close *Module::Build::Version::DATA
+ if fileno *Module::Build::Version::DATA;
+ }
+ } else {
+ $prefer_installer = "mb";
+ }
+ }
+ if (lc($prefer_installer) eq "rand") {
+ $prefer_installer = rand()<.5 ? "eumm" : "mb";
+ }
+ if (lc($prefer_installer) eq "mb") {
+ $self->{modulebuild} = 1;
+ } elsif ($self->{archived} eq "patch") {
+ # not an edge case, nothing to install for sure
+ my $why = "A patch file cannot be installed";
+ $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
+ $self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
+ } elsif (! $mpl_exists) {
+ $self->_edge_cases($mpl,$local_file);
+ }
+ if ($self->{build_dir}
+ &&
+ $CPAN::Config->{build_dir_reuse}
+ ) {
+ $self->store_persistent_state;
+ }
+ return $self;
+}
+
+# see also reanimate_build_dir
+#-> CPAN::Distribution::store_persistent_state
+sub store_persistent_state {
+ my($self) = @_;
+ my $dir = $self->{build_dir};
+ unless (defined $dir && length $dir) {
+ my $id = $self->id;
+ $CPAN::Frontend->mywarnonce("build_dir of $id is not known, ".
+ "will not store persistent state\n");
+ return;
+ }
+ # self-build-dir
+ my $sbd = Cwd::realpath(
+ File::Spec->catdir($dir, File::Spec->updir ())
+ );
+ # config-build-dir
+ my $cbd = Cwd::realpath(
+ # the catdir is a workaround for bug https://rt.cpan.org/Ticket/Display.html?id=101283
+ File::Spec->catdir($CPAN::Config->{build_dir}, File::Spec->curdir())
+ );
+ unless ($sbd eq $cbd) {
+ $CPAN::Frontend->mywarnonce("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
+ "will not store persistent state\n");
+ return;
+ }
+ my $file = sprintf "%s.yml", $dir;
+ my $yaml_module = CPAN::_yaml_module();
+ if ($CPAN::META->has_inst($yaml_module)) {
+ CPAN->_yaml_dumpfile(
+ $file,
+ {
+ time => time,
+ perl => CPAN::_perl_fingerprint(),
+ distribution => $self,
+ }
+ );
+ } else {
+ $CPAN::Frontend->myprintonce("'$yaml_module' not installed, ".
+ "will not store persistent state\n");
+ }
+}
+
+#-> CPAN::Distribution::try_download
+sub try_download {
+ my($self,$patch) = @_;
+ my $norm = $self->normalize($patch);
+ my($local_wanted) =
+ File::Spec->catfile(
+ $CPAN::Config->{keep_source_where},
+ "authors",
+ "id",
+ split(/\//,$norm),
+ );
+ $self->debug("Doing localize") if $CPAN::DEBUG;
+ return CPAN::FTP->localize("authors/id/$norm",
+ $local_wanted);
+}
+
+{
+ my $stdpatchargs = "";
+ #-> CPAN::Distribution::patch
+ sub patch {
+ my($self) = @_;
+ $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
+ my $patches = $self->prefs->{patches};
+ $patches ||= "";
+ $self->debug("patches[$patches]") if $CPAN::DEBUG;
+ if ($patches) {
+ return unless @$patches;
+ $self->safe_chdir($self->{build_dir});
+ CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
+ my $patchbin = $CPAN::Config->{patch};
+ unless ($patchbin && length $patchbin) {
+ $CPAN::Frontend->mydie("No external patch command configured\n\n".
+ "Please run 'o conf init /patch/'\n\n");
+ }
+ unless (MM->maybe_command($patchbin)) {
+ $CPAN::Frontend->mydie("No external patch command available\n\n".
+ "Please run 'o conf init /patch/'\n\n");
+ }
+ $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
+ local $ENV{PATCH_GET} = 0; # formerly known as -g0
+ unless ($stdpatchargs) {
+ my $system = "$patchbin --version |";
+ local *FH;
+ open FH, $system or die "Could not fork '$system': $!";
+ local $/ = "\n";
+ my $pversion;
+ PARSEVERSION: while (<FH>) {
+ if (/^patch\s+([\d\.]+)/) {
+ $pversion = $1;
+ last PARSEVERSION;
+ }
+ }
+ if ($pversion) {
+ $stdpatchargs = "-N --fuzz=3";
+ } else {
+ $stdpatchargs = "-N";
+ }
+ }
+ my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
+ $CPAN::Frontend->myprint("Applying $countedpatches:\n");
+ my $patches_dir = $CPAN::Config->{patches_dir};
+ for my $patch (@$patches) {
+ if ($patches_dir && !File::Spec->file_name_is_absolute($patch)) {
+ my $f = File::Spec->catfile($patches_dir, $patch);
+ $patch = $f if -f $f;
+ }
+ unless (-f $patch) {
+ CPAN->debug("not on disk: patch[$patch]") if $CPAN::DEBUG;
+ if (my $trydl = $self->try_download($patch)) {
+ $patch = $trydl;
+ } else {
+ my $fail = "Could not find patch '$patch'";
+ $CPAN::Frontend->mywarn("$fail; cannot continue\n");
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
+ delete $self->{build_dir};
+ return;
+ }
+ }
+ $CPAN::Frontend->myprint(" $patch\n");
+ my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
+
+ my $pcommand;
+ my($ppp,$pfiles) = $self->_patch_p_parameter($readfh);
+ if ($ppp eq "applypatch") {
+ $pcommand = "$CPAN::Config->{applypatch} -verbose";
+ } else {
+ my $thispatchargs = join " ", $stdpatchargs, $ppp;
+ $pcommand = "$patchbin $thispatchargs";
+ require Config; # usually loaded from CPAN.pm
+ if ($Config::Config{osname} eq "solaris") {
+ # native solaris patch cannot patch readonly files
+ for my $file (@{$pfiles||[]}) {
+ my @stat = stat $file or next;
+ chmod $stat[2] | 0600, $file; # may fail
+ }
+ }
+ }
+
+ $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
+ my $writefh = FileHandle->new;
+ $CPAN::Frontend->myprint(" $pcommand\n");
+ unless (open $writefh, "|$pcommand") {
+ my $fail = "Could not fork '$pcommand'";
+ $CPAN::Frontend->mywarn("$fail; cannot continue\n");
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
+ delete $self->{build_dir};
+ return;
+ }
+ binmode($writefh);
+ while (my $x = $readfh->READLINE) {
+ print $writefh $x;
+ }
+ unless (close $writefh) {
+ my $fail = "Could not apply patch '$patch'";
+ $CPAN::Frontend->mywarn("$fail; cannot continue\n");
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
+ delete $self->{build_dir};
+ return;
+ }
+ }
+ $self->{patched}++;
+ }
+ return 1;
+ }
+}
+
+# may return
+# - "applypatch"
+# - ("-p0"|"-p1", $files)
+sub _patch_p_parameter {
+ my($self,$fh) = @_;
+ my $cnt_files = 0;
+ my $cnt_p0files = 0;
+ my @files;
+ local($_);
+ while ($_ = $fh->READLINE) {
+ if (
+ $CPAN::Config->{applypatch}
+ &&
+ /\#\#\#\# ApplyPatch data follows \#\#\#\#/
+ ) {
+ return "applypatch"
+ }
+ next unless /^[\*\+]{3}\s(\S+)/;
+ my $file = $1;
+ push @files, $file;
+ $cnt_files++;
+ $cnt_p0files++ if -f $file;
+ CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
+ if $CPAN::DEBUG;
+ }
+ return "-p1" unless $cnt_files;
+ my $opt_p = $cnt_files==$cnt_p0files ? "-p0" : "-p1";
+ return ($opt_p, \@files);
+}
+
+#-> sub CPAN::Distribution::_edge_cases
+# with "configure" or "Makefile" or single file scripts
+sub _edge_cases {
+ my($self,$mpl,$local_file) = @_;
+ $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
+ $mpl,
+ CPAN::anycwd(),
+ )) if $CPAN::DEBUG;
+ my $build_dir = $self->{build_dir};
+ my($configure) = File::Spec->catfile($build_dir,"Configure");
+ if (-f $configure) {
+ # do we have anything to do?
+ $self->{configure} = $configure;
+ } elsif (-f File::Spec->catfile($build_dir,"Makefile")) {
+ $CPAN::Frontend->mywarn(qq{
+Package comes with a Makefile and without a Makefile.PL.
+We\'ll try to build it with that Makefile then.
+});
+ $self->{writemakefile} = CPAN::Distrostatus->new("YES");
+ $CPAN::Frontend->mysleep(2);
+ } else {
+ my $cf = $self->called_for || "unknown";
+ if ($cf =~ m|/|) {
+ $cf =~ s|.*/||;
+ $cf =~ s|\W.*||;
+ }
+ $cf =~ s|[/\\:]||g; # risk of filesystem damage
+ $cf = "unknown" unless length($cf);
+ if (my $crud = $self->_contains_crud($build_dir)) {
+ my $why = qq{Package contains $crud; not recognized as a perl package, giving up};
+ $CPAN::Frontend->mywarn("$why\n");
+ $self->{writemakefile} = CPAN::Distrostatus->new(qq{NO -- $why});
+ return;
+ }
+ $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
+ (The test -f "$mpl" returned false.)
+ Writing one on our own (setting NAME to $cf)\a\n});
+ $self->{had_no_makefile_pl}++;
+ $CPAN::Frontend->mysleep(3);
+
+ # Writing our own Makefile.PL
+
+ my $exefile_stanza = "";
+ if ($self->{archived} eq "maybe_pl") {
+ $exefile_stanza = $self->_exefile_stanza($build_dir,$local_file);
+ }
+
+ my $fh = FileHandle->new;
+ $fh->open(">$mpl")
+ or Carp::croak("Could not open >$mpl: $!");
+ $fh->print(
+ qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
+# because there was no Makefile.PL supplied.
+# Autogenerated on: }.scalar localtime().qq{
+
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => q[$cf],$exefile_stanza
+ );
+});
+ $fh->close;
+ }
+}
+
+#-> CPAN;:Distribution::_contains_crud
+sub _contains_crud {
+ my($self,$dir) = @_;
+ my(@dirs, $dh, @files);
+ opendir $dh, $dir or return;
+ my $dirent;
+ for $dirent (readdir $dh) {
+ next if $dirent =~ /^\.\.?$/;
+ my $path = File::Spec->catdir($dir,$dirent);
+ if (-d $path) {
+ push @dirs, $dirent;
+ } elsif (-f $path) {
+ push @files, $dirent;
+ }
+ }
+ if (@dirs && @files) {
+ return "both files[@files] and directories[@dirs]";
+ } elsif (@files > 2) {
+ return "several files[@files] but no Makefile.PL or Build.PL";
+ }
+ return;
+}
+
+#-> CPAN;:Distribution::_exefile_stanza
+sub _exefile_stanza {
+ my($self,$build_dir,$local_file) = @_;
+
+ my $fh = FileHandle->new;
+ my $script_file = File::Spec->catfile($build_dir,$local_file);
+ $fh->open($script_file)
+ or Carp::croak("Could not open script '$script_file': $!");
+ local $/ = "\n";
+ # parse name and prereq
+ my($state) = "poddir";
+ my($name, $prereq) = ("", "");
+ while (<$fh>) {
+ if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
+ if ($1 eq 'NAME') {
+ $state = "name";
+ } elsif ($1 eq 'PREREQUISITES') {
+ $state = "prereq";
+ }
+ } elsif ($state =~ m{^(name|prereq)$}) {
+ if (/^=/) {
+ $state = "poddir";
+ } elsif (/^\s*$/) {
+ # nop
+ } elsif ($state eq "name") {
+ if ($name eq "") {
+ ($name) = /^(\S+)/;
+ $state = "poddir";
+ }
+ } elsif ($state eq "prereq") {
+ $prereq .= $_;
+ }
+ } elsif (/^=cut\b/) {
+ last;
+ }
+ }
+ $fh->close;
+
+ for ($name) {
+ s{.*<}{}; # strip X<...>
+ s{>.*}{};
+ }
+ chomp $prereq;
+ $prereq = join " ", split /\s+/, $prereq;
+ my($PREREQ_PM) = join("\n", map {
+ s{.*<}{}; # strip X<...>
+ s{>.*}{};
+ if (/[\s\'\"]/) { # prose?
+ } else {
+ s/[^\w:]$//; # period?
+ " "x28 . "'$_' => 0,";
+ }
+ } split /\s*,\s*/, $prereq);
+
+ if ($name) {
+ my $to_file = File::Spec->catfile($build_dir, $name);
+ rename $script_file, $to_file
+ or die "Can't rename $script_file to $to_file: $!";
+ }
+
+ return "
+ EXE_FILES => ['$name'],
+ PREREQ_PM => {
+$PREREQ_PM
+ },
+";
+}
+
+#-> CPAN::Distribution::_signature_business
+sub _signature_business {
+ my($self) = @_;
+ my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
+ q{check_sigs});
+ if ($check_sigs) {
+ if ($CPAN::META->has_inst("Module::Signature")) {
+ if (-f "SIGNATURE") {
+ $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
+ my $rv = Module::Signature::verify();
+ if ($rv != Module::Signature::SIGNATURE_OK() and
+ $rv != Module::Signature::SIGNATURE_MISSING()) {
+ $CPAN::Frontend->mywarn(
+ qq{\nSignature invalid for }.
+ qq{distribution file. }.
+ qq{Please investigate.\n\n}
+ );
+
+ my $wrap =
+ sprintf(qq{I'd recommend removing %s. Some error occurred }.
+ qq{while checking its signature, so it could }.
+ qq{be invalid. Maybe you have configured }.
+ qq{your 'urllist' with a bad URL. Please check this }.
+ qq{array with 'o conf urllist' and retry. Or }.
+ qq{examine the distribution in a subshell. Try
+ look %s
+and run
+ cpansign -v
+},
+ $self->{localfile},
+ $self->pretty_id,
+ );
+ $self->{signature_verify} = CPAN::Distrostatus->new("NO");
+ $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
+ $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
+ } else {
+ $self->{signature_verify} = CPAN::Distrostatus->new("YES");
+ $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
+ }
+ } else {
+ $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
+ }
+ } else {
+ $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
+ }
+ }
+}
+
+#-> CPAN::Distribution::untar_me ;
+sub untar_me {
+ my($self,$ct) = @_;
+ $self->{archived} = "tar";
+ my $result = eval { $ct->untar() };
+ if ($result) {
+ $self->{unwrapped} = CPAN::Distrostatus->new("YES");
+ } else {
+ # unfortunately we have no $@ here, Tarzip is using mydie which dies with "\n"
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
+ }
+}
+
+# CPAN::Distribution::unzip_me ;
+sub unzip_me {
+ my($self,$ct) = @_;
+ $self->{archived} = "zip";
+ if ($ct->unzip()) {
+ $self->{unwrapped} = CPAN::Distrostatus->new("YES");
+ } else {
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
+ }
+ return;
+}
+
+sub handle_singlefile {
+ my($self,$local_file) = @_;
+
+ if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ) {
+ $self->{archived} = "pm";
+ } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
+ $self->{archived} = "patch";
+ } else {
+ $self->{archived} = "maybe_pl";
+ }
+
+ my $to = File::Basename::basename($local_file);
+ if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
+ if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
+ $self->{unwrapped} = CPAN::Distrostatus->new("YES");
+ } else {
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
+ }
+ } else {
+ if (File::Copy::cp($local_file,".")) {
+ $self->{unwrapped} = CPAN::Distrostatus->new("YES");
+ } else {
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
+ }
+ }
+ return $to;
+}
+
+#-> sub CPAN::Distribution::new ;
+sub new {
+ my($class,%att) = @_;
+
+ # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
+
+ my $this = { %att };
+ return bless $this, $class;
+}
+
+#-> sub CPAN::Distribution::look ;
+sub look {
+ my($self) = @_;
+
+ if ($^O eq 'MacOS') {
+ $self->Mac::BuildTools::look;
+ return;
+ }
+
+ if ( $CPAN::Config->{'shell'} ) {
+ $CPAN::Frontend->myprint(qq{
+Trying to open a subshell in the build directory...
+});
+ } else {
+ $CPAN::Frontend->myprint(qq{
+Your configuration does not define a value for subshells.
+Please define it with "o conf shell <your shell>"
+});
+ return;
+ }
+ my $dist = $self->id;
+ my $dir;
+ unless ($dir = $self->dir) {
+ $self->get;
+ }
+ unless ($dir ||= $self->dir) {
+ $CPAN::Frontend->mywarn(qq{
+Could not determine which directory to use for looking at $dist.
+});
+ return;
+ }
+ my $pwd = CPAN::anycwd();
+ $self->safe_chdir($dir);
+ $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
+ {
+ local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
+ $ENV{CPAN_SHELL_LEVEL} += 1;
+ my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
+
+ local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
+ ? $ENV{PERL5LIB}
+ : ($ENV{PERLLIB} || "");
+
+ local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
+ # local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # look
+ $CPAN::META->set_perl5lib;
+ local $ENV{MAKEFLAGS}; # protect us from outer make calls
+
+ unless (system($shell) == 0) {
+ my $code = $? >> 8;
+ $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
+ }
+ }
+ $self->safe_chdir($pwd);
+}
+
+# CPAN::Distribution::cvs_import ;
+sub cvs_import {
+ my($self) = @_;
+ $self->get;
+ my $dir = $self->dir;
+
+ my $package = $self->called_for;
+ my $module = $CPAN::META->instance('CPAN::Module', $package);
+ my $version = $module->cpan_version;
+
+ my $userid = $self->cpan_userid;
+
+ my $cvs_dir = (split /\//, $dir)[-1];
+ $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
+ my $cvs_root =
+ $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
+ my $cvs_site_perl =
+ $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
+ if ($cvs_site_perl) {
+ $cvs_dir = "$cvs_site_perl/$cvs_dir";
+ }
+ my $cvs_log = qq{"imported $package $version sources"};
+ $version =~ s/\./_/g;
+ # XXX cvs: undocumented and unclear how it was meant to work
+ my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
+ "$cvs_dir", $userid, "v$version");
+
+ my $pwd = CPAN::anycwd();
+ chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
+
+ $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
+
+ $CPAN::Frontend->myprint(qq{@cmd\n});
+ system(@cmd) == 0 or
+ # XXX cvs
+ $CPAN::Frontend->mydie("cvs import failed");
+ chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
+}
+
+#-> sub CPAN::Distribution::readme ;
+sub readme {
+ my($self) = @_;
+ my($dist) = $self->id;
+ my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
+ $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
+ my($local_file);
+ my($local_wanted) =
+ File::Spec->catfile(
+ $CPAN::Config->{keep_source_where},
+ "authors",
+ "id",
+ split(/\//,"$sans.readme"),
+ );
+ my $readme = "authors/id/$sans.readme";
+ $self->debug("Doing localize for '$readme'") if $CPAN::DEBUG;
+ $local_file = CPAN::FTP->localize($readme,
+ $local_wanted)
+ or $CPAN::Frontend->mydie(qq{No $sans.readme found});
+
+ if ($^O eq 'MacOS') {
+ Mac::BuildTools::launch_file($local_file);
+ return;
+ }
+
+ my $fh_pager = FileHandle->new;
+ local($SIG{PIPE}) = "IGNORE";
+ my $pager = $CPAN::Config->{'pager'} || "cat";
+ $fh_pager->open("|$pager")
+ or die "Could not open pager $pager\: $!";
+ my $fh_readme = FileHandle->new;
+ $fh_readme->open($local_file)
+ or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
+ $CPAN::Frontend->myprint(qq{
+Displaying file
+ $local_file
+with pager "$pager"
+});
+ $fh_pager->print(<$fh_readme>);
+ $fh_pager->close;
+}
+
+#-> sub CPAN::Distribution::verifyCHECKSUM ;
+sub verifyCHECKSUM {
+ my($self) = @_;
+ EXCUSE: {
+ my @e;
+ $self->{CHECKSUM_STATUS} ||= "";
+ $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
+ $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ }
+ my($lc_want,$lc_file,@local,$basename);
+ @local = split(/\//,$self->id);
+ pop @local;
+ push @local, "CHECKSUMS";
+ $lc_want =
+ File::Spec->catfile($CPAN::Config->{keep_source_where},
+ "authors", "id", @local);
+ local($") = "/";
+ if (my $size = -s $lc_want) {
+ $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
+ if ($self->CHECKSUM_check_file($lc_want,1)) {
+ return $self->{CHECKSUM_STATUS} = "OK";
+ }
+ }
+ $lc_file = CPAN::FTP->localize("authors/id/@local",
+ $lc_want,1);
+ unless ($lc_file) {
+ $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
+ $local[-1] .= ".gz";
+ $lc_file = CPAN::FTP->localize("authors/id/@local",
+ "$lc_want.gz",1);
+ if ($lc_file) {
+ $lc_file =~ s/\.gz(?!\n)\Z//;
+ eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
+ } else {
+ return;
+ }
+ }
+ if ($self->CHECKSUM_check_file($lc_file)) {
+ return $self->{CHECKSUM_STATUS} = "OK";
+ }
+}
+
+#-> sub CPAN::Distribution::SIG_check_file ;
+sub SIG_check_file {
+ my($self,$chk_file) = @_;
+ my $rv = eval { Module::Signature::_verify($chk_file) };
+
+ if ($rv == Module::Signature::SIGNATURE_OK()) {
+ $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
+ return $self->{SIG_STATUS} = "OK";
+ } else {
+ $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
+ qq{distribution file. }.
+ qq{Please investigate.\n\n}.
+ $self->as_string,
+ $CPAN::META->instance(
+ 'CPAN::Author',
+ $self->cpan_userid
+ )->as_string);
+
+ my $wrap = qq{I\'d recommend removing $chk_file. Its signature
+is invalid. Maybe you have configured your 'urllist' with
+a bad URL. Please check this array with 'o conf urllist', and
+retry.};
+
+ $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
+ }
+}
+
+#-> sub CPAN::Distribution::CHECKSUM_check_file ;
+
+# sloppy is 1 when we have an old checksums file that maybe is good
+# enough
+
+sub CHECKSUM_check_file {
+ my($self,$chk_file,$sloppy) = @_;
+ my($cksum,$file,$basename);
+
+ $sloppy ||= 0;
+ $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
+ my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
+ q{check_sigs});
+ if ($check_sigs) {
+ if ($CPAN::META->has_inst("Module::Signature")) {
+ $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
+ $self->SIG_check_file($chk_file);
+ } else {
+ $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
+ }
+ }
+
+ $file = $self->{localfile};
+ $basename = File::Basename::basename($file);
+ my $fh = FileHandle->new;
+ if (open $fh, $chk_file) {
+ local($/);
+ my $eval = <$fh>;
+ $eval =~ s/\015?\012/\n/g;
+ close $fh;
+ my($compmt) = Safe->new();
+ $cksum = $compmt->reval($eval);
+ if ($@) {
+ rename $chk_file, "$chk_file.bad";
+ Carp::confess($@) if $@;
+ }
+ } else {
+ Carp::carp "Could not open $chk_file for reading";
+ }
+
+ if (! ref $cksum or ref $cksum ne "HASH") {
+ $CPAN::Frontend->mywarn(qq{
+Warning: checksum file '$chk_file' broken.
+
+When trying to read that file I expected to get a hash reference
+for further processing, but got garbage instead.
+});
+ my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
+ $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
+ $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
+ return;
+ } elsif (exists $cksum->{$basename}{sha256}) {
+ $self->debug("Found checksum for $basename:" .
+ "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
+
+ open($fh, $file);
+ binmode $fh;
+ my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
+ $fh->close;
+ $fh = CPAN::Tarzip->TIEHANDLE($file);
+
+ unless ($eq) {
+ my $dg = Digest::SHA->new(256);
+ my($data,$ref);
+ $ref = \$data;
+ while ($fh->READ($ref, 4096) > 0) {
+ $dg->add($data);
+ }
+ my $hexdigest = $dg->hexdigest;
+ $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
+ }
+
+ if ($eq) {
+ $CPAN::Frontend->myprint("Checksum for $file ok\n");
+ return $self->{CHECKSUM_STATUS} = "OK";
+ } else {
+ $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
+ qq{distribution file. }.
+ qq{Please investigate.\n\n}.
+ $self->as_string,
+ $CPAN::META->instance(
+ 'CPAN::Author',
+ $self->cpan_userid
+ )->as_string);
+
+ my $wrap = qq{I\'d recommend removing $file. Its
+checksum is incorrect. Maybe you have configured your 'urllist' with
+a bad URL. Please check this array with 'o conf urllist', and
+retry.};
+
+ $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
+
+ # former versions just returned here but this seems a
+ # serious threat that deserves a die
+
+ # $CPAN::Frontend->myprint("\n\n");
+ # sleep 3;
+ # return;
+ }
+ # close $fh if fileno($fh);
+ } else {
+ return if $sloppy;
+ unless ($self->{CHECKSUM_STATUS}) {
+ $CPAN::Frontend->mywarn(qq{
+Warning: No checksum for $basename in $chk_file.
+
+The cause for this may be that the file is very new and the checksum
+has not yet been calculated, but it may also be that something is
+going awry right now.
+});
+ my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
+ $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
+ }
+ $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
+ return;
+ }
+}
+
+#-> sub CPAN::Distribution::eq_CHECKSUM ;
+sub eq_CHECKSUM {
+ my($self,$fh,$expect) = @_;
+ if ($CPAN::META->has_inst("Digest::SHA")) {
+ my $dg = Digest::SHA->new(256);
+ my($data);
+ while (read($fh, $data, 4096)) {
+ $dg->add($data);
+ }
+ my $hexdigest = $dg->hexdigest;
+ # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
+ return $hexdigest eq $expect;
+ }
+ return 1;
+}
+
+#-> sub CPAN::Distribution::force ;
+
+# Both CPAN::Modules and CPAN::Distributions know if "force" is in
+# effect by autoinspection, not by inspecting a global variable. One
+# of the reason why this was chosen to work that way was the treatment
+# of dependencies. They should not automatically inherit the force
+# status. But this has the downside that ^C and die() will return to
+# the prompt but will not be able to reset the force_update
+# attributes. We try to correct for it currently in the read_metadata
+# routine, and immediately before we check for a Signal. I hope this
+# works out in one of v1.57_53ff
+
+# "Force get forgets previous error conditions"
+
+#-> sub CPAN::Distribution::fforce ;
+sub fforce {
+ my($self, $method) = @_;
+ $self->force($method,1);
+}
+
+#-> sub CPAN::Distribution::force ;
+sub force {
+ my($self, $method,$fforce) = @_;
+ my %phase_map = (
+ get => [
+ "unwrapped",
+ "build_dir",
+ "archived",
+ "localfile",
+ "CHECKSUM_STATUS",
+ "signature_verify",
+ "prefs",
+ "prefs_file",
+ "prefs_file_doc",
+ ],
+ make => [
+ "writemakefile",
+ "make",
+ "modulebuild",
+ "prereq_pm",
+ ],
+ test => [
+ "badtestcnt",
+ "make_test",
+ ],
+ install => [
+ "install",
+ ],
+ unknown => [
+ "reqtype",
+ "yaml_content",
+ ],
+ );
+ my $methodmatch = 0;
+ my $ldebug = 0;
+ PHASE: for my $phase (qw(unknown get make test install)) { # order matters
+ $methodmatch = 1 if $fforce || $phase eq $method;
+ next unless $methodmatch;
+ ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
+ if ($phase eq "get") {
+ if (substr($self->id,-1,1) eq "."
+ && $att =~ /(unwrapped|build_dir|archived)/ ) {
+ # cannot be undone for local distros
+ next ATTRIBUTE;
+ }
+ if ($att eq "build_dir"
+ && $self->{build_dir}
+ && $CPAN::META->{is_tested}
+ ) {
+ delete $CPAN::META->{is_tested}{$self->{build_dir}};
+ }
+ } elsif ($phase eq "test") {
+ if ($att eq "make_test"
+ && $self->{make_test}
+ && $self->{make_test}{COMMANDID}
+ && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
+ ) {
+ # endless loop too likely
+ next ATTRIBUTE;
+ }
+ }
+ delete $self->{$att};
+ if ($ldebug || $CPAN::DEBUG) {
+ # local $CPAN::DEBUG = 16; # Distribution
+ CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
+ }
+ }
+ }
+ if ($method && $method =~ /make|test|install/) {
+ $self->{force_update} = 1; # name should probably have been force_install
+ }
+}
+
+#-> sub CPAN::Distribution::notest ;
+sub notest {
+ my($self, $method) = @_;
+ # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method");
+ $self->{"notest"}++; # name should probably have been force_install
+}
+
+#-> sub CPAN::Distribution::unnotest ;
+sub unnotest {
+ my($self) = @_;
+ # warn "XDEBUG: deleting notest";
+ delete $self->{notest};
+}
+
+#-> sub CPAN::Distribution::unforce ;
+sub unforce {
+ my($self) = @_;
+ delete $self->{force_update};
+}
+
+#-> sub CPAN::Distribution::isa_perl ;
+sub isa_perl {
+ my($self) = @_;
+ my $file = File::Basename::basename($self->id);
+ if ($file =~ m{ ^ perl
+ (
+ -5\.\d+\.\d+
+ |
+ 5[._-]00[0-5](_[0-4][0-9])?
+ )
+ \.tar[._-](?:gz|bz2)
+ (?!\n)\Z
+ }xs) {
+ return "$1.$3";
+ } elsif ($self->cpan_comment
+ &&
+ $self->cpan_comment =~ /isa_perl\(.+?\)/) {
+ return $1;
+ }
+}
+
+
+#-> sub CPAN::Distribution::perl ;
+sub perl {
+ my ($self) = @_;
+ if (! $self) {
+ use Carp qw(carp);
+ carp __PACKAGE__ . "::perl was called without parameters.";
+ }
+ return CPAN::HandleConfig->safe_quote($CPAN::Perl);
+}
+
+#-> sub CPAN::Distribution::shortcut_prepare ;
+# return values: undef means don't shortcut; 0 means shortcut as fail;
+# and 1 means shortcut as success
+
+sub shortcut_prepare {
+ my ($self) = @_;
+
+ $self->debug("checking archive type[$self->{ID}]") if $CPAN::DEBUG;
+ if (!$self->{archived} || $self->{archived} eq "NO") {
+ return $self->goodbye("Is neither a tar nor a zip archive.");
+ }
+
+ $self->debug("checking unwrapping[$self->{ID}]") if $CPAN::DEBUG;
+ if (!$self->{unwrapped}
+ || (
+ UNIVERSAL::can($self->{unwrapped},"failed") ?
+ $self->{unwrapped}->failed :
+ $self->{unwrapped} =~ /^NO/
+ )) {
+ return $self->goodbye("Had problems unarchiving. Please build manually");
+ }
+
+ $self->debug("checking signature[$self->{ID}]") if $CPAN::DEBUG;
+ if ( ! $self->{force_update}
+ && exists $self->{signature_verify}
+ && (
+ UNIVERSAL::can($self->{signature_verify},"failed") ?
+ $self->{signature_verify}->failed :
+ $self->{signature_verify} =~ /^NO/
+ )
+ ) {
+ return $self->goodbye("Did not pass the signature test.");
+ }
+
+ $self->debug("checking writemakefile[$self->{ID}]") if $CPAN::DEBUG;
+ if ($self->{writemakefile}) {
+ if (
+ UNIVERSAL::can($self->{writemakefile},"failed") ?
+ $self->{writemakefile}->failed :
+ $self->{writemakefile} =~ /^NO/
+ ) {
+ # XXX maybe a retry would be in order?
+ my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
+ $self->{writemakefile}->text :
+ $self->{writemakefile};
+ $err =~ s/^NO\s*(--\s+)?//;
+ $err ||= "Had some problem writing Makefile";
+ $err .= ", not re-running";
+ return $self->goodbye($err);
+ } else {
+ return $self->success("Has already been prepared");
+ }
+ }
+
+ $self->debug("checking configure_requires_later[$self->{ID}]") if $CPAN::DEBUG;
+ if( my $later = $self->{configure_requires_later} ) { # see also undelay
+ return $self->goodbye($later);
+ }
+
+ return undef; # no shortcut
+}
+
+sub prepare {
+ my ($self) = @_;
+
+ $self->get
+ or return;
+
+ if ( defined( my $sc = $self->shortcut_prepare) ) {
+ return $sc;
+ }
+
+ local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
+ ? $ENV{PERL5LIB}
+ : ($ENV{PERLLIB} || "");
+ local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
+ local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # prepare
+ $CPAN::META->set_perl5lib;
+ local $ENV{MAKEFLAGS}; # protect us from outer make calls
+
+ if ($CPAN::Signal) {
+ delete $self->{force_update};
+ return;
+ }
+
+ my $builddir = $self->dir or
+ $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
+
+ unless (chdir $builddir) {
+ $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
+ return;
+ }
+
+ if ($CPAN::Signal) {
+ delete $self->{force_update};
+ return;
+ }
+
+ $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
+
+ local $ENV{PERL_AUTOINSTALL} = $ENV{PERL_AUTOINSTALL} || '';
+ local $ENV{PERL_EXTUTILS_AUTOINSTALL} = $ENV{PERL_EXTUTILS_AUTOINSTALL} || '';
+ $self->choose_MM_or_MB
+ or return;
+
+ my $configurator = $self->{configure} ? "Configure"
+ : $self->{modulebuild} ? "Build.PL"
+ : "Makefile.PL";
+
+ $CPAN::Frontend->myprint("Configuring ".$self->id." with $configurator\n");
+
+ if ($CPAN::Config->{prerequisites_policy} eq "follow") {
+ $ENV{PERL_AUTOINSTALL} ||= "--defaultdeps";
+ $ENV{PERL_EXTUTILS_AUTOINSTALL} ||= "--defaultdeps";
+ }
+
+ my $system;
+ my $pl_commandline;
+ if ($self->prefs->{pl}) {
+ $pl_commandline = $self->prefs->{pl}{commandline};
+ }
+ local $ENV{PERL} = defined $ENV{PERL}? $ENV{PERL} : $^X;
+ local $ENV{PERL5_CPAN_IS_EXECUTING} = $ENV{PERL5_CPAN_IS_EXECUTING} || '';
+ local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
+ local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
+ if ($pl_commandline) {
+ $system = $pl_commandline;
+ $ENV{PERL} = $^X;
+ } elsif ($self->{'configure'}) {
+ $system = $self->{'configure'};
+ } elsif ($self->{modulebuild}) {
+ my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
+ my $mbuildpl_arg = $self->_make_phase_arg("pl");
+ $system = sprintf("%s Build.PL%s",
+ $perl,
+ $mbuildpl_arg ? " $mbuildpl_arg" : "",
+ );
+ } else {
+ my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
+ my $switch = "";
+# This needs a handler that can be turned on or off:
+# $switch = "-MExtUtils::MakeMaker ".
+# "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
+# if $] > 5.00310;
+ my $makepl_arg = $self->_make_phase_arg("pl");
+ $ENV{PERL5_CPAN_IS_EXECUTING} = File::Spec->catfile($self->{build_dir},
+ "Makefile.PL");
+ $system = sprintf("%s%s Makefile.PL%s",
+ $perl,
+ $switch ? " $switch" : "",
+ $makepl_arg ? " $makepl_arg" : "",
+ );
+ }
+ my $pl_env;
+ if ($self->prefs->{pl}) {
+ $pl_env = $self->prefs->{pl}{env};
+ }
+ local @ENV{keys %$pl_env} = values %$pl_env if $pl_env;
+ if (exists $self->{writemakefile}) {
+ } else {
+ local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
+ my($ret,$pid,$output);
+ $@ = "";
+ my $go_via_alarm;
+ if ($CPAN::Config->{inactivity_timeout}) {
+ require Config;
+ if ($Config::Config{d_alarm}
+ &&
+ $Config::Config{d_alarm} eq "define"
+ ) {
+ $go_via_alarm++
+ } else {
+ $CPAN::Frontend->mywarn("Warning: you have configured the config ".
+ "variable 'inactivity_timeout' to ".
+ "'$CPAN::Config->{inactivity_timeout}'. But ".
+ "on this machine the system call 'alarm' ".
+ "isn't available. This means that we cannot ".
+ "provide the feature of intercepting long ".
+ "waiting code and will turn this feature off.\n"
+ );
+ $CPAN::Config->{inactivity_timeout} = 0;
+ }
+ }
+ if ($go_via_alarm) {
+ if ( $self->_should_report('pl') ) {
+ ($output, $ret) = CPAN::Reporter::record_command(
+ $system,
+ $CPAN::Config->{inactivity_timeout},
+ );
+ CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
+ }
+ else {
+ eval {
+ alarm $CPAN::Config->{inactivity_timeout};
+ local $SIG{CHLD}; # = sub { wait };
+ if (defined($pid = fork)) {
+ if ($pid) { #parent
+ # wait;
+ waitpid $pid, 0;
+ } else { #child
+ # note, this exec isn't necessary if
+ # inactivity_timeout is 0. On the Mac I'd
+ # suggest, we set it always to 0.
+ exec $system;
+ }
+ } else {
+ $CPAN::Frontend->myprint("Cannot fork: $!");
+ return;
+ }
+ };
+ alarm 0;
+ if ($@) {
+ kill 9, $pid;
+ waitpid $pid, 0;
+ my $err = "$@";
+ $CPAN::Frontend->myprint($err);
+ $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
+ $@ = "";
+ $self->store_persistent_state;
+ return $self->goodbye("$system -- TIMED OUT");
+ }
+ }
+ } else {
+ if (my $expect_model = $self->_prefs_with_expect("pl")) {
+ # XXX probably want to check _should_report here and warn
+ # about not being able to use CPAN::Reporter with expect
+ $ret = $self->_run_via_expect($system,'writemakefile',$expect_model);
+ if (! defined $ret
+ && $self->{writemakefile}
+ && $self->{writemakefile}->failed) {
+ # timeout
+ return;
+ }
+ }
+ elsif ( $self->_should_report('pl') ) {
+ ($output, $ret) = eval { CPAN::Reporter::record_command($system) };
+ if (! defined $output or $@) {
+ my $err = $@ || "Unknown error";
+ $CPAN::Frontend->mywarn("Error while running PL phase: $err");
+ return $self->goodbye("$system -- NOT OK");
+ }
+ CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
+ }
+ else {
+ $ret = system($system);
+ }
+ if ($ret != 0) {
+ $self->{writemakefile} = CPAN::Distrostatus
+ ->new("NO '$system' returned status $ret");
+ $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
+ $self->store_persistent_state;
+ return $self->goodbye("$system -- NOT OK");
+ }
+ }
+ if (-f "Makefile" || -f "Build" || ($^O eq 'VMS' && (-f 'descrip.mms' || -f 'Build.com'))) {
+ $self->{writemakefile} = CPAN::Distrostatus->new("YES");
+ delete $self->{make_clean}; # if cleaned before, enable next
+ $self->store_persistent_state;
+ return $self->success("$system -- OK");
+ } else {
+ my $makefile = $self->{modulebuild} ? "Build" : "Makefile";
+ my $why = "No '$makefile' created";
+ $CPAN::Frontend->mywarn($why);
+ $self->{writemakefile} = CPAN::Distrostatus
+ ->new(qq{NO -- $why\n});
+ $self->store_persistent_state;
+ return $self->goodbye("$system -- NOT OK");
+ }
+ }
+ $self->store_persistent_state;
+ return 1; # success
+}
+
+#-> sub CPAN::Distribution::shortcut_make ;
+# return values: undef means don't shortcut; 0 means shortcut as fail;
+# and 1 means shortcut as success
+sub shortcut_make {
+ my ($self) = @_;
+
+ $self->debug("checking make/build results[$self->{ID}]") if $CPAN::DEBUG;
+ if (defined $self->{make}) {
+ if (UNIVERSAL::can($self->{make},"failed") ?
+ $self->{make}->failed :
+ $self->{make} =~ /^NO/
+ ) {
+ if ($self->{force_update}) {
+ # Trying an already failed 'make' (unless somebody else blocks)
+ return undef; # no shortcut
+ } else {
+ # introduced for turning recursion detection into a distrostatus
+ my $error = length $self->{make}>3
+ ? substr($self->{make},3) : "Unknown error";
+ $self->store_persistent_state;
+ return $self->goodbye("Could not make: $error\n");
+ }
+ } else {
+ return $self->success("Has already been made")
+ }
+ }
+ return undef; # no shortcut
+}
+
+#-> sub CPAN::Distribution::make ;
+sub make {
+ my($self) = @_;
+
+ $self->pre_make();
+
+ $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
+ if (my $goto = $self->prefs->{goto}) {
+ return $self->goto($goto);
+ }
+ # Emergency brake if they said install Pippi and get newest perl
+
+ # XXX Would this make more sense in shortcut_prepare, since
+ # that doesn't make sense on a perl dist either? Broader
+ # question: what is the purpose of suggesting force install
+ # on a perl distribution? That seems unlikely to result in
+ # such a dependency being satisfied, even if the perl is
+ # successfully installed. This situation is tantamount to
+ # a prereq on a version of perl greater than the current one
+ # so I think we should just abort. -- xdg, 2012-04-06
+ if ($self->isa_perl) {
+ if (
+ $self->called_for ne $self->id &&
+ ! $self->{force_update}
+ ) {
+ # if we die here, we break bundles
+ $CPAN::Frontend
+ ->mywarn(sprintf(
+ qq{The most recent version "%s" of the module "%s"
+is part of the perl-%s distribution. To install that, you need to run
+ force install %s --or--
+ install %s
+},
+ $CPAN::META->instance(
+ 'CPAN::Module',
+ $self->called_for
+ )->cpan_version,
+ $self->called_for,
+ $self->isa_perl,
+ $self->called_for,
+ $self->pretty_id,
+ ));
+ $self->{make} = CPAN::Distrostatus->new("NO isa perl");
+ $CPAN::Frontend->mysleep(1);
+ return;
+ }
+ }
+
+ $self->prepare
+ or return;
+
+ if ( defined( my $sc = $self->shortcut_make) ) {
+ return $sc;
+ }
+
+ if ($CPAN::Signal) {
+ delete $self->{force_update};
+ return;
+ }
+
+ my $builddir = $self->dir or
+ $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
+
+ unless (chdir $builddir) {
+ $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
+ return;
+ }
+
+ my $make = $self->{modulebuild} ? "Build" : "make";
+ $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
+ local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
+ ? $ENV{PERL5LIB}
+ : ($ENV{PERLLIB} || "");
+ local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
+ local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # make
+ $CPAN::META->set_perl5lib;
+ local $ENV{MAKEFLAGS}; # protect us from outer make calls
+
+ if ($CPAN::Signal) {
+ delete $self->{force_update};
+ return;
+ }
+
+ if ($^O eq 'MacOS') {
+ Mac::BuildTools::make($self);
+ return;
+ }
+
+ my %env;
+ while (my($k,$v) = each %ENV) {
+ next if defined $v;
+ $env{$k} = '';
+ }
+ local @ENV{keys %env} = values %env;
+ my $satisfied = eval { $self->satisfy_requires };
+ return $self->goodbye($@) if $@;
+ return unless $satisfied ;
+ if ($CPAN::Signal) {
+ delete $self->{force_update};
+ return;
+ }
+
+ # need to chdir again, because $self->satisfy_requires might change the directory
+ unless (chdir $builddir) {
+ $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
+ return;
+ }
+
+ my $system;
+ my $make_commandline;
+ if ($self->prefs->{make}) {
+ $make_commandline = $self->prefs->{make}{commandline};
+ }
+ local $ENV{PERL} = defined $ENV{PERL}? $ENV{PERL} : $^X;
+ local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
+ local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
+ if ($make_commandline) {
+ $system = $make_commandline;
+ $ENV{PERL} = CPAN::find_perl();
+ } else {
+ if ($self->{modulebuild}) {
+ unless (-f "Build" || ($^O eq 'VMS' && -f 'Build.com')) {
+ my $cwd = CPAN::anycwd();
+ $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
+ " in cwd[$cwd]. Danger, Will Robinson!\n");
+ $CPAN::Frontend->mysleep(5);
+ }
+ $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
+ } else {
+ $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
+ }
+ $system =~ s/\s+$//;
+ my $make_arg = $self->_make_phase_arg("make");
+ $system = sprintf("%s%s",
+ $system,
+ $make_arg ? " $make_arg" : "",
+ );
+ }
+ my $make_env;
+ if ($self->prefs->{make}) {
+ $make_env = $self->prefs->{make}{env};
+ }
+ local @ENV{keys %$make_env} = values %$make_env if $make_env;
+ my $expect_model = $self->_prefs_with_expect("make");
+ my $want_expect = 0;
+ if ( $expect_model && @{$expect_model->{talk}} ) {
+ my $can_expect = $CPAN::META->has_inst("Expect");
+ if ($can_expect) {
+ $want_expect = 1;
+ } else {
+ $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
+ "system()\n");
+ }
+ }
+ my ($system_ok, $system_err);
+ if ($want_expect) {
+ # XXX probably want to check _should_report here and
+ # warn about not being able to use CPAN::Reporter with expect
+ $system_ok = $self->_run_via_expect($system,'make',$expect_model) == 0;
+ }
+ elsif ( $self->_should_report('make') ) {
+ my ($output, $ret) = CPAN::Reporter::record_command($system);
+ CPAN::Reporter::grade_make( $self, $system, $output, $ret );
+ $system_ok = ! $ret;
+ }
+ else {
+ my $rc = system($system);
+ $system_ok = $rc == 0;
+ $system_err = $! if $rc == -1;
+ }
+ $self->introduce_myself;
+ if ( $system_ok ) {
+ $CPAN::Frontend->myprint(" $system -- OK\n");
+ $self->{make} = CPAN::Distrostatus->new("YES");
+ } else {
+ $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
+ $self->{make} = CPAN::Distrostatus->new("NO");
+ $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
+ $CPAN::Frontend->mywarn(" $system_err\n") if defined $system_err;
+ }
+ $self->store_persistent_state;
+
+ $self->post_make();
+
+ return !! $system_ok;
+}
+
+# CPAN::Distribution::goodbye ;
+sub goodbye {
+ my($self,$goodbye) = @_;
+ my $id = $self->pretty_id;
+ $CPAN::Frontend->mywarn(" $id\n $goodbye\n");
+ return 0; # must be explicit false, not undef
+}
+
+sub success {
+ my($self,$why) = @_;
+ my $id = $self->pretty_id;
+ $CPAN::Frontend->myprint(" $id\n $why\n");
+ return 1;
+}
+
+# CPAN::Distribution::_run_via_expect ;
+sub _run_via_expect {
+ my($self,$system,$phase,$expect_model) = @_;
+ CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
+ if ($CPAN::META->has_inst("Expect")) {
+ my $expo = Expect->new; # expo Expect object;
+ $expo->spawn($system);
+ $expect_model->{mode} ||= "deterministic";
+ if ($expect_model->{mode} eq "deterministic") {
+ return $self->_run_via_expect_deterministic($expo,$phase,$expect_model);
+ } elsif ($expect_model->{mode} eq "anyorder") {
+ return $self->_run_via_expect_anyorder($expo,$phase,$expect_model);
+ } else {
+ die "Panic: Illegal expect mode: $expect_model->{mode}";
+ }
+ } else {
+ $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
+ return system($system);
+ }
+}
+
+sub _run_via_expect_anyorder {
+ my($self,$expo,$phase,$expect_model) = @_;
+ my $timeout = $expect_model->{timeout} || 5;
+ my $reuse = $expect_model->{reuse};
+ my @expectacopy = @{$expect_model->{talk}}; # we trash it!
+ my $but = "";
+ my $timeout_start = time;
+ EXPECT: while () {
+ my($eof,$ran_into_timeout);
+ # XXX not up to the full power of expect. one could certainly
+ # wrap all of the talk pairs into a single expect call and on
+ # success tweak it and step ahead to the next question. The
+ # current implementation unnecessarily limits itself to a
+ # single match.
+ my @match = $expo->expect(1,
+ [ eof => sub {
+ $eof++;
+ } ],
+ [ timeout => sub {
+ $ran_into_timeout++;
+ } ],
+ -re => eval"qr{.}",
+ );
+ if ($match[2]) {
+ $but .= $match[2];
+ }
+ $but .= $expo->clear_accum;
+ if ($eof) {
+ $expo->soft_close;
+ return $expo->exitstatus();
+ } elsif ($ran_into_timeout) {
+ # warn "DEBUG: they are asking a question, but[$but]";
+ for (my $i = 0; $i <= $#expectacopy; $i+=2) {
+ my($next,$send) = @expectacopy[$i,$i+1];
+ my $regex = eval "qr{$next}";
+ # warn "DEBUG: will compare with regex[$regex].";
+ if ($but =~ /$regex/) {
+ # warn "DEBUG: will send send[$send]";
+ $expo->send($send);
+ # never allow reusing an QA pair unless they told us
+ splice @expectacopy, $i, 2 unless $reuse;
+ $but =~ s/(?s:^.*?)$regex//;
+ $timeout_start = time;
+ next EXPECT;
+ }
+ }
+ my $have_waited = time - $timeout_start;
+ if ($have_waited < $timeout) {
+ # warn "DEBUG: have_waited[$have_waited]timeout[$timeout]";
+ next EXPECT;
+ }
+ my $why = "could not answer a question during the dialog";
+ $CPAN::Frontend->mywarn("Failing: $why\n");
+ $self->{$phase} =
+ CPAN::Distrostatus->new("NO $why");
+ return 0;
+ }
+ }
+}
+
+sub _run_via_expect_deterministic {
+ my($self,$expo,$phase,$expect_model) = @_;
+ my $ran_into_timeout;
+ my $ran_into_eof;
+ my $timeout = $expect_model->{timeout} || 15; # currently unsettable
+ my $expecta = $expect_model->{talk};
+ EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
+ my($re,$send) = @$expecta[$i,$i+1];
+ CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
+ my $regex = eval "qr{$re}";
+ $expo->expect($timeout,
+ [ eof => sub {
+ my $but = $expo->clear_accum;
+ $CPAN::Frontend->mywarn("EOF (maybe harmless)
+expected[$regex]\nbut[$but]\n\n");
+ $ran_into_eof++;
+ } ],
+ [ timeout => sub {
+ my $but = $expo->clear_accum;
+ $CPAN::Frontend->mywarn("TIMEOUT
+expected[$regex]\nbut[$but]\n\n");
+ $ran_into_timeout++;
+ } ],
+ -re => $regex);
+ if ($ran_into_timeout) {
+ # note that the caller expects 0 for success
+ $self->{$phase} =
+ CPAN::Distrostatus->new("NO timeout during expect dialog");
+ return 0;
+ } elsif ($ran_into_eof) {
+ last EXPECT;
+ }
+ $expo->send($send);
+ }
+ $expo->soft_close;
+ return $expo->exitstatus();
+}
+
+#-> CPAN::Distribution::_validate_distropref
+sub _validate_distropref {
+ my($self,@args) = @_;
+ if (
+ $CPAN::META->has_inst("CPAN::Kwalify")
+ &&
+ $CPAN::META->has_inst("Kwalify")
+ ) {
+ eval {CPAN::Kwalify::_validate("distroprefs",@args);};
+ if ($@) {
+ $CPAN::Frontend->mywarn($@);
+ }
+ } else {
+ CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
+ }
+}
+
+#-> CPAN::Distribution::_find_prefs
+sub _find_prefs {
+ my($self) = @_;
+ my $distroid = $self->pretty_id;
+ #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
+ my $prefs_dir = $CPAN::Config->{prefs_dir};
+ return if $prefs_dir =~ /^\s*$/;
+ eval { File::Path::mkpath($prefs_dir); };
+ if ($@) {
+ $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
+ }
+ # shortcut if there are no distroprefs files
+ {
+ my $dh = DirHandle->new($prefs_dir) or $CPAN::Frontend->mydie("Couldn't open '$prefs_dir': $!");
+ my @files = map { /\.(yml|dd|st)\z/i } $dh->read;
+ return unless @files;
+ }
+ my $yaml_module = CPAN::_yaml_module();
+ my $ext_map = {};
+ my @extensions;
+ if ($CPAN::META->has_inst($yaml_module)) {
+ $ext_map->{yml} = 'CPAN';
+ } else {
+ my @fallbacks;
+ if ($CPAN::META->has_inst("Data::Dumper")) {
+ push @fallbacks, $ext_map->{dd} = 'Data::Dumper';
+ }
+ if ($CPAN::META->has_inst("Storable")) {
+ push @fallbacks, $ext_map->{st} = 'Storable';
+ }
+ if (@fallbacks) {
+ local $" = " and ";
+ unless ($self->{have_complained_about_missing_yaml}++) {
+ $CPAN::Frontend->mywarnonce("'$yaml_module' not installed, falling back ".
+ "to @fallbacks to read prefs '$prefs_dir'\n");
+ }
+ } else {
+ unless ($self->{have_complained_about_missing_yaml}++) {
+ $CPAN::Frontend->mywarnonce("'$yaml_module' not installed, cannot ".
+ "read prefs '$prefs_dir'\n");
+ }
+ }
+ }
+ my $finder = CPAN::Distroprefs->find($prefs_dir, $ext_map);
+ DIRENT: while (my $result = $finder->next) {
+ if ($result->is_warning) {
+ $CPAN::Frontend->mywarn($result->as_string);
+ $CPAN::Frontend->mysleep(1);
+ next DIRENT;
+ } elsif ($result->is_fatal) {
+ $CPAN::Frontend->mydie($result->as_string);
+ }
+
+ my @prefs = @{ $result->prefs };
+
+ ELEMENT: for my $y (0..$#prefs) {
+ my $pref = $prefs[$y];
+ $self->_validate_distropref($pref->data, $result->abs, $y);
+
+ # I don't know why we silently skip when there's no match, but
+ # complain if there's an empty match hashref, and there's no
+ # comment explaining why -- hdp, 2008-03-18
+ unless ($pref->has_any_match) {
+ next ELEMENT;
+ }
+
+ unless ($pref->has_valid_subkeys) {
+ $CPAN::Frontend->mydie(sprintf
+ "Nonconforming .%s file '%s': " .
+ "missing match/* subattribute. " .
+ "Please remove, cannot continue.",
+ $result->ext, $result->abs,
+ );
+ }
+
+ my $arg = {
+ env => \%ENV,
+ distribution => $distroid,
+ perl => \&CPAN::find_perl,
+ perlconfig => \%Config::Config,
+ module => sub { [ $self->containsmods ] },
+ };
+
+ if ($pref->matches($arg)) {
+ return {
+ prefs => $pref->data,
+ prefs_file => $result->abs,
+ prefs_file_doc => $y,
+ };
+ }
+
+ }
+ }
+ return;
+}
+
+# CPAN::Distribution::prefs
+sub prefs {
+ my($self) = @_;
+ if (exists $self->{negative_prefs_cache}
+ &&
+ $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
+ ) {
+ delete $self->{negative_prefs_cache};
+ delete $self->{prefs};
+ }
+ if (exists $self->{prefs}) {
+ return $self->{prefs}; # XXX comment out during debugging
+ }
+ if ($CPAN::Config->{prefs_dir}) {
+ CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
+ my $prefs = $self->_find_prefs();
+ $prefs ||= ""; # avoid warning next line
+ CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
+ if ($prefs) {
+ for my $x (qw(prefs prefs_file prefs_file_doc)) {
+ $self->{$x} = $prefs->{$x};
+ }
+ my $bs = sprintf(
+ "%s[%s]",
+ File::Basename::basename($self->{prefs_file}),
+ $self->{prefs_file_doc},
+ );
+ my $filler1 = "_" x 22;
+ my $filler2 = int(66 - length($bs))/2;
+ $filler2 = 0 if $filler2 < 0;
+ $filler2 = " " x $filler2;
+ $CPAN::Frontend->myprint("
+$filler1 D i s t r o P r e f s $filler1
+$filler2 $bs $filler2
+");
+ $CPAN::Frontend->mysleep(1);
+ return $self->{prefs};
+ }
+ }
+ $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
+ return $self->{prefs} = +{};
+}
+
+# CPAN::Distribution::_make_phase_arg
+sub _make_phase_arg {
+ my($self, $phase) = @_;
+ my $_make_phase_arg;
+ my $prefs = $self->prefs;
+ if (
+ $prefs
+ && exists $prefs->{$phase}
+ && exists $prefs->{$phase}{args}
+ && $prefs->{$phase}{args}
+ ) {
+ $_make_phase_arg = join(" ",
+ map {CPAN::HandleConfig
+ ->safe_quote($_)} @{$prefs->{$phase}{args}},
+ );
+ }
+
+# cpan[2]> o conf make[TAB]
+# make make_install_make_command
+# make_arg makepl_arg
+# make_install_arg
+# cpan[2]> o conf mbuild[TAB]
+# mbuild_arg mbuild_install_build_command
+# mbuild_install_arg mbuildpl_arg
+
+ my $mantra; # must switch make/mbuild here
+ if ($self->{modulebuild}) {
+ $mantra = "mbuild";
+ } else {
+ $mantra = "make";
+ }
+ my %map = (
+ pl => "pl_arg",
+ make => "_arg",
+ test => "_test_arg", # does not really exist but maybe
+ # will some day and now protects
+ # us from unini warnings
+ install => "_install_arg",
+ );
+ my $phase_underscore_meshup = $map{$phase};
+ my $what = sprintf "%s%s", $mantra, $phase_underscore_meshup;
+
+ $_make_phase_arg ||= $CPAN::Config->{$what};
+ return $_make_phase_arg;
+}
+
+# CPAN::Distribution::_make_command
+sub _make_command {
+ my ($self) = @_;
+ if ($self) {
+ return
+ CPAN::HandleConfig
+ ->safe_quote(
+ CPAN::HandleConfig->prefs_lookup($self,
+ q{make})
+ || $Config::Config{make}
+ || 'make'
+ );
+ } else {
+ # Old style call, without object. Deprecated
+ Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
+ return
+ safe_quote(undef,
+ CPAN::HandleConfig->prefs_lookup($self,q{make})
+ || $CPAN::Config->{make}
+ || $Config::Config{make}
+ || 'make');
+ }
+}
+
+sub _make_install_make_command {
+ my ($self) = @_;
+ my $mimc =
+ CPAN::HandleConfig->prefs_lookup($self, q{make_install_make_command});
+ return $self->_make_command() unless $mimc;
+
+ # Quote the "make install" make command on Windows, where it is commonly
+ # found in, e.g., C:\Program Files\... and therefore needs quoting. We can't
+ # do this in general because the command maybe "sudo make..." (i.e. a
+ # program with arguments), but that is unlikely to be the case on Windows.
+ $mimc = CPAN::HandleConfig->safe_quote($mimc) if $^O eq 'MSWin32';
+
+ return $mimc;
+}
+
+#-> sub CPAN::Distribution::is_locally_optional
+sub is_locally_optional {
+ my($self, $prereq_pm, $prereq) = @_;
+ $prereq_pm ||= $self->{prereq_pm};
+ my($nmo,$opt);
+ for my $rt (qw(requires build_requires)) {
+ if (exists $prereq_pm->{$rt}{$prereq}) {
+ # rt 121914
+ $nmo ||= $CPAN::META->instance("CPAN::Module",$prereq);
+ my $av = $nmo->available_version;
+ return 0 if !$av || CPAN::Version->vlt($av,$prereq_pm->{$rt}{$prereq});
+ }
+ if (exists $prereq_pm->{"opt_$rt"}{$prereq}) {
+ $opt = 1;
+ }
+ }
+ return $opt||0;
+}
+
+#-> sub CPAN::Distribution::follow_prereqs ;
+sub follow_prereqs {
+ my($self) = shift;
+ my($slot) = shift;
+ my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
+ return unless @prereq_tuples;
+ my(@good_prereq_tuples);
+ for my $p (@prereq_tuples) {
+ # e.g. $p = ['Devel::PartialDump', 'r', 1]
+ # promote if possible
+ if ($p->[1] =~ /^(r|c)$/) {
+ push @good_prereq_tuples, $p;
+ } elsif ($p->[1] =~ /^(b)$/) {
+ my $reqtype = CPAN::Queue->reqtype_of($p->[0]);
+ if ($reqtype =~ /^(r|c)$/) {
+ push @good_prereq_tuples, [$p->[0], $reqtype, $p->[2]];
+ } else {
+ push @good_prereq_tuples, $p;
+ }
+ } else {
+ die "Panic: in follow_prereqs: reqtype[$p->[1]] seen, should never happen";
+ }
+ }
+ my $pretty_id = $self->pretty_id;
+ my %map = (
+ b => "build_requires",
+ r => "requires",
+ c => "commandline",
+ );
+ my($filler1,$filler2,$filler3,$filler4);
+ my $unsat = "Unsatisfied dependencies detected during";
+ my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
+ {
+ my $r = int(($w - length($unsat))/2);
+ my $l = $w - length($unsat) - $r;
+ $filler1 = "-"x4 . " "x$l;
+ $filler2 = " "x$r . "-"x4 . "\n";
+ }
+ {
+ my $r = int(($w - length($pretty_id))/2);
+ my $l = $w - length($pretty_id) - $r;
+ $filler3 = "-"x4 . " "x$l;
+ $filler4 = " "x$r . "-"x4 . "\n";
+ }
+ $CPAN::Frontend->
+ myprint("$filler1 $unsat $filler2".
+ "$filler3 $pretty_id $filler4".
+ join("", map {sprintf " %s \[%s%s]\n", $_->[0], $map{$_->[1]}, $self->is_locally_optional(undef,$_->[0]) ? ",optional" : ""} @good_prereq_tuples),
+ );
+ my $follow = 0;
+ if ($CPAN::Config->{prerequisites_policy} eq "follow") {
+ $follow = 1;
+ } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
+ my $answer = CPAN::Shell::colorable_makemaker_prompt(
+"Shall I follow them and prepend them to the queue
+of modules we are processing right now?", "yes");
+ $follow = $answer =~ /^\s*y/i;
+ } else {
+ my @prereq = map { $_->[0] } @good_prereq_tuples;
+ local($") = ", ";
+ $CPAN::Frontend->
+ myprint(" Ignoring dependencies on modules @prereq\n");
+ }
+ if ($follow) {
+ my $id = $self->id;
+ my(@to_queue_mand,@to_queue_opt);
+ for my $gp (@good_prereq_tuples) {
+ my($prereq,$reqtype,$optional) = @$gp;
+ my $qthing = +{qmod=>$prereq,reqtype=>$reqtype,optional=>$optional};
+ if ($optional &&
+ $self->is_locally_optional(undef,$prereq)
+ ){
+ # Since we do not depend on this one, we do not need
+ # this in a mandatory arrangement:
+ push @to_queue_opt, $qthing;
+ } else {
+ my $any = CPAN::Shell->expandany($prereq);
+ $self->{$slot . "_for"}{$any->id}++;
+ if ($any) {
+ unless ($optional) {
+ # No recursion check in an optional area of the tree
+ $any->color_cmd_tmps(0,2);
+ }
+ } else {
+ $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$prereq'\n");
+ $CPAN::Frontend->mysleep(2);
+ }
+ # order everything that is not locally_optional just
+ # like mandatory items: this keeps leaves before
+ # branches
+ unshift @to_queue_mand, $qthing;
+ }
+ }
+ if (@to_queue_mand) {
+ unshift @to_queue_mand, {qmod => $id, reqtype => $self->{reqtype}, optional=> !$self->{mandatory}};
+ CPAN::Queue->jumpqueue(@to_queue_opt,@to_queue_mand);
+ $self->{$slot} = "Delayed until after prerequisites";
+ return 1; # signal we need dependencies
+ } elsif (@to_queue_opt) {
+ CPAN::Queue->jumpqueue(@to_queue_opt);
+ }
+ }
+ return;
+}
+
+sub _feature_depends {
+ my($self) = @_;
+ my $meta_yml = $self->parse_meta_yml();
+ my $optf = $meta_yml->{optional_features} or return;
+ if (!ref $optf or ref $optf ne "HASH"){
+ $CPAN::Frontend->mywarn("The content of optional_features is not a HASH reference. Cannot use it.\n");
+ $optf = {};
+ }
+ my $wantf = $self->prefs->{features} or return;
+ if (!ref $wantf or ref $wantf ne "ARRAY"){
+ $CPAN::Frontend->mywarn("The content of 'features' is not an ARRAY reference. Cannot use it.\n");
+ $wantf = [];
+ }
+ my $dep = +{};
+ for my $wf (@$wantf) {
+ if (my $f = $optf->{$wf}) {
+ $CPAN::Frontend->myprint("Found the demanded feature '$wf' that ".
+ "is accompanied by this description:\n".
+ $f->{description}.
+ "\n\n"
+ );
+ # configure_requires currently not in the spec, unlikely to be useful anyway
+ for my $reqtype (qw(configure_requires build_requires requires)) {
+ my $reqhash = $f->{$reqtype} or next;
+ while (my($k,$v) = each %$reqhash) {
+ $dep->{$reqtype}{$k} = $v;
+ }
+ }
+ } else {
+ $CPAN::Frontend->mywarn("The demanded feature '$wf' was not ".
+ "found in the META.yml file".
+ "\n\n"
+ );
+ }
+ }
+ $dep;
+}
+
+sub prereqs_for_slot {
+ my($self,$slot) = @_;
+ my($prereq_pm);
+ unless ($CPAN::META->has_usable("CPAN::Meta::Requirements")) {
+ my $whynot = "not available";
+ if (defined $CPAN::Meta::Requirements::VERSION) {
+ $whynot = "version $CPAN::Meta::Requirements::VERSION not sufficient";
+ }
+ $CPAN::Frontend->mywarn("CPAN::Meta::Requirements $whynot\n");
+ my $before = "";
+ if ($self->{CALLED_FOR}){
+ if ($self->{CALLED_FOR} =~
+ /^(
+ CPAN::Meta::Requirements
+ |version
+ |parent
+ |ExtUtils::MakeMaker
+ |Test::Harness
+ )$/x) {
+ $CPAN::Frontend->mywarn("Setting requirements to nil as a workaround\n");
+ return;
+ }
+ $before = " before $self->{CALLED_FOR}";
+ }
+ $CPAN::Frontend->mydie("Please install CPAN::Meta::Requirements manually$before");
+ }
+ my $merged = CPAN::Meta::Requirements->new;
+ my $prefs_depends = $self->prefs->{depends}||{};
+ my $feature_depends = $self->_feature_depends();
+ if ($slot eq "configure_requires_later") {
+ for my $hash ( $self->configure_requires,
+ $prefs_depends->{configure_requires},
+ $feature_depends->{configure_requires},
+ ) {
+ $merged->add_requirements(
+ CPAN::Meta::Requirements->from_string_hash($hash)
+ );
+ }
+ if (-f "Build.PL"
+ && ! -f File::Spec->catfile($self->{build_dir},"Makefile.PL")
+ && ! $merged->requirements_for_module("Module::Build")
+ && ! $CPAN::META->has_inst("Module::Build")
+ ) {
+ $CPAN::Frontend->mywarn(
+ " Warning: CPAN.pm discovered Module::Build as undeclared prerequisite.\n".
+ " Adding it now as such.\n"
+ );
+ $CPAN::Frontend->mysleep(5);
+ $merged->add_minimum( "Module::Build" => 0 );
+ delete $self->{writemakefile};
+ }
+ $prereq_pm = {}; # configure_requires defined as "b"
+ } elsif ($slot eq "later") {
+ my $prereq_pm_0 = $self->prereq_pm || {};
+ for my $reqtype (qw(requires build_requires opt_requires opt_build_requires)) {
+ $prereq_pm->{$reqtype} = {%{$prereq_pm_0->{$reqtype}||{}}}; # copy to not pollute it
+ for my $dep ($prefs_depends,$feature_depends) {
+ for my $k (keys %{$dep->{$reqtype}||{}}) {
+ $prereq_pm->{$reqtype}{$k} = $dep->{$reqtype}{$k};
+ }
+ }
+ }
+ # XXX what about optional_req|breq? -- xdg, 2012-04-01
+ for my $hash (
+ $prereq_pm->{requires},
+ $prereq_pm->{build_requires},
+ $prereq_pm->{opt_requires},
+ $prereq_pm->{opt_build_requires},
+
+ ) {
+ $merged->add_requirements(
+ CPAN::Meta::Requirements->from_string_hash($hash)
+ );
+ }
+ } else {
+ die "Panic: illegal slot '$slot'";
+ }
+ return ($merged->as_string_hash, $prereq_pm);
+}
+
+#-> sub CPAN::Distribution::unsat_prereq ;
+# return ([Foo,"r"],[Bar,"b"]) for normal modules
+# return ([perl=>5.008]) if we need a newer perl than we are running under
+# (sorry for the inconsistency, it was an accident)
+sub unsat_prereq {
+ my($self,$slot) = @_;
+ my($merged_hash,$prereq_pm) = $self->prereqs_for_slot($slot);
+ my(@need);
+ unless ($CPAN::META->has_usable("CPAN::Meta::Requirements")) {
+ $CPAN::Frontend->mywarn("CPAN::Meta::Requirements not available, please install as soon as possible, trying to continue with severly limited capabilities\n");
+ return;
+ }
+ my $merged = CPAN::Meta::Requirements->from_string_hash($merged_hash);
+ my @merged = sort $merged->required_modules;
+ CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
+ NEED: for my $need_module ( @merged ) {
+ my $need_version = $merged->requirements_for_module($need_module);
+ my($available_version,$inst_file,$available_file,$nmo);
+ if ($need_module eq "perl") {
+ $available_version = $];
+ $available_file = CPAN::find_perl();
+ } else {
+ if (CPAN::_sqlite_running()) {
+ CPAN::Index->reload;
+ $CPAN::SQLite->search("CPAN::Module",$need_module);
+ }
+ $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
+ $inst_file = $nmo->inst_file || '';
+ $available_file = $nmo->available_file || '';
+ $available_version = $nmo->available_version;
+ if ($nmo->uptodate) {
+ my $accepts = eval {
+ $merged->accepts_module($need_module, $available_version);
+ };
+ unless ($accepts) {
+ my $rq = $merged->requirements_for_module( $need_module );
+ $CPAN::Frontend->mywarn(
+ "Warning: Version '$available_version' of ".
+ "'$need_module' is up to date but does not ".
+ "fulfill requirements ($rq). I will continue, ".
+ "but chances to succeed are low.\n");
+ }
+ next NEED;
+ }
+
+ # if they have not specified a version, we accept any installed one
+ if ( $available_file
+ and ( # a few quick short circuits
+ not defined $need_version
+ or $need_version eq '0' # "==" would trigger warning when not numeric
+ or $need_version eq "undef"
+ )) {
+ unless ($nmo->inst_deprecated) {
+ next NEED;
+ }
+ }
+ }
+
+ # We only want to install prereqs if either they're not installed
+ # or if the installed version is too old. We cannot omit this
+ # check, because if 'force' is in effect, nobody else will check.
+ # But we don't want to accept a deprecated module installed as part
+ # of the Perl core, so we continue if the available file is the installed
+ # one and is deprecated
+
+ if ( $available_file ) {
+ my $fulfills_all_version_rqs = $self->_fulfills_all_version_rqs
+ (
+ $need_module,
+ $available_file,
+ $available_version,
+ $need_version,
+ );
+ if ( $inst_file
+ && $available_file eq $inst_file
+ && $nmo->inst_deprecated
+ ) {
+ # continue installing as a prereq. we really want that
+ # because the deprecated module may spit out warnings
+ # and third party did not know until today. Only one
+ # exception is OK, because CPANPLUS is special after
+ # all:
+ if ( $fulfills_all_version_rqs and
+ $nmo->id =~ /^CPANPLUS(?:::Dist::Build)$/
+ ) {
+ # here we have an available version that is good
+ # enough although deprecated (preventing circular
+ # loop CPANPLUS => CPANPLUS::Dist::Build RT#83042)
+ next NEED;
+ }
+ } elsif (
+ $self->{reqtype} =~ /^(r|c)$/
+ && (exists $prereq_pm->{requires}{$need_module} || exists $prereq_pm->{opt_requires} )
+ && $nmo
+ && !$inst_file
+ ) {
+ # continue installing as a prereq; this may be a
+ # distro we already used when it was a build_requires
+ # so we did not install it. But suddenly somebody
+ # wants it as a requires
+ my $need_distro = $nmo->distribution;
+ if ($need_distro->{install} && $need_distro->{install}->failed && $need_distro->{install}->text =~ /is only/) {
+ CPAN->debug("promotion from build_requires to requires") if $CPAN::DEBUG;
+ delete $need_distro->{install}; # promote to another installation attempt
+ $need_distro->{reqtype} = "r";
+ $need_distro->install;
+ next NEED;
+ }
+ }
+ else {
+ next NEED if $fulfills_all_version_rqs;
+ }
+ }
+
+ if ($need_module eq "perl") {
+ return ["perl", $need_version];
+ }
+ $self->{sponsored_mods}{$need_module} ||= 0;
+ CPAN->debug("need_module[$need_module]s/s/n[$self->{sponsored_mods}{$need_module}]") if $CPAN::DEBUG;
+ if (my $sponsoring = $self->{sponsored_mods}{$need_module}++) {
+ # We have already sponsored it and for some reason it's still
+ # not available. So we do ... what??
+
+ # if we push it again, we have a potential infinite loop
+
+ # The following "next" was a very problematic construct.
+ # It helped a lot but broke some day and had to be
+ # replaced.
+
+ # We must be able to deal with modules that come again and
+ # again as a prereq and have themselves prereqs and the
+ # queue becomes long but finally we would find the correct
+ # order. The RecursiveDependency check should trigger a
+ # die when it's becoming too weird. Unfortunately removing
+ # this next breaks many other things.
+
+ # The bug that brought this up is described in Todo under
+ # "5.8.9 cannot install Compress::Zlib"
+
+ # next; # this is the next that had to go away
+
+ # The following "next NEED" are fine and the error message
+ # explains well what is going on. For example when the DBI
+ # fails and consequently DBD::SQLite fails and now we are
+ # processing CPAN::SQLite. Then we must have a "next" for
+ # DBD::SQLite. How can we get it and how can we identify
+ # all other cases we must identify?
+
+ my $do = $nmo->distribution;
+ next NEED unless $do; # not on CPAN
+ if (CPAN::Version->vcmp($need_version, $nmo->ro->{CPAN_VERSION}) > 0){
+ $CPAN::Frontend->mywarn("Warning: Prerequisite ".
+ "'$need_module => $need_version' ".
+ "for '$self->{ID}' seems ".
+ "not available according to the indices\n"
+ );
+ next NEED;
+ }
+ NOSAYER: for my $nosayer (
+ "unwrapped",
+ "writemakefile",
+ "signature_verify",
+ "make",
+ "make_test",
+ "install",
+ "make_clean",
+ ) {
+ if ($do->{$nosayer}) {
+ my $selfid = $self->pretty_id;
+ my $did = $do->pretty_id;
+ if (UNIVERSAL::can($do->{$nosayer},"failed") ?
+ $do->{$nosayer}->failed :
+ $do->{$nosayer} =~ /^NO/) {
+ if ($nosayer eq "make_test"
+ &&
+ $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
+ ) {
+ next NOSAYER;
+ }
+ ### XXX don't complain about missing optional deps -- xdg, 2012-04-01
+ if ($self->is_locally_optional($prereq_pm, $need_module)) {
+ # don't complain about failing optional prereqs
+ }
+ else {
+ $CPAN::Frontend->mywarn("Warning: Prerequisite ".
+ "'$need_module => $need_version' ".
+ "for '$selfid' failed when ".
+ "processing '$did' with ".
+ "'$nosayer => $do->{$nosayer}'. Continuing, ".
+ "but chances to succeed are limited.\n"
+ );
+ $CPAN::Frontend->mysleep($sponsoring/10);
+ }
+ next NEED;
+ } else { # the other guy succeeded
+ if ($nosayer =~ /^(install|make_test)$/) {
+ # we had this with
+ # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz
+ # in 2007-03 for 'make install'
+ # and 2008-04: #30464 (for 'make test')
+ # $CPAN::Frontend->mywarn("Warning: Prerequisite ".
+ # "'$need_module => $need_version' ".
+ # "for '$selfid' already built ".
+ # "but the result looks suspicious. ".
+ # "Skipping another build attempt, ".
+ # "to prevent looping endlessly.\n"
+ # );
+ next NEED;
+ }
+ }
+ }
+ }
+ }
+ my $needed_as;
+ if (0) {
+ } elsif (exists $prereq_pm->{requires}{$need_module}
+ || exists $prereq_pm->{opt_requires}{$need_module}
+ ) {
+ $needed_as = "r";
+ } elsif ($slot eq "configure_requires_later") {
+ # in ae872487d5 we said: C< we have not yet run the
+ # {Build,Makefile}.PL, we must presume "r" >; but the
+ # meta.yml standard says C< These dependencies are not
+ # required after the distribution is installed. >; so now
+ # we change it back to "b" and care for the proper
+ # promotion later.
+ $needed_as = "b";
+ } else {
+ $needed_as = "b";
+ }
+ # here need to flag as optional for recommends/suggests
+ # -- xdg, 2012-04-01
+ $self->debug(sprintf "%s manadory?[%s]",
+ $self->pretty_id,
+ $self->{mandatory})
+ if $CPAN::DEBUG;
+ my $optional = !$self->{mandatory}
+ || $self->is_locally_optional($prereq_pm, $need_module);
+ push @need, [$need_module,$needed_as,$optional];
+ }
+ my @unfolded = map { "[".join(",",@$_)."]" } @need;
+ CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
+ @need;
+}
+
+sub _fulfills_all_version_rqs {
+ my($self,$need_module,$available_file,$available_version,$need_version) = @_;
+ my(@all_requirements) = split /\s*,\s*/, $need_version;
+ local($^W) = 0;
+ my $ok = 0;
+ RQ: for my $rq (@all_requirements) {
+ if ($rq =~ s|>=\s*||) {
+ } elsif ($rq =~ s|>\s*||) {
+ # 2005-12: one user
+ if (CPAN::Version->vgt($available_version,$rq)) {
+ $ok++;
+ }
+ next RQ;
+ } elsif ($rq =~ s|!=\s*||) {
+ # 2005-12: no user
+ if (CPAN::Version->vcmp($available_version,$rq)) {
+ $ok++;
+ next RQ;
+ } else {
+ $ok=0;
+ last RQ;
+ }
+ } elsif ($rq =~ m|<=?\s*|) {
+ # 2005-12: no user
+ $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
+ $ok++;
+ next RQ;
+ } elsif ($rq =~ s|==\s*||) {
+ # 2009-07: ELLIOTJS/Perl-Critic-1.099_002.tar.gz
+ if (CPAN::Version->vcmp($available_version,$rq)) {
+ $ok=0;
+ last RQ;
+ } else {
+ $ok++;
+ next RQ;
+ }
+ }
+ if (! CPAN::Version->vgt($rq, $available_version)) {
+ $ok++;
+ }
+ CPAN->debug(sprintf("need_module[%s]available_file[%s]".
+ "available_version[%s]rq[%s]ok[%d]",
+ $need_module,
+ $available_file,
+ $available_version,
+ CPAN::Version->readable($rq),
+ $ok,
+ )) if $CPAN::DEBUG;
+ }
+ my $ret = $ok == @all_requirements;
+ CPAN->debug(sprintf("need_module[%s]ok[%s]all_requirements[%d]",$need_module, $ok, scalar @all_requirements)) if $CPAN::DEBUG;
+ return $ret;
+}
+
+#-> sub CPAN::Distribution::read_meta
+# read any sort of meta files, return CPAN::Meta object if no errors
+sub read_meta {
+ my($self) = @_;
+ my $meta_file = $self->pick_meta_file
+ or return;
+
+ return unless $CPAN::META->has_usable("CPAN::Meta");
+ my $meta = eval { CPAN::Meta->load_file($meta_file)}
+ or return;
+
+ # Very old EU::MM could have wrong META
+ if ($meta_file eq 'META.yml'
+ && $meta->generated_by =~ /ExtUtils::MakeMaker version ([\d\._]+)/
+ ) {
+ my $eummv = do { local $^W = 0; $1+0; };
+ return if $eummv < 6.2501;
+ }
+
+ return $meta;
+}
+
+#-> sub CPAN::Distribution::read_yaml ;
+# XXX This should be DEPRECATED -- dagolden, 2011-02-05
+sub read_yaml {
+ my($self) = @_;
+ my $meta_file = $self->pick_meta_file('\.yml$');
+ $self->debug("meta_file[$meta_file]") if $CPAN::DEBUG;
+ return unless $meta_file;
+ my $yaml;
+ eval { $yaml = $self->parse_meta_yml($meta_file) };
+ if ($@ or ! $yaml) {
+ return undef; # if we die, then we cannot read YAML's own META.yml
+ }
+ # not "authoritative"
+ if (defined $yaml && (! ref $yaml || ref $yaml ne "HASH")) {
+ $CPAN::Frontend->mywarn("META.yml does not seem to be conforming, cannot use it.\n");
+ $yaml = undef;
+ }
+ $self->debug(sprintf "yaml[%s]", $yaml || "UNDEF")
+ if $CPAN::DEBUG;
+ $self->debug($yaml) if $CPAN::DEBUG && $yaml;
+ # MYMETA.yml is static and authoritative by definition
+ if ( $meta_file =~ /MYMETA\.yml/ ) {
+ return $yaml;
+ }
+ # META.yml is authoritative only if dynamic_config is defined and false
+ if ( defined $yaml->{dynamic_config} && ! $yaml->{dynamic_config} ) {
+ return $yaml;
+ }
+ # otherwise, we can't use what we found
+ return undef;
+}
+
+#-> sub CPAN::Distribution::configure_requires ;
+sub configure_requires {
+ my($self) = @_;
+ return unless my $meta_file = $self->pick_meta_file('^META');
+ if (my $meta_obj = $self->read_meta) {
+ my $prereqs = $meta_obj->effective_prereqs;
+ my $cr = $prereqs->requirements_for(qw/configure requires/);
+ return $cr ? $cr->as_string_hash : undef;
+ }
+ else {
+ my $yaml = eval { $self->parse_meta_yml($meta_file) };
+ return $yaml->{configure_requires};
+ }
+}
+
+#-> sub CPAN::Distribution::prereq_pm ;
+sub prereq_pm {
+ my($self) = @_;
+ return unless $self->{writemakefile} # no need to have succeeded
+ # but we must have run it
+ || $self->{modulebuild};
+ unless ($self->{build_dir}) {
+ return;
+ }
+ # no Makefile/Build means configuration aborted, so don't look for prereqs
+ my $makefile = File::Spec->catfile($self->{build_dir}, $^O eq 'VMS' ? 'descrip.mms' : 'Makefile');
+ my $buildfile = File::Spec->catfile($self->{build_dir}, $^O eq 'VMS' ? 'Build.com' : 'Build');
+ return unless -f $makefile || -f $buildfile;
+ CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
+ $self->{writemakefile}||"",
+ $self->{modulebuild}||"",
+ ) if $CPAN::DEBUG;
+ my($req,$breq, $opt_req, $opt_breq);
+ my $meta_obj = $self->read_meta;
+ # META/MYMETA is only authoritative if dynamic_config is false
+ if ($meta_obj && ! $meta_obj->dynamic_config) {
+ my $prereqs = $meta_obj->effective_prereqs;
+ my $requires = $prereqs->requirements_for(qw/runtime requires/);
+ my $build_requires = $prereqs->requirements_for(qw/build requires/);
+ my $test_requires = $prereqs->requirements_for(qw/test requires/);
+ # XXX we don't yet distinguish build vs test, so merge them for now
+ $build_requires->add_requirements($test_requires);
+ $req = $requires->as_string_hash;
+ $breq = $build_requires->as_string_hash;
+
+ # XXX assemble optional_req && optional_breq from recommends/suggests
+ # depending on corresponding policies -- xdg, 2012-04-01
+ CPAN->use_inst("CPAN::Meta::Requirements");
+ my $opt_runtime = CPAN::Meta::Requirements->new;
+ my $opt_build = CPAN::Meta::Requirements->new;
+ if ( $CPAN::Config->{recommends_policy} ) {
+ $opt_runtime->add_requirements( $prereqs->requirements_for(qw/runtime recommends/));
+ $opt_build->add_requirements( $prereqs->requirements_for(qw/build recommends/));
+ $opt_build->add_requirements( $prereqs->requirements_for(qw/test recommends/));
+
+ }
+ if ( $CPAN::Config->{suggests_policy} ) {
+ $opt_runtime->add_requirements( $prereqs->requirements_for(qw/runtime suggests/));
+ $opt_build->add_requirements( $prereqs->requirements_for(qw/build suggests/));
+ $opt_build->add_requirements( $prereqs->requirements_for(qw/test suggests/));
+ }
+ $opt_req = $opt_runtime->as_string_hash;
+ $opt_breq = $opt_build->as_string_hash;
+ }
+ elsif (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
+ $req = $yaml->{requires} || {};
+ $breq = $yaml->{build_requires} || {};
+ if ( $CPAN::Config->{recommends_policy} ) {
+ $opt_req = $yaml->{recommends} || {};
+ }
+ undef $req unless ref $req eq "HASH" && %$req;
+ if ($req) {
+ if ($yaml->{generated_by} &&
+ $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
+ my $eummv = do { local $^W = 0; $1+0; };
+ if ($eummv < 6.2501) {
+ # thanks to Slaven for digging that out: MM before
+ # that could be wrong because it could reflect a
+ # previous release
+ undef $req;
+ }
+ }
+ my $areq;
+ my $do_replace;
+ foreach my $k (sort keys %{$req||{}}) {
+ my $v = $req->{$k};
+ next unless defined $v;
+ if ($v =~ /\d/) {
+ $areq->{$k} = $v;
+ } elsif ($k =~ /[A-Za-z]/ &&
+ $v =~ /[A-Za-z]/ &&
+ $CPAN::META->exists("CPAN::Module",$v)
+ ) {
+ $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
+ "requires hash: $k => $v; I'll take both ".
+ "key and value as a module name\n");
+ $CPAN::Frontend->mysleep(1);
+ $areq->{$k} = 0;
+ $areq->{$v} = 0;
+ $do_replace++;
+ }
+ }
+ $req = $areq if $do_replace;
+ }
+ }
+ else {
+ $CPAN::Frontend->mywarnonce("Could not read metadata file. Falling back to other ".
+ "methods to determine prerequisites\n");
+ }
+
+ unless ($req || $breq) {
+ my $build_dir;
+ unless ( $build_dir = $self->{build_dir} ) {
+ return;
+ }
+ my $makefile = File::Spec->catfile($build_dir,"Makefile");
+ my $fh;
+ if (-f $makefile
+ and
+ $fh = FileHandle->new("<$makefile\0")) {
+ CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
+ local($/) = "\n";
+ while (<$fh>) {
+ last if /MakeMaker post_initialize section/;
+ my($p) = m{^[\#]
+ \s+PREREQ_PM\s+=>\s+(.+)
+ }x;
+ next unless $p;
+ # warn "Found prereq expr[$p]";
+
+ # Regexp modified by A.Speer to remember actual version of file
+ # PREREQ_PM hash key wants, then add to
+ while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ) {
+ my($m,$n) = ($1,$2);
+ # When a prereq is mentioned twice: let the bigger
+ # win; usual culprit is that they declared
+ # build_requires separately from requires; see
+ # rt.cpan.org #47774
+ my($prevn);
+ if ( defined $req->{$m} ) {
+ $prevn = $req->{$m};
+ }
+ if ($n =~ /^q\[(.*?)\]$/) {
+ $n = $1;
+ }
+ if (!$prevn || CPAN::Version->vlt($prevn, $n)){
+ $req->{$m} = $n;
+ }
+ }
+ last;
+ }
+ }
+ }
+ unless ($req || $breq) {
+ my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
+ my $buildfile = File::Spec->catfile($build_dir,"Build");
+ if (-f $buildfile) {
+ CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
+ my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
+ if (-f $build_prereqs) {
+ CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
+ my $content = do { local *FH;
+ open FH, $build_prereqs
+ or $CPAN::Frontend->mydie("Could not open ".
+ "'$build_prereqs': $!");
+ local $/;
+ <FH>;
+ };
+ my $bphash = eval $content;
+ if ($@) {
+ } else {
+ $req = $bphash->{requires} || +{};
+ $breq = $bphash->{build_requires} || +{};
+ }
+ }
+ }
+ }
+ # XXX needs to be adapted for optional_req & optional_breq -- xdg, 2012-04-01
+ if ($req || $breq || $opt_req || $opt_breq ) {
+ return $self->{prereq_pm} = {
+ requires => $req,
+ build_requires => $breq,
+ opt_requires => $opt_req,
+ opt_build_requires => $opt_breq,
+ };
+ }
+}
+
+#-> sub CPAN::Distribution::shortcut_test ;
+# return values: undef means don't shortcut; 0 means shortcut as fail;
+# and 1 means shortcut as success
+sub shortcut_test {
+ my ($self) = @_;
+
+ $self->debug("checking badtestcnt[$self->{ID}]") if $CPAN::DEBUG;
+ $self->{badtestcnt} ||= 0;
+ if ($self->{badtestcnt} > 0) {
+ require Data::Dumper;
+ CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
+ return $self->goodbye("Won't repeat unsuccessful test during this command");
+ }
+
+ for my $slot ( qw/later configure_requires_later/ ) {
+ $self->debug("checking $slot slot[$self->{ID}]") if $CPAN::DEBUG;
+ return $self->success($self->{$slot})
+ if $self->{$slot};
+ }
+
+ $self->debug("checking if tests passed[$self->{ID}]") if $CPAN::DEBUG;
+ if ( $self->{make_test} ) {
+ if (
+ UNIVERSAL::can($self->{make_test},"failed") ?
+ $self->{make_test}->failed :
+ $self->{make_test} =~ /^NO/
+ ) {
+ if (
+ UNIVERSAL::can($self->{make_test},"commandid")
+ &&
+ $self->{make_test}->commandid == $CPAN::CurrentCommandId
+ ) {
+ return $self->goodbye("Has already been tested within this command");
+ }
+ } else {
+ # if global "is_tested" has been cleared, we need to mark this to
+ # be added to PERL5LIB if not already installed
+ if ($self->tested_ok_but_not_installed) {
+ $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
+ }
+ return $self->success("Has already been tested successfully");
+ }
+ }
+
+ if ($self->{notest}) {
+ $self->{make_test} = CPAN::Distrostatus->new("YES");
+ return $self->success("Skipping test because of notest pragma");
+ }
+
+ return undef; # no shortcut
+}
+
+#-> sub CPAN::Distribution::_exe_files ;
+sub _exe_files {
+ my($self) = @_;
+ return unless $self->{writemakefile} # no need to have succeeded
+ # but we must have run it
+ || $self->{modulebuild};
+ unless ($self->{build_dir}) {
+ return;
+ }
+ CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
+ $self->{writemakefile}||"",
+ $self->{modulebuild}||"",
+ ) if $CPAN::DEBUG;
+ my $build_dir;
+ unless ( $build_dir = $self->{build_dir} ) {
+ return;
+ }
+ my $makefile = File::Spec->catfile($build_dir,"Makefile");
+ my $fh;
+ my @exe_files;
+ if (-f $makefile
+ and
+ $fh = FileHandle->new("<$makefile\0")) {
+ CPAN->debug("Getting exefiles from Makefile") if $CPAN::DEBUG;
+ local($/) = "\n";
+ while (<$fh>) {
+ last if /MakeMaker post_initialize section/;
+ my($p) = m{^[\#]
+ \s+EXE_FILES\s+=>\s+\[(.+)\]
+ }x;
+ next unless $p;
+ # warn "Found exefiles expr[$p]";
+ my @p = split /,\s*/, $p;
+ for my $p2 (@p) {
+ if ($p2 =~ /^q\[(.+)\]/) {
+ push @exe_files, $1;
+ }
+ }
+ }
+ }
+ return \@exe_files if @exe_files;
+ my $buildparams = File::Spec->catfile($build_dir,"_build","build_params");
+ if (-f $buildparams) {
+ CPAN->debug("Found '$buildparams'") if $CPAN::DEBUG;
+ my $x = do $buildparams;
+ for my $sf (@{$x->[2]{script_files} || []}) {
+ push @exe_files, $sf;
+ }
+ }
+ return \@exe_files;
+}
+
+#-> sub CPAN::Distribution::test ;
+sub test {
+ my($self) = @_;
+
+ $self->pre_test();
+
+ $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
+ if (my $goto = $self->prefs->{goto}) {
+ return $self->goto($goto);
+ }
+
+ $self->make
+ or return;
+
+ if ( defined( my $sc = $self->shortcut_test ) ) {
+ return $sc;
+ }
+
+ if ($CPAN::Signal) {
+ delete $self->{force_update};
+ return;
+ }
+ # warn "XDEBUG: checking for notest: $self->{notest} $self";
+ my $make = $self->{modulebuild} ? "Build" : "make";
+
+ local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
+ ? $ENV{PERL5LIB}
+ : ($ENV{PERLLIB} || "");
+
+ local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
+ local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # test
+ $CPAN::META->set_perl5lib;
+ local $ENV{MAKEFLAGS}; # protect us from outer make calls
+ local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
+ local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
+
+ $CPAN::Frontend->myprint("Running $make test\n");
+
+ my $builddir = $self->dir or
+ $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
+
+ unless (chdir $builddir) {
+ $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
+ return;
+ }
+
+ $self->debug("Changed directory to $self->{build_dir}")
+ if $CPAN::DEBUG;
+
+ if ($^O eq 'MacOS') {
+ Mac::BuildTools::make_test($self);
+ return;
+ }
+
+ if ($self->{modulebuild}) {
+ my $thm = CPAN::Shell->expand("Module","Test::Harness");
+ my $v = $thm->inst_version;
+ if (CPAN::Version->vlt($v,2.62)) {
+ # XXX Eric Wilhelm reported this as a bug: klapperl:
+ # Test::Harness 3.0 self-tests, so that should be 'unless
+ # installing Test::Harness'
+ unless ($self->id eq $thm->distribution->id) {
+ $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
+ '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
+ $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
+ return;
+ }
+ }
+ }
+
+ if ( ! $self->{force_update} ) {
+ # bypass actual tests if "trust_test_report_history" and have a report
+ my $have_tested_fcn;
+ if ( $CPAN::Config->{trust_test_report_history}
+ && $CPAN::META->has_inst("CPAN::Reporter::History")
+ && ( $have_tested_fcn = CPAN::Reporter::History->can("have_tested" ))) {
+ if ( my @reports = $have_tested_fcn->( dist => $self->base_id ) ) {
+ # Do nothing if grade was DISCARD
+ if ( $reports[-1]->{grade} =~ /^(?:PASS|UNKNOWN)$/ ) {
+ $self->{make_test} = CPAN::Distrostatus->new("YES");
+ # if global "is_tested" has been cleared, we need to mark this to
+ # be added to PERL5LIB if not already installed
+ if ($self->tested_ok_but_not_installed) {
+ $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
+ }
+ $CPAN::Frontend->myprint("Found prior test report -- OK\n");
+ return;
+ }
+ elsif ( $reports[-1]->{grade} =~ /^(?:FAIL|NA)$/ ) {
+ $self->{make_test} = CPAN::Distrostatus->new("NO");
+ $self->{badtestcnt}++;
+ $CPAN::Frontend->mywarn("Found prior test report -- NOT OK\n");
+ return;
+ }
+ }
+ }
+ }
+
+ my $system;
+ my $prefs_test = $self->prefs->{test};
+ if (my $commandline
+ = exists $prefs_test->{commandline} ? $prefs_test->{commandline} : "") {
+ $system = $commandline;
+ $ENV{PERL} = CPAN::find_perl();
+ } elsif ($self->{modulebuild}) {
+ $system = sprintf "%s test", $self->_build_command();
+ unless (-e "Build" || ($^O eq 'VMS' && -e "Build.com")) {
+ my $id = $self->pretty_id;
+ $CPAN::Frontend->mywarn("Alert: no 'Build' file found while trying to test '$id'");
+ }
+ } else {
+ $system = join " ", $self->_make_command(), "test";
+ }
+ my $make_test_arg = $self->_make_phase_arg("test");
+ $system = sprintf("%s%s",
+ $system,
+ $make_test_arg ? " $make_test_arg" : "",
+ );
+ my($tests_ok);
+ my $test_env;
+ if ($self->prefs->{test}) {
+ $test_env = $self->prefs->{test}{env};
+ }
+ local @ENV{keys %$test_env} = values %$test_env if $test_env;
+ my $expect_model = $self->_prefs_with_expect("test");
+ my $want_expect = 0;
+ if ( $expect_model && @{$expect_model->{talk}} ) {
+ my $can_expect = $CPAN::META->has_inst("Expect");
+ if ($can_expect) {
+ $want_expect = 1;
+ } else {
+ $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
+ "testing without\n");
+ }
+ }
+ if ($want_expect) {
+ if ($self->_should_report('test')) {
+ $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
+ "not supported when distroprefs specify ".
+ "an interactive test\n");
+ }
+ $tests_ok = $self->_run_via_expect($system,'test',$expect_model) == 0;
+ } elsif ( $self->_should_report('test') ) {
+ $tests_ok = CPAN::Reporter::test($self, $system);
+ } else {
+ $tests_ok = system($system) == 0;
+ }
+ $self->introduce_myself;
+ my $but = $self->_make_test_illuminate_prereqs();
+ if ( $tests_ok ) {
+ if ($but) {
+ $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
+ $self->{make_test} = CPAN::Distrostatus->new("NO $but");
+ $self->store_persistent_state;
+ return $self->goodbye("[dependencies] -- NA");
+ }
+ $CPAN::Frontend->myprint(" $system -- OK\n");
+ $self->{make_test} = CPAN::Distrostatus->new("YES");
+ $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
+ # probably impossible to need the next line because badtestcnt
+ # has a lifespan of one command
+ delete $self->{badtestcnt};
+ } else {
+ if ($but) {
+ $but .= "; additionally test harness failed";
+ $CPAN::Frontend->mywarn("$but\n");
+ $self->{make_test} = CPAN::Distrostatus->new("NO $but");
+ } elsif ( $self->{force_update} ) {
+ $self->{make_test} = CPAN::Distrostatus->new(
+ "NO but failure ignored because 'force' in effect"
+ );
+ } else {
+ $self->{make_test} = CPAN::Distrostatus->new("NO");
+ }
+ $self->{badtestcnt}++;
+ $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
+ CPAN::Shell->optprint
+ ("hint",
+ sprintf
+ ("//hint// to see the cpan-testers results for installing this module, try:
+ reports %s\n",
+ $self->pretty_id));
+ }
+ $self->store_persistent_state;
+
+ $self->post_test();
+
+ return $self->{force_update} ? 1 : !! $tests_ok;
+}
+
+sub _make_test_illuminate_prereqs {
+ my($self) = @_;
+ my @prereq;
+
+ # local $CPAN::DEBUG = 16; # Distribution
+ for my $m (sort keys %{$self->{sponsored_mods}}) {
+ next unless $self->{sponsored_mods}{$m} > 0;
+ my $m_obj = CPAN::Shell->expand("Module",$m) or next;
+ # XXX we need available_version which reflects
+ # $ENV{PERL5LIB} so that already tested but not yet
+ # installed modules are counted.
+ my $available_version = $m_obj->available_version;
+ my $available_file = $m_obj->available_file;
+ if ($available_version &&
+ !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
+ ) {
+ CPAN->debug("m[$m] good enough available_version[$available_version]")
+ if $CPAN::DEBUG;
+ } elsif ($available_file
+ && (
+ !$self->{prereq_pm}{$m}
+ ||
+ $self->{prereq_pm}{$m} == 0
+ )
+ ) {
+ # lex Class::Accessor::Chained::Fast which has no $VERSION
+ CPAN->debug("m[$m] have available_file[$available_file]")
+ if $CPAN::DEBUG;
+ } else {
+ push @prereq, $m
+ if $m_obj->{mandatory};
+ }
+ }
+ my $but;
+ if (@prereq) {
+ my $cnt = @prereq;
+ my $which = join ",", @prereq;
+ $but = $cnt == 1 ? "one dependency not OK ($which)" :
+ "$cnt dependencies missing ($which)";
+ }
+ $but;
+}
+
+sub _prefs_with_expect {
+ my($self,$where) = @_;
+ return unless my $prefs = $self->prefs;
+ return unless my $where_prefs = $prefs->{$where};
+ if ($where_prefs->{expect}) {
+ return {
+ mode => "deterministic",
+ timeout => 15,
+ talk => $where_prefs->{expect},
+ };
+ } elsif ($where_prefs->{"eexpect"}) {
+ return $where_prefs->{"eexpect"};
+ }
+ return;
+}
+
+#-> sub CPAN::Distribution::clean ;
+sub clean {
+ my($self) = @_;
+ my $make = $self->{modulebuild} ? "Build" : "make";
+ $CPAN::Frontend->myprint("Running $make clean\n");
+ unless (exists $self->{archived}) {
+ $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
+ "/untarred, nothing done\n");
+ return 1;
+ }
+ unless (exists $self->{build_dir}) {
+ $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
+ return 1;
+ }
+ if (exists $self->{writemakefile}
+ and $self->{writemakefile}->failed
+ ) {
+ $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
+ return 1;
+ }
+ EXCUSE: {
+ my @e;
+ exists $self->{make_clean} and $self->{make_clean} eq "YES" and
+ push @e, "make clean already called once";
+ $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ }
+ chdir $self->{build_dir} or
+ Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
+ $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
+
+ if ($^O eq 'MacOS') {
+ Mac::BuildTools::make_clean($self);
+ return;
+ }
+
+ my $system;
+ if ($self->{modulebuild}) {
+ unless (-f "Build") {
+ my $cwd = CPAN::anycwd();
+ $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
+ " in cwd[$cwd]. Danger, Will Robinson!");
+ $CPAN::Frontend->mysleep(5);
+ }
+ $system = sprintf "%s clean", $self->_build_command();
+ } else {
+ $system = join " ", $self->_make_command(), "clean";
+ }
+ my $system_ok = system($system) == 0;
+ $self->introduce_myself;
+ if ( $system_ok ) {
+ $CPAN::Frontend->myprint(" $system -- OK\n");
+
+ # $self->force;
+
+ # Jost Krieger pointed out that this "force" was wrong because
+ # it has the effect that the next "install" on this distribution
+ # will untar everything again. Instead we should bring the
+ # object's state back to where it is after untarring.
+
+ for my $k (qw(
+ force_update
+ install
+ writemakefile
+ make
+ make_test
+ )) {
+ delete $self->{$k};
+ }
+ $self->{make_clean} = CPAN::Distrostatus->new("YES");
+
+ } else {
+ # Hmmm, what to do if make clean failed?
+
+ $self->{make_clean} = CPAN::Distrostatus->new("NO");
+ $CPAN::Frontend->mywarn(qq{ $system -- NOT OK\n});
+
+ # 2006-02-27: seems silly to me to force a make now
+ # $self->force("make"); # so that this directory won't be used again
+
+ }
+ $self->store_persistent_state;
+}
+
+#-> sub CPAN::Distribution::check_disabled ;
+sub check_disabled {
+ my ($self) = @_;
+ $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
+ if ($self->prefs->{disabled} && ! $self->{force_update}) {
+ return sprintf(
+ "Disabled via prefs file '%s' doc %d",
+ $self->{prefs_file},
+ $self->{prefs_file_doc},
+ );
+ }
+ return;
+}
+
+#-> sub CPAN::Distribution::goto ;
+sub goto {
+ my($self,$goto) = @_;
+ $goto = $self->normalize($goto);
+ my $why = sprintf(
+ "Goto '$goto' via prefs file '%s' doc %d",
+ $self->{prefs_file},
+ $self->{prefs_file_doc},
+ );
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
+ # 2007-07-16 akoenig : Better than NA would be if we could inherit
+ # the status of the $goto distro but given the exceptional nature
+ # of 'goto' I feel reluctant to implement it
+ my $goodbye_message = "[goto] -- NA $why";
+ $self->goodbye($goodbye_message);
+
+ # inject into the queue
+
+ CPAN::Queue->delete($self->id);
+ CPAN::Queue->jumpqueue({qmod => $goto, reqtype => $self->{reqtype}});
+
+ # and run where we left off
+
+ my($method) = (caller(1))[3];
+ CPAN->instance("CPAN::Distribution",$goto)->$method();
+ CPAN::Queue->delete_first($goto);
+ # XXX delete_first returns undef; is that what this should return
+ # up the call stack, eg. return $sefl->goto($goto) -- xdg, 2012-04-04
+}
+
+#-> sub CPAN::Distribution::shortcut_install ;
+# return values: undef means don't shortcut; 0 means shortcut as fail;
+# and 1 means shortcut as success
+sub shortcut_install {
+ my ($self) = @_;
+
+ $self->debug("checking previous install results[$self->{ID}]") if $CPAN::DEBUG;
+ if (exists $self->{install}) {
+ my $text = UNIVERSAL::can($self->{install},"text") ?
+ $self->{install}->text :
+ $self->{install};
+ if ($text =~ /^YES/) {
+ $CPAN::META->is_installed($self->{build_dir});
+ return $self->success("Already done");
+ } elsif ($text =~ /is only/) {
+ # e.g. 'is only build_requires'
+ return $self->goodbye($text);
+ } else {
+ # comment in Todo on 2006-02-11; maybe retry?
+ return $self->goodbye("Already tried without success");
+ }
+ }
+
+ for my $slot ( qw/later configure_requires_later/ ) {
+ return $self->success($self->{$slot})
+ if $self->{$slot};
+ }
+
+ return undef;
+}
+
+#-> sub CPAN::Distribution::install ;
+sub install {
+ my($self) = @_;
+
+ $self->pre_install();
+
+ $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
+ if (my $goto = $self->prefs->{goto}) {
+ return $self->goto($goto);
+ }
+
+ $self->test
+ or return;
+
+ if ( defined( my $sc = $self->shortcut_install ) ) {
+ return $sc;
+ }
+
+ if ($CPAN::Signal) {
+ delete $self->{force_update};
+ return;
+ }
+
+ my $builddir = $self->dir or
+ $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
+
+ unless (chdir $builddir) {
+ $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
+ return;
+ }
+
+ $self->debug("Changed directory to $self->{build_dir}")
+ if $CPAN::DEBUG;
+
+ my $make = $self->{modulebuild} ? "Build" : "make";
+ $CPAN::Frontend->myprint("Running $make install\n");
+
+ if ($^O eq 'MacOS') {
+ Mac::BuildTools::make_install($self);
+ return;
+ }
+
+ my $system;
+ if (my $commandline = $self->prefs->{install}{commandline}) {
+ $system = $commandline;
+ $ENV{PERL} = CPAN::find_perl();
+ } elsif ($self->{modulebuild}) {
+ my($mbuild_install_build_command) =
+ exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
+ $CPAN::Config->{mbuild_install_build_command} ?
+ $CPAN::Config->{mbuild_install_build_command} :
+ $self->_build_command();
+ my $install_directive = $^O eq 'VMS' ? '"install"' : 'install';
+ $system = sprintf("%s %s %s",
+ $mbuild_install_build_command,
+ $install_directive,
+ $CPAN::Config->{mbuild_install_arg},
+ );
+ } else {
+ my($make_install_make_command) = $self->_make_install_make_command();
+ $system = sprintf("%s install %s",
+ $make_install_make_command,
+ $CPAN::Config->{make_install_arg},
+ );
+ }
+
+ my($stderr) = $^O eq "MSWin32" || $^O eq 'VMS' ? "" : " 2>&1 ";
+ my $brip = CPAN::HandleConfig->prefs_lookup($self,
+ q{build_requires_install_policy});
+ $brip ||="ask/yes";
+ my $id = $self->id;
+ my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
+ my $want_install = "yes";
+ if ($reqtype eq "b") {
+ if ($brip eq "no") {
+ $want_install = "no";
+ } elsif ($brip =~ m|^ask/(.+)|) {
+ my $default = $1;
+ $default = "yes" unless $default =~ /^(y|n)/i;
+ $want_install =
+ CPAN::Shell::colorable_makemaker_prompt
+ ("$id is just needed temporarily during building or testing. ".
+ "Do you want to install it permanently?",
+ $default);
+ }
+ }
+ unless ($want_install =~ /^y/i) {
+ my $is_only = "is only 'build_requires'";
+ $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
+ delete $self->{force_update};
+ return $self->goodbye("Not installing because $is_only");
+ }
+ local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
+ ? $ENV{PERL5LIB}
+ : ($ENV{PERLLIB} || "");
+
+ local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
+ local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # install
+ $CPAN::META->set_perl5lib;
+ local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
+ local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
+
+ my($pipe) = FileHandle->new("$system $stderr |");
+ unless ($pipe) {
+ $CPAN::Frontend->mywarn("Can't execute $system: $!");
+ $self->introduce_myself;
+ $self->{install} = CPAN::Distrostatus->new("NO");
+ $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
+ delete $self->{force_update};
+ return;
+ }
+ my($makeout) = "";
+ while (<$pipe>) {
+ print $_; # intentionally NOT use Frontend->myprint because it
+ # looks irritating when we markup in color what we
+ # just pass through from an external program
+ $makeout .= $_;
+ }
+ $pipe->close;
+ my $close_ok = $? == 0;
+ $self->introduce_myself;
+ if ( $close_ok ) {
+ $CPAN::Frontend->myprint(" $system -- OK\n");
+ $CPAN::META->is_installed($self->{build_dir});
+ $self->{install} = CPAN::Distrostatus->new("YES");
+ if ($CPAN::Config->{'cleanup_after_install'}
+ && ! $self->is_dot_dist) {
+ my $parent = File::Spec->catdir( $self->{build_dir}, File::Spec->updir );
+ chdir $parent or $CPAN::Frontend->mydie("Couldn't chdir to $parent: $!\n");
+ File::Path::rmtree($self->{build_dir});
+ my $yml = "$self->{build_dir}.yml";
+ if (-e $yml) {
+ unlink $yml or $CPAN::Frontend->mydie("Couldn't unlink $yml: $!\n");
+ }
+ }
+ } else {
+ $self->{install} = CPAN::Distrostatus->new("NO");
+ $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
+ my $mimc =
+ CPAN::HandleConfig->prefs_lookup($self,
+ q{make_install_make_command});
+ if (
+ $makeout =~ /permission/s
+ && $> > 0
+ && (
+ ! $mimc
+ || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
+ q{make}))
+ )
+ ) {
+ $CPAN::Frontend->myprint(
+ qq{----\n}.
+ qq{ You may have to su }.
+ qq{to root to install the package\n}.
+ qq{ (Or you may want to run something like\n}.
+ qq{ o conf make_install_make_command 'sudo make'\n}.
+ qq{ to raise your permissions.}
+ );
+ }
+ }
+ delete $self->{force_update};
+ unless ($CPAN::Config->{'cleanup_after_install'}) {
+ $self->store_persistent_state;
+ }
+
+ $self->post_install();
+
+ return !! $close_ok;
+}
+
+sub introduce_myself {
+ my($self) = @_;
+ $CPAN::Frontend->myprint(sprintf(" %s\n",$self->pretty_id));
+}
+
+#-> sub CPAN::Distribution::dir ;
+sub dir {
+ shift->{build_dir};
+}
+
+#-> sub CPAN::Distribution::perldoc ;
+sub perldoc {
+ my($self) = @_;
+
+ my($dist) = $self->id;
+ my $package = $self->called_for;
+
+ if ($CPAN::META->has_inst("Pod::Perldocs")) {
+ my($perl) = $self->perl
+ or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
+ my @args = ($perl, q{-MPod::Perldocs}, q{-e},
+ q{Pod::Perldocs->run()}, $package);
+ my($wstatus);
+ unless ( ($wstatus = system(@args)) == 0 ) {
+ my $estatus = $wstatus >> 8;
+ $CPAN::Frontend->myprint(qq{
+ Function system("@args")
+ returned status $estatus (wstat $wstatus)
+ });
+ }
+ }
+ else {
+ $self->_display_url( $CPAN::Defaultdocs . $package );
+ }
+}
+
+#-> sub CPAN::Distribution::_check_binary ;
+sub _check_binary {
+ my ($dist,$shell,$binary) = @_;
+ my ($pid,$out);
+
+ $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
+ if $CPAN::DEBUG;
+
+ if ($CPAN::META->has_inst("File::Which")) {
+ return File::Which::which($binary);
+ } else {
+ local *README;
+ $pid = open README, "which $binary|"
+ or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
+ return unless $pid;
+ while (<README>) {
+ $out .= $_;
+ }
+ close README
+ or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
+ and return;
+ }
+
+ $CPAN::Frontend->myprint(qq{ + $out \n})
+ if $CPAN::DEBUG && $out;
+
+ return $out;
+}
+
+#-> sub CPAN::Distribution::_display_url ;
+sub _display_url {
+ my($self,$url) = @_;
+ my($res,$saved_file,$pid,$out);
+
+ $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
+ if $CPAN::DEBUG;
+
+ # should we define it in the config instead?
+ my $html_converter = "html2text.pl";
+
+ my $web_browser = $CPAN::Config->{'lynx'} || undef;
+ my $web_browser_out = $web_browser
+ ? CPAN::Distribution->_check_binary($self,$web_browser)
+ : undef;
+
+ if ($web_browser_out) {
+ # web browser found, run the action
+ my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
+ $CPAN::Frontend->myprint(qq{system[$browser $url]})
+ if $CPAN::DEBUG;
+ $CPAN::Frontend->myprint(qq{
+Displaying URL
+ $url
+with browser $browser
+});
+ $CPAN::Frontend->mysleep(1);
+ system("$browser $url");
+ if ($saved_file) { 1 while unlink($saved_file) }
+ } else {
+ # web browser not found, let's try text only
+ my $html_converter_out =
+ CPAN::Distribution->_check_binary($self,$html_converter);
+ $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
+
+ if ($html_converter_out ) {
+ # html2text found, run it
+ $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
+ $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
+ unless defined($saved_file);
+
+ local *README;
+ $pid = open README, "$html_converter $saved_file |"
+ or $CPAN::Frontend->mydie(qq{
+Could not fork '$html_converter $saved_file': $!});
+ my($fh,$filename);
+ if ($CPAN::META->has_usable("File::Temp")) {
+ $fh = File::Temp->new(
+ dir => File::Spec->tmpdir,
+ template => 'cpan_htmlconvert_XXXX',
+ suffix => '.txt',
+ unlink => 0,
+ );
+ $filename = $fh->filename;
+ } else {
+ $filename = "cpan_htmlconvert_$$.txt";
+ $fh = FileHandle->new();
+ open $fh, ">$filename" or die;
+ }
+ while (<README>) {
+ $fh->print($_);
+ }
+ close README or
+ $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
+ my $tmpin = $fh->filename;
+ $CPAN::Frontend->myprint(sprintf(qq{
+Run '%s %s' and
+saved output to %s\n},
+ $html_converter,
+ $saved_file,
+ $tmpin,
+ )) if $CPAN::DEBUG;
+ close $fh;
+ local *FH;
+ open FH, $tmpin
+ or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
+ my $fh_pager = FileHandle->new;
+ local($SIG{PIPE}) = "IGNORE";
+ my $pager = $CPAN::Config->{'pager'} || "cat";
+ $fh_pager->open("|$pager")
+ or $CPAN::Frontend->mydie(qq{
+Could not open pager '$pager': $!});
+ $CPAN::Frontend->myprint(qq{
+Displaying URL
+ $url
+with pager "$pager"
+});
+ $CPAN::Frontend->mysleep(1);
+ $fh_pager->print(<FH>);
+ $fh_pager->close;
+ } else {
+ # coldn't find the web browser or html converter
+ $CPAN::Frontend->myprint(qq{
+You need to install lynx or $html_converter to use this feature.});
+ }
+ }
+}
+
+#-> sub CPAN::Distribution::_getsave_url ;
+sub _getsave_url {
+ my($dist, $shell, $url) = @_;
+
+ $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
+ if $CPAN::DEBUG;
+
+ my($fh,$filename);
+ if ($CPAN::META->has_usable("File::Temp")) {
+ $fh = File::Temp->new(
+ dir => File::Spec->tmpdir,
+ template => "cpan_getsave_url_XXXX",
+ suffix => ".html",
+ unlink => 0,
+ );
+ $filename = $fh->filename;
+ } else {
+ $fh = FileHandle->new;
+ $filename = "cpan_getsave_url_$$.html";
+ }
+ my $tmpin = $filename;
+ if ($CPAN::META->has_usable('LWP')) {
+ $CPAN::Frontend->myprint("Fetching with LWP:
+ $url
+");
+ my $Ua;
+ CPAN::LWP::UserAgent->config;
+ eval { $Ua = CPAN::LWP::UserAgent->new; };
+ if ($@) {
+ $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
+ return;
+ } else {
+ my($var);
+ $Ua->proxy('http', $var)
+ if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
+ $Ua->no_proxy($var)
+ if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
+ }
+
+ my $req = HTTP::Request->new(GET => $url);
+ $req->header('Accept' => 'text/html');
+ my $res = $Ua->request($req);
+ if ($res->is_success) {
+ $CPAN::Frontend->myprint(" + request successful.\n")
+ if $CPAN::DEBUG;
+ print $fh $res->content;
+ close $fh;
+ $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
+ if $CPAN::DEBUG;
+ return $tmpin;
+ } else {
+ $CPAN::Frontend->myprint(sprintf(
+ "LWP failed with code[%s], message[%s]\n",
+ $res->code,
+ $res->message,
+ ));
+ return;
+ }
+ } else {
+ $CPAN::Frontend->mywarn(" LWP not available\n");
+ return;
+ }
+}
+
+#-> sub CPAN::Distribution::_build_command
+sub _build_command {
+ my($self) = @_;
+ if ($^O eq "MSWin32") { # special code needed at least up to
+ # Module::Build 0.2611 and 0.2706; a fix
+ # in M:B has been promised 2006-01-30
+ my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
+ return "$perl ./Build";
+ }
+ elsif ($^O eq 'VMS') {
+ return "$^X Build.com";
+ }
+ return "./Build";
+}
+
+#-> sub CPAN::Distribution::_should_report
+sub _should_report {
+ my($self, $phase) = @_;
+ die "_should_report() requires a 'phase' argument"
+ if ! defined $phase;
+
+ # configured
+ my $test_report = CPAN::HandleConfig->prefs_lookup($self,
+ q{test_report});
+ return unless $test_report;
+
+ # don't repeat if we cached a result
+ return $self->{should_report}
+ if exists $self->{should_report};
+
+ # don't report if we generated a Makefile.PL
+ if ( $self->{had_no_makefile_pl} ) {
+ $CPAN::Frontend->mywarn(
+ "Will not send CPAN Testers report with generated Makefile.PL.\n"
+ );
+ return $self->{should_report} = 0;
+ }
+
+ # available
+ if ( ! $CPAN::META->has_inst("CPAN::Reporter")) {
+ $CPAN::Frontend->mywarnonce(
+ "CPAN::Reporter not installed. No reports will be sent.\n"
+ );
+ return $self->{should_report} = 0;
+ }
+
+ # capable
+ my $crv = CPAN::Reporter->VERSION;
+ if ( CPAN::Version->vlt( $crv, 0.99 ) ) {
+ # don't cache $self->{should_report} -- need to check each phase
+ if ( $phase eq 'test' ) {
+ return 1;
+ }
+ else {
+ $CPAN::Frontend->mywarn(
+ "Reporting on the '$phase' phase requires CPAN::Reporter 0.99, but \n" .
+ "you only have version $crv\. Only 'test' phase reports will be sent.\n"
+ );
+ return;
+ }
+ }
+
+ # appropriate
+ if ($self->is_dot_dist) {
+ $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
+ "for local directories\n");
+ return $self->{should_report} = 0;
+ }
+ if ($self->prefs->{patches}
+ &&
+ @{$self->prefs->{patches}}
+ &&
+ $self->{patched}
+ ) {
+ $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
+ "when the source has been patched\n");
+ return $self->{should_report} = 0;
+ }
+
+ # proceed and cache success
+ return $self->{should_report} = 1;
+}
+
+#-> sub CPAN::Distribution::reports
+sub reports {
+ my($self) = @_;
+ my $pathname = $self->id;
+ $CPAN::Frontend->myprint("Distribution: $pathname\n");
+
+ unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) {
+ $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
+ }
+ unless ($CPAN::META->has_usable("LWP")) {
+ $CPAN::Frontend->mydie("LWP not installed; cannot continue");
+ }
+ unless ($CPAN::META->has_usable("File::Temp")) {
+ $CPAN::Frontend->mydie("File::Temp not installed; cannot continue");
+ }
+
+ my $d = CPAN::DistnameInfo->new($pathname);
+
+ my $dist = $d->dist; # "CPAN-DistnameInfo"
+ my $version = $d->version; # "0.02"
+ my $maturity = $d->maturity; # "released"
+ my $filename = $d->filename; # "CPAN-DistnameInfo-0.02.tar.gz"
+ my $cpanid = $d->cpanid; # "GBARR"
+ my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
+
+ my $url = sprintf "http://www.cpantesters.org/show/%s.yaml", $dist;
+
+ CPAN::LWP::UserAgent->config;
+ my $Ua;
+ eval { $Ua = CPAN::LWP::UserAgent->new; };
+ if ($@) {
+ $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
+ }
+ $CPAN::Frontend->myprint("Fetching '$url'...");
+ my $resp = $Ua->get($url);
+ unless ($resp->is_success) {
+ $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
+ }
+ $CPAN::Frontend->myprint("DONE\n\n");
+ my $yaml = $resp->content;
+ # what a long way round!
+ my $fh = File::Temp->new(
+ dir => File::Spec->tmpdir,
+ template => 'cpan_reports_XXXX',
+ suffix => '.yaml',
+ unlink => 0,
+ );
+ my $tfilename = $fh->filename;
+ print $fh $yaml;
+ close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!");
+ my $unserialized = CPAN->_yaml_loadfile($tfilename)->[0];
+ unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!");
+ my %other_versions;
+ my $this_version_seen;
+ for my $rep (@$unserialized) {
+ my $rversion = $rep->{version};
+ if ($rversion eq $version) {
+ unless ($this_version_seen++) {
+ $CPAN::Frontend->myprint ("$rep->{version}:\n");
+ }
+ my $arch = $rep->{archname} || $rep->{platform} || '????';
+ my $grade = $rep->{action} || $rep->{status} || '????';
+ my $ostext = $rep->{ostext} || ucfirst($rep->{osname}) || '????';
+ $CPAN::Frontend->myprint
+ (sprintf("%1s%1s%-4s %s on %s %s (%s)\n",
+ $arch eq $Config::Config{archname}?"*":"",
+ $grade eq "PASS"?"+":$grade eq"FAIL"?"-":"",
+ $grade,
+ $rep->{perl},
+ $ostext,
+ $rep->{osvers},
+ $arch,
+ ));
+ } else {
+ $other_versions{$rep->{version}}++;
+ }
+ }
+ unless ($this_version_seen) {
+ $CPAN::Frontend->myprint("No reports found for version '$version'
+Reports for other versions:\n");
+ for my $v (sort keys %other_versions) {
+ $CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n");
+ }
+ }
+ $url =~ s/\.yaml/.html/;
+ $CPAN::Frontend->myprint("See $url for details\n");
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Distroprefs.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Distroprefs.pm
new file mode 100644
index 0000000000..05b19faa47
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Distroprefs.pm
@@ -0,0 +1,481 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+
+use 5.006;
+use strict;
+package CPAN::Distroprefs;
+
+use vars qw($VERSION);
+$VERSION = '6.0001';
+
+package CPAN::Distroprefs::Result;
+
+use File::Spec;
+
+sub new { bless $_[1] || {} => $_[0] }
+
+sub abs { File::Spec->catfile($_[0]->dir, $_[0]->file) }
+
+sub __cloner {
+ my ($class, $name, $newclass) = @_;
+ $newclass = 'CPAN::Distroprefs::Result::' . $newclass;
+ no strict 'refs';
+ *{$class . '::' . $name} = sub {
+ $newclass->new({
+ %{ $_[0] },
+ %{ $_[1] },
+ });
+ };
+}
+BEGIN { __PACKAGE__->__cloner(as_warning => 'Warning') }
+BEGIN { __PACKAGE__->__cloner(as_fatal => 'Fatal') }
+BEGIN { __PACKAGE__->__cloner(as_success => 'Success') }
+
+sub __accessor {
+ my ($class, $key) = @_;
+ no strict 'refs';
+ *{$class . '::' . $key} = sub { $_[0]->{$key} };
+}
+BEGIN { __PACKAGE__->__accessor($_) for qw(type file ext dir) }
+
+sub is_warning { 0 }
+sub is_fatal { 0 }
+sub is_success { 0 }
+
+package CPAN::Distroprefs::Result::Error;
+use vars qw(@ISA);
+BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic
+BEGIN { __PACKAGE__->__accessor($_) for qw(msg) }
+
+sub as_string {
+ my ($self) = @_;
+ if ($self->msg) {
+ return sprintf $self->fmt_reason, $self->file, $self->msg;
+ } else {
+ return sprintf $self->fmt_unknown, $self->file;
+ }
+}
+
+package CPAN::Distroprefs::Result::Warning;
+use vars qw(@ISA);
+BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic
+sub is_warning { 1 }
+sub fmt_reason { "Error reading distroprefs file %s, skipping: %s" }
+sub fmt_unknown { "Unknown error reading distroprefs file %s, skipping." }
+
+package CPAN::Distroprefs::Result::Fatal;
+use vars qw(@ISA);
+BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic
+sub is_fatal { 1 }
+sub fmt_reason { "Error reading distroprefs file %s: %s" }
+sub fmt_unknown { "Unknown error reading distroprefs file %s." }
+
+package CPAN::Distroprefs::Result::Success;
+use vars qw(@ISA);
+BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic
+BEGIN { __PACKAGE__->__accessor($_) for qw(prefs extension) }
+sub is_success { 1 }
+
+package CPAN::Distroprefs::Iterator;
+
+sub new { bless $_[1] => $_[0] }
+
+sub next { $_[0]->() }
+
+package CPAN::Distroprefs;
+
+use Carp ();
+use DirHandle;
+
+sub _load_method {
+ my ($self, $loader, $result) = @_;
+ return '_load_yaml' if $loader eq 'CPAN' or $loader =~ /^YAML(::|$)/;
+ return '_load_' . $result->ext;
+}
+
+sub _load_yaml {
+ my ($self, $loader, $result) = @_;
+ my $data = eval {
+ $loader eq 'CPAN'
+ ? $loader->_yaml_loadfile($result->abs)
+ : [ $loader->can('LoadFile')->($result->abs) ]
+ };
+ if (my $err = $@) {
+ die $result->as_warning({
+ msg => $err,
+ });
+ } elsif (!$data) {
+ die $result->as_warning;
+ } else {
+ return @$data;
+ }
+}
+
+sub _load_dd {
+ my ($self, $loader, $result) = @_;
+ my @data;
+ {
+ package CPAN::Eval;
+ # this caused a die in CPAN.pm, and I am leaving it 'fatal', though I'm
+ # not sure why we wouldn't just skip the file as we do for all other
+ # errors. -- hdp
+ my $abs = $result->abs;
+ open FH, "<$abs" or die $result->as_fatal(msg => "$!");
+ local $/;
+ my $eval = <FH>;
+ close FH;
+ no strict;
+ eval $eval;
+ if (my $err = $@) {
+ die $result->as_warning({ msg => $err });
+ }
+ my $i = 1;
+ while (${"VAR$i"}) {
+ push @data, ${"VAR$i"};
+ $i++;
+ }
+ }
+ return @data;
+}
+
+sub _load_st {
+ my ($self, $loader, $result) = @_;
+ # eval because Storable is never forward compatible
+ my @data = eval { @{scalar $loader->can('retrieve')->($result->abs) } };
+ if (my $err = $@) {
+ die $result->as_warning({ msg => $err });
+ }
+ return @data;
+}
+
+sub _build_file_list {
+ if (@_ > 3) {
+ die "_build_file_list should be called with 3 arguments, was called with more. First argument is '$_[0]'.";
+ }
+ my ($dir, $dir1, $ext_re) = @_;
+ my @list;
+ my $dh;
+ unless (opendir($dh, $dir)) {
+ $CPAN::Frontend->mywarn("ignoring prefs directory '$dir': $!");
+ return @list;
+ }
+ while (my $fn = readdir $dh) {
+ next if $fn eq '.' || $fn eq '..';
+ if (-d "$dir/$fn") {
+ next if $fn =~ /^[._]/; # prune .svn, .git, .hg, _darcs and what the user wants to hide
+ push @list, _build_file_list("$dir/$fn", "$dir1$fn/", $ext_re);
+ } else {
+ if ($fn =~ $ext_re) {
+ push @list, "$dir1$fn";
+ }
+ }
+ }
+ return @list;
+}
+
+sub find {
+ my ($self, $dir, $ext_map) = @_;
+
+ return CPAN::Distroprefs::Iterator->new(sub { return }) unless %$ext_map;
+
+ my $possible_ext = join "|", map { quotemeta } keys %$ext_map;
+ my $ext_re = qr/\.($possible_ext)$/;
+
+ my @files = _build_file_list($dir, '', $ext_re);
+ @files = sort @files if @files;
+
+ # label the block so that we can use redo in the middle
+ return CPAN::Distroprefs::Iterator->new(sub { LOOP: {
+
+ my $fn = shift @files;
+ return unless defined $fn;
+ my ($ext) = $fn =~ $ext_re;
+
+ my $loader = $ext_map->{$ext};
+
+ my $result = CPAN::Distroprefs::Result->new({
+ file => $fn, ext => $ext, dir => $dir
+ });
+ # copied from CPAN.pm; is this ever actually possible?
+ redo unless -f $result->abs;
+
+ my $load_method = $self->_load_method($loader, $result);
+ my @prefs = eval { $self->$load_method($loader, $result) };
+ if (my $err = $@) {
+ if (ref($err) && eval { $err->isa('CPAN::Distroprefs::Result') }) {
+ return $err;
+ }
+ # rethrow any exceptions that we did not generate
+ die $err;
+ } elsif (!@prefs) {
+ # the loader should have handled this, but just in case:
+ return $result->as_warning;
+ }
+ return $result->as_success({
+ prefs => [
+ map { CPAN::Distroprefs::Pref->new({ data => $_ }) } @prefs
+ ],
+ });
+ } });
+}
+
+package CPAN::Distroprefs::Pref;
+
+use Carp ();
+
+sub new { bless $_[1] => $_[0] }
+
+sub data { shift->{data} }
+
+sub has_any_match { $_[0]->data->{match} ? 1 : 0 }
+
+sub has_match {
+ my $match = $_[0]->data->{match} || return 0;
+ exists $match->{$_[1]} || exists $match->{"not_$_[1]"}
+}
+
+sub has_valid_subkeys {
+ grep { exists $_[0]->data->{match}{$_} }
+ map { $_, "not_$_" }
+ $_[0]->match_attributes
+}
+
+sub _pattern {
+ my $re = shift;
+ my $p = eval sprintf 'qr{%s}', $re;
+ if ($@) {
+ $@ =~ s/\n$//;
+ die "Error in Distroprefs pattern qr{$re}\n$@";
+ }
+ return $p;
+}
+
+sub _match_scalar {
+ my ($match, $data) = @_;
+ my $qr = _pattern($match);
+ return $data =~ /$qr/;
+}
+
+sub _match_hash {
+ my ($match, $data) = @_;
+ for my $mkey (keys %$match) {
+ (my $dkey = $mkey) =~ s/^not_//;
+ my $val = defined $data->{$dkey} ? $data->{$dkey} : '';
+ if (_match_scalar($match->{$mkey}, $val)) {
+ return 0 if $mkey =~ /^not_/;
+ }
+ else {
+ return 0 if $mkey !~ /^not_/;
+ }
+ }
+ return 1;
+}
+
+sub _match {
+ my ($self, $key, $data, $matcher) = @_;
+ my $m = $self->data->{match};
+ if (exists $m->{$key}) {
+ return 0 unless $matcher->($m->{$key}, $data);
+ }
+ if (exists $m->{"not_$key"}) {
+ return 0 if $matcher->($m->{"not_$key"}, $data);
+ }
+ return 1;
+}
+
+sub _scalar_match {
+ my ($self, $key, $data) = @_;
+ return $self->_match($key, $data, \&_match_scalar);
+}
+
+sub _hash_match {
+ my ($self, $key, $data) = @_;
+ return $self->_match($key, $data, \&_match_hash);
+}
+
+# do not take the order of C<keys %$match> because "module" is by far the
+# slowest
+sub match_attributes { qw(env distribution perl perlconfig module) }
+
+sub match_module {
+ my ($self, $modules) = @_;
+ return $self->_match("module", $modules, sub {
+ my($match, $data) = @_;
+ my $qr = _pattern($match);
+ for my $module (@$data) {
+ return 1 if $module =~ /$qr/;
+ }
+ return 0;
+ });
+}
+
+sub match_distribution { shift->_scalar_match(distribution => @_) }
+sub match_perl { shift->_scalar_match(perl => @_) }
+
+sub match_perlconfig { shift->_hash_match(perlconfig => @_) }
+sub match_env { shift->_hash_match(env => @_) }
+
+sub matches {
+ my ($self, $arg) = @_;
+
+ my $default_match = 0;
+ for my $key (grep { $self->has_match($_) } $self->match_attributes) {
+ unless (exists $arg->{$key}) {
+ Carp::croak "Can't match pref: missing argument key $key";
+ }
+ $default_match = 1;
+ my $val = $arg->{$key};
+ # make it possible to avoid computing things until we have to
+ if (ref($val) eq 'CODE') { $val = $val->() }
+ my $meth = "match_$key";
+ return 0 unless $self->$meth($val);
+ }
+
+ return $default_match;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::Distroprefs -- read and match distroprefs
+
+=head1 SYNOPSIS
+
+ use CPAN::Distroprefs;
+
+ my %info = (... distribution/environment info ...);
+
+ my $finder = CPAN::Distroprefs->find($prefs_dir, \%ext_map);
+
+ while (my $result = $finder->next) {
+
+ die $result->as_string if $result->is_fatal;
+
+ warn($result->as_string), next if $result->is_warning;
+
+ for my $pref (@{ $result->prefs }) {
+ if ($pref->matches(\%info)) {
+ return $pref;
+ }
+ }
+ }
+
+
+=head1 DESCRIPTION
+
+This module encapsulates reading L<Distroprefs|CPAN> and matching them against CPAN distributions.
+
+=head1 INTERFACE
+
+ my $finder = CPAN::Distroprefs->find($dir, \%ext_map);
+
+ while (my $result = $finder->next) { ... }
+
+Build an iterator which finds distroprefs files in the tree below the
+given directory. Within the tree directories matching C<m/^[._]/> are
+pruned.
+
+C<%ext_map> is a hashref whose keys are file extensions and whose values are
+modules used to load matching files:
+
+ {
+ 'yml' => 'YAML::Syck',
+ 'dd' => 'Data::Dumper',
+ ...
+ }
+
+Each time C<< $finder->next >> is called, the iterator returns one of two
+possible values:
+
+=over
+
+=item * a CPAN::Distroprefs::Result object
+
+=item * C<undef>, indicating that no prefs files remain to be found
+
+=back
+
+=head1 RESULTS
+
+L<C<find()>|/INTERFACE> returns CPAN::Distroprefs::Result objects to
+indicate success or failure when reading a prefs file.
+
+=head2 Common
+
+All results share some common attributes:
+
+=head3 type
+
+C<success>, C<warning>, or C<fatal>
+
+=head3 file
+
+the file from which these prefs were read, or to which this error refers (relative filename)
+
+=head3 ext
+
+the file's extension, which determines how to load it
+
+=head3 dir
+
+the directory the file was read from
+
+=head3 abs
+
+the absolute path to the file
+
+=head2 Errors
+
+Error results (warning and fatal) contain:
+
+=head3 msg
+
+the error message (usually either C<$!> or a YAML error)
+
+=head2 Successes
+
+Success results contain:
+
+=head3 prefs
+
+an arrayref of CPAN::Distroprefs::Pref objects
+
+=head1 PREFS
+
+CPAN::Distroprefs::Pref objects represent individual distroprefs documents.
+They are constructed automatically as part of C<success> results from C<find()>.
+
+=head3 data
+
+the pref information as a hashref, suitable for e.g. passing to Kwalify
+
+=head3 match_attributes
+
+returns a list of the valid match attributes (see the Distroprefs section in L<CPAN>)
+
+currently: C<env perl perlconfig distribution module>
+
+=head3 has_any_match
+
+true if this pref has a 'match' attribute at all
+
+=head3 has_valid_subkeys
+
+true if this pref has a 'match' attribute and at least one valid match attribute
+
+=head3 matches
+
+ if ($pref->matches(\%arg)) { ... }
+
+true if this pref matches the passed-in hashref, which must have a value for
+each of the C<match_attributes> (above)
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Distrostatus.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Distrostatus.pm
new file mode 100644
index 0000000000..0cc6cc9a79
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Distrostatus.pm
@@ -0,0 +1,45 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Distrostatus;
+use overload '""' => "as_string",
+ fallback => 1;
+use vars qw($something_has_failed_at);
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5";
+
+
+sub new {
+ my($class,$arg) = @_;
+ my $failed = substr($arg,0,2) eq "NO";
+ if ($failed) {
+ $something_has_failed_at = $CPAN::CurrentCommandId;
+ }
+ bless {
+ TEXT => $arg,
+ FAILED => $failed,
+ COMMANDID => $CPAN::CurrentCommandId,
+ TIME => time,
+ }, $class;
+}
+sub something_has_just_failed () {
+ defined $something_has_failed_at &&
+ $something_has_failed_at == $CPAN::CurrentCommandId;
+}
+sub commandid { shift->{COMMANDID} }
+sub failed { shift->{FAILED} }
+sub text {
+ my($self,$set) = @_;
+ if (defined $set) {
+ $self->{TEXT} = $set;
+ }
+ $self->{TEXT};
+}
+sub as_string {
+ my($self) = @_;
+ $self->text;
+}
+
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Exception/RecursiveDependency.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Exception/RecursiveDependency.pm
new file mode 100644
index 0000000000..82e82346ef
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Exception/RecursiveDependency.pm
@@ -0,0 +1,113 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Exception::RecursiveDependency;
+use strict;
+use overload '""' => "as_string";
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5001";
+
+{
+ package CPAN::Exception::RecursiveDependency::na;
+ use overload '""' => "as_string";
+ sub new { bless {}, shift };
+ sub as_string { "N/A" };
+}
+
+my $NA = CPAN::Exception::RecursiveDependency::na->new;
+
+# a module sees its distribution (no version)
+# a distribution sees its prereqs (which are module names) (usually with versions)
+# a bundle sees its module names and/or its distributions (no version)
+
+sub new {
+ my($class) = shift;
+ my($deps_arg) = shift;
+ my (@deps,%seen,$loop_starts_with);
+ DCHAIN: for my $dep (@$deps_arg) {
+ push @deps, {name => $dep, display_as => $dep};
+ if ($seen{$dep}++) {
+ $loop_starts_with = $dep;
+ last DCHAIN;
+ }
+ }
+ my $in_loop = 0;
+ my %mark;
+ DWALK: for my $i (0..$#deps) {
+ my $x = $deps[$i]{name};
+ $in_loop ||= $loop_starts_with && $x eq $loop_starts_with;
+ my $xo = CPAN::Shell->expandany($x) or next;
+ if ($xo->isa("CPAN::Module")) {
+ my $have = $xo->inst_version || $NA;
+ my($want,$d,$want_type);
+ if ($i>0 and $d = $deps[$i-1]{name}) {
+ my $do = CPAN::Shell->expandany($d);
+ $want = $do->{prereq_pm}{requires}{$x};
+ if (defined $want) {
+ $want_type = "requires: ";
+ } else {
+ $want = $do->{prereq_pm}{build_requires}{$x};
+ if (defined $want) {
+ $want_type = "build_requires: ";
+ } else {
+ $want_type = "unknown status";
+ $want = "???";
+ }
+ }
+ } else {
+ $want = $xo->cpan_version;
+ $want_type = "want: ";
+ }
+ $deps[$i]{have} = $have;
+ $deps[$i]{want_type} = $want_type;
+ $deps[$i]{want} = $want;
+ $deps[$i]{display_as} = "$x (have: $have; $want_type$want)";
+ if ((! ref $have || !$have->isa('CPAN::Exception::RecursiveDependency::na'))
+ && CPAN::Version->vge($have, $want)) {
+ # https://rt.cpan.org/Ticket/Display.html?id=115340
+ undef $loop_starts_with;
+ last DWALK;
+ }
+ } elsif ($xo->isa("CPAN::Distribution")) {
+ my $pretty = $deps[$i]{display_as} = $xo->pretty_id;
+ my $mark_as;
+ if ($in_loop) {
+ $mark_as = CPAN::Distrostatus->new("NO cannot resolve circular dependency");
+ } else {
+ $mark_as = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency");
+ }
+ $mark{$pretty} = { xo => $xo, mark_as => $mark_as };
+ }
+ }
+ if ($loop_starts_with) {
+ while (my($k,$v) = each %mark) {
+ my $xo = $v->{xo};
+ $xo->{make} = $v->{mark_as};
+ $xo->store_persistent_state; # otherwise I will not reach
+ # all involved parties for
+ # the next session
+ }
+ }
+ bless { deps => \@deps, loop_starts_with => $loop_starts_with }, $class;
+}
+
+sub is_resolvable {
+ ! defined shift->{loop_starts_with};
+}
+
+sub as_string {
+ my($self) = shift;
+ my $deps = $self->{deps};
+ my $loop_starts_with = $self->{loop_starts_with};
+ unless ($loop_starts_with) {
+ return "--not a recursive/circular dependency--";
+ }
+ my $ret = "\nRecursive dependency detected:\n ";
+ $ret .= join("\n => ", map {$_->{display_as}} @$deps);
+ $ret .= ".\nCannot resolve.\n";
+ $ret;
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Exception/blocked_urllist.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Exception/blocked_urllist.pm
new file mode 100644
index 0000000000..87d07d13f1
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Exception/blocked_urllist.pm
@@ -0,0 +1,46 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Exception::blocked_urllist;
+use strict;
+use overload '""' => "as_string";
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "1.001";
+
+
+sub new {
+ my($class) = @_;
+ bless {}, $class;
+}
+
+sub as_string {
+ my($self) = shift;
+ if ($CPAN::Config->{connect_to_internet_ok}) {
+ return qq{
+
+You have not configured a urllist for CPAN mirrors. Configure it with
+
+ o conf init urllist
+
+};
+ } else {
+ return qq{
+
+You have not configured a urllist and do not allow connections to the
+internet to get a list of mirrors. If you wish to get a list of CPAN
+mirrors to pick from, use this command
+
+ o conf init connect_to_internet_ok urllist
+
+If you do not wish to get a list of mirrors and would prefer to set
+your urllist manually, use just this command instead
+
+ o conf init urllist
+
+};
+ }
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Exception/yaml_not_installed.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Exception/yaml_not_installed.pm
new file mode 100644
index 0000000000..1e7fa83a53
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Exception/yaml_not_installed.pm
@@ -0,0 +1,23 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Exception::yaml_not_installed;
+use strict;
+use overload '""' => "as_string";
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5";
+
+
+sub new {
+ my($class,$module,$file,$during) = @_;
+ bless { module => $module, file => $file, during => $during }, $class;
+}
+
+sub as_string {
+ my($self) = shift;
+ "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Exception/yaml_process_error.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Exception/yaml_process_error.pm
new file mode 100644
index 0000000000..ae8c14ebeb
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Exception/yaml_process_error.pm
@@ -0,0 +1,53 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Exception::yaml_process_error;
+use strict;
+use overload '""' => "as_string";
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5";
+
+
+sub new {
+ my($class,$module,$file,$during,$error) = @_;
+ # my $at = Carp::longmess(""); # XXX find something more beautiful
+ bless { module => $module,
+ file => $file,
+ during => $during,
+ error => $error,
+ # at => $at,
+ }, $class;
+}
+
+sub as_string {
+ my($self) = shift;
+ if ($self->{during}) {
+ if ($self->{file}) {
+ if ($self->{module}) {
+ if ($self->{error}) {
+ return "Alert: While trying to '$self->{during}' YAML file\n".
+ " '$self->{file}'\n".
+ "with '$self->{module}' the following error was encountered:\n".
+ " $self->{error}\n";
+ } else {
+ return "Alert: While trying to '$self->{during}' YAML file\n".
+ " '$self->{file}'\n".
+ "with '$self->{module}' some unknown error was encountered\n";
+ }
+ } else {
+ return "Alert: While trying to '$self->{during}' YAML file\n".
+ " '$self->{file}'\n".
+ "some unknown error was encountered\n";
+ }
+ } else {
+ return "Alert: While trying to '$self->{during}' some YAML file\n".
+ "some unknown error was encountered\n";
+ }
+ } else {
+ return "Alert: unknown error encountered\n";
+ }
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/FTP.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/FTP.pm
new file mode 100644
index 0000000000..6d9800e31b
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/FTP.pm
@@ -0,0 +1,1146 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::FTP;
+use strict;
+
+use Errno ();
+use Fcntl qw(:flock);
+use File::Basename qw(dirname);
+use File::Path qw(mkpath);
+use CPAN::FTP::netrc;
+use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod);
+
+@CPAN::FTP::ISA = qw(CPAN::Debug);
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5011";
+
+sub _plus_append_open {
+ my($fh, $file) = @_;
+ my $parent_dir = dirname $file;
+ mkpath $parent_dir;
+ my($cnt);
+ until (open $fh, "+>>$file") {
+ next if $! == Errno::EAGAIN; # don't increment on EAGAIN
+ $CPAN::Frontend->mydie("Could not open '$file' after 10000 tries: $!") if ++$cnt > 100000;
+ sleep 0.0001;
+ mkpath $parent_dir;
+ }
+}
+
+#-> sub CPAN::FTP::ftp_statistics
+# if they want to rewrite, they need to pass in a filehandle
+sub _ftp_statistics {
+ my($self,$fh) = @_;
+ my $locktype = $fh ? LOCK_EX : LOCK_SH;
+ # XXX On Windows flock() implements mandatory locking, so we can
+ # XXX only use shared locking to still allow _yaml_load_file() to
+ # XXX read from the file using a different filehandle.
+ $locktype = LOCK_SH if $^O eq "MSWin32";
+
+ $fh ||= FileHandle->new;
+ my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
+ _plus_append_open($fh,$file);
+ my $sleep = 1;
+ my $waitstart;
+ while (!CPAN::_flock($fh, $locktype|LOCK_NB)) {
+ $waitstart ||= localtime();
+ if ($sleep>3) {
+ my $now = localtime();
+ $CPAN::Frontend->mywarn("$now: waiting for read lock on '$file' (since $waitstart)\n");
+ }
+ sleep($sleep); # this sleep must not be overridden;
+ # Frontend->mysleep with AUTOMATED_TESTING has
+ # provoked complete lock contention on my NFS
+ if ($sleep <= 6) {
+ $sleep+=0.5;
+ } else {
+ # retry to get a fresh handle. If it is NFS and the handle is stale, we will never get an flock
+ _plus_append_open($fh, $file);
+ }
+ }
+ my $stats = eval { CPAN->_yaml_loadfile($file); };
+ if ($@) {
+ if (ref $@) {
+ if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
+ chomp $@;
+ $CPAN::Frontend->myprintonce("Warning (usually harmless): $@\n");
+ return;
+ } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
+ my $time = time;
+ my $to = "$file.$time";
+ $CPAN::Frontend->mywarn("Error reading '$file': $@
+ Trying to stash it away as '$to' to prevent further interruptions.
+ You may want to remove that file later.\n");
+ # may fail because somebody else has moved it away in the meantime:
+ rename $file, $to or $CPAN::Frontend->mywarn("Could not rename '$file' to '$to': $!\n");
+ return;
+ }
+ } else {
+ $CPAN::Frontend->mydie($@);
+ }
+ }
+ CPAN::_flock($fh, LOCK_UN);
+ return $stats->[0];
+}
+
+#-> sub CPAN::FTP::_mytime
+sub _mytime () {
+ if (CPAN->has_inst("Time::HiRes")) {
+ return Time::HiRes::time();
+ } else {
+ return time;
+ }
+}
+
+#-> sub CPAN::FTP::_new_stats
+sub _new_stats {
+ my($self,$file) = @_;
+ my $ret = {
+ file => $file,
+ attempts => [],
+ start => _mytime,
+ };
+ $ret;
+}
+
+#-> sub CPAN::FTP::_add_to_statistics
+sub _add_to_statistics {
+ my($self,$stats) = @_;
+ my $yaml_module = CPAN::_yaml_module();
+ $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
+ if ($CPAN::META->has_inst($yaml_module)) {
+ $stats->{thesiteurl} = $ThesiteURL;
+ $stats->{end} = CPAN::FTP::_mytime();
+ my $fh = FileHandle->new;
+ my $time = time;
+ my $sdebug = 0;
+ my @debug;
+ @debug = $time if $sdebug;
+ my $fullstats = $self->_ftp_statistics($fh);
+ close $fh;
+ $fullstats->{history} ||= [];
+ push @debug, scalar @{$fullstats->{history}} if $sdebug;
+ push @debug, time if $sdebug;
+ push @{$fullstats->{history}}, $stats;
+ # YAML.pm 0.62 is unacceptably slow with 999;
+ # YAML::Syck 0.82 has no noticable performance problem with 999;
+ my $ftpstats_size = $CPAN::Config->{ftpstats_size} || 99;
+ my $ftpstats_period = $CPAN::Config->{ftpstats_period} || 14;
+ while (
+ @{$fullstats->{history}} > $ftpstats_size
+ || $time - $fullstats->{history}[0]{start} > 86400*$ftpstats_period
+ ) {
+ shift @{$fullstats->{history}}
+ }
+ push @debug, scalar @{$fullstats->{history}} if $sdebug;
+ push @debug, time if $sdebug;
+ push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
+ # need no eval because if this fails, it is serious
+ my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
+ CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
+ if ( $sdebug ) {
+ local $CPAN::DEBUG = 512; # FTP
+ push @debug, time;
+ CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
+ "after[%d]at[%d]oldest[%s]dumped backat[%d]",
+ @debug,
+ ));
+ }
+ # Win32 cannot rename a file to an existing filename
+ unlink($sfile) if ($^O eq 'MSWin32' or $^O eq 'os2');
+ _copy_stat($sfile, "$sfile.$$") if -e $sfile;
+ rename "$sfile.$$", $sfile
+ or $CPAN::Frontend->mywarn("Could not rename '$sfile.$$' to '$sfile': $!\nGiving up\n");
+ }
+}
+
+# Copy some stat information (owner, group, mode and) from one file to
+# another.
+# This is a utility function which might be moved to a utility repository.
+#-> sub CPAN::FTP::_copy_stat
+sub _copy_stat {
+ my($src, $dest) = @_;
+ my @stat = stat($src);
+ if (!@stat) {
+ $CPAN::Frontend->mywarn("Can't stat '$src': $!\n");
+ return;
+ }
+
+ eval {
+ chmod $stat[2], $dest
+ or $CPAN::Frontend->mywarn("Can't chmod '$dest' to " . sprintf("0%o", $stat[2]) . ": $!\n");
+ };
+ warn $@ if $@;
+ eval {
+ chown $stat[4], $stat[5], $dest
+ or do {
+ my $save_err = $!; # otherwise it's lost in the get... calls
+ $CPAN::Frontend->mywarn("Can't chown '$dest' to " .
+ (getpwuid($stat[4]))[0] . "/" .
+ (getgrgid($stat[5]))[0] . ": $save_err\n"
+ );
+ };
+ };
+ warn $@ if $@;
+}
+
+# if file is CHECKSUMS, suggest the place where we got the file to be
+# checked from, maybe only for young files?
+#-> sub CPAN::FTP::_recommend_url_for
+sub _recommend_url_for {
+ my($self, $file, $urllist) = @_;
+ if ($file =~ s|/CHECKSUMS(.gz)?$||) {
+ my $fullstats = $self->_ftp_statistics();
+ my $history = $fullstats->{history} || [];
+ while (my $last = pop @$history) {
+ last if $last->{end} - time > 3600; # only young results are interesting
+ next unless $last->{file}; # dirname of nothing dies!
+ next unless $file eq dirname($last->{file});
+ return $last->{thesiteurl};
+ }
+ }
+ if ($CPAN::Config->{randomize_urllist}
+ &&
+ rand(1) < $CPAN::Config->{randomize_urllist}
+ ) {
+ $urllist->[int rand scalar @$urllist];
+ } else {
+ return ();
+ }
+}
+
+#-> sub CPAN::FTP::_get_urllist
+sub _get_urllist {
+ my($self, $with_defaults) = @_;
+ $with_defaults ||= 0;
+ CPAN->debug("with_defaults[$with_defaults]") if $CPAN::DEBUG;
+
+ $CPAN::Config->{urllist} ||= [];
+ unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
+ $CPAN::Frontend->mywarn("Malformed urllist; ignoring. Configuration file corrupt?\n");
+ $CPAN::Config->{urllist} = [];
+ }
+ my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
+ push @urllist, @CPAN::Defaultsites if $with_defaults;
+ for my $u (@urllist) {
+ CPAN->debug("u[$u]") if $CPAN::DEBUG;
+ if (UNIVERSAL::can($u,"text")) {
+ $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
+ } else {
+ $u .= "/" unless substr($u,-1) eq "/";
+ $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
+ }
+ }
+ \@urllist;
+}
+
+#-> sub CPAN::FTP::ftp_get ;
+sub ftp_get {
+ my($class,$host,$dir,$file,$target) = @_;
+ $class->debug(
+ qq[Going to fetch file [$file] from dir [$dir]
+ on host [$host] as local [$target]\n]
+ ) if $CPAN::DEBUG;
+ my $ftp = Net::FTP->new($host);
+ unless ($ftp) {
+ $CPAN::Frontend->mywarn(" Could not connect to host '$host' with Net::FTP\n");
+ return;
+ }
+ return 0 unless defined $ftp;
+ $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
+ $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
+ unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ) {
+ my $msg = $ftp->message;
+ $CPAN::Frontend->mywarn(" Couldn't login on $host: $msg\n");
+ return;
+ }
+ unless ( $ftp->cwd($dir) ) {
+ my $msg = $ftp->message;
+ $CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg\n");
+ return;
+ }
+ $ftp->binary;
+ $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
+ unless ( $ftp->get($file,$target) ) {
+ my $msg = $ftp->message;
+ $CPAN::Frontend->mywarn(" Couldn't fetch $file from $host: $msg\n");
+ return;
+ }
+ $ftp->quit; # it's ok if this fails
+ return 1;
+}
+
+# If more accuracy is wanted/needed, Chris Leach sent me this patch...
+
+ # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
+ # > --- /tmp/cp Wed Sep 24 13:26:40 1997
+ # > ***************
+ # > *** 1562,1567 ****
+ # > --- 1562,1580 ----
+ # > return 1 if substr($url,0,4) eq "file";
+ # > return 1 unless $url =~ m|://([^/]+)|;
+ # > my $host = $1;
+ # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
+ # > + if ($proxy) {
+ # > + $proxy =~ m|://([^/:]+)|;
+ # > + $proxy = $1;
+ # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
+ # > + if ($noproxy) {
+ # > + if ($host !~ /$noproxy$/) {
+ # > + $host = $proxy;
+ # > + }
+ # > + } else {
+ # > + $host = $proxy;
+ # > + }
+ # > + }
+ # > require Net::Ping;
+ # > return 1 unless $Net::Ping::VERSION >= 2;
+ # > my $p;
+
+
+#-> sub CPAN::FTP::localize ;
+sub localize {
+ my($self,$file,$aslocal,$force,$with_defaults) = @_;
+ $force ||= 0;
+ Carp::croak( "Usage: ->localize(cpan_file,as_local_file[,\$force])" )
+ unless defined $aslocal;
+ if ($CPAN::DEBUG){
+ require Carp;
+ my $longmess = Carp::longmess();
+ $self->debug("file[$file] aslocal[$aslocal] force[$force] carplongmess[$longmess]");
+ }
+ if ($^O eq 'MacOS') {
+ # Comment by AK on 2000-09-03: Uniq short filenames would be
+ # available in CHECKSUMS file
+ my($name, $path) = File::Basename::fileparse($aslocal, '');
+ if (length($name) > 31) {
+ $name =~ s/(
+ \.(
+ readme(\.(gz|Z))? |
+ (tar\.)?(gz|Z) |
+ tgz |
+ zip |
+ pm\.(gz|Z)
+ )
+ )$//x;
+ my $suf = $1;
+ my $size = 31 - length($suf);
+ while (length($name) > $size) {
+ chop $name;
+ }
+ $name .= $suf;
+ $aslocal = File::Spec->catfile($path, $name);
+ }
+ }
+
+ if (-f $aslocal && -r _ && !($force & 1)) {
+ my $size;
+ if ($size = -s $aslocal) {
+ $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
+ return $aslocal;
+ } else {
+ # empty file from a previous unsuccessful attempt to download it
+ unlink $aslocal or
+ $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
+ "could not remove.");
+ }
+ }
+ my($maybe_restore) = 0;
+ if (-f $aslocal) {
+ rename $aslocal, "$aslocal.bak$$";
+ $maybe_restore++;
+ }
+
+ my($aslocal_dir) = dirname($aslocal);
+ # Inheritance is not easier to manage than a few if/else branches
+ if ($CPAN::META->has_usable('LWP::UserAgent')) {
+ unless ($Ua) {
+ CPAN::LWP::UserAgent->config;
+ eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
+ if ($@) {
+ $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
+ if $CPAN::DEBUG;
+ } else {
+ my($var);
+ $Ua->proxy('ftp', $var)
+ if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
+ $Ua->proxy('http', $var)
+ if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
+ $Ua->no_proxy($var)
+ if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
+ }
+ }
+ }
+ for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
+ $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
+ }
+
+ # Try the list of urls for each single object. We keep a record
+ # where we did get a file from
+ my(@reordered,$last);
+ my $ccurllist = $self->_get_urllist($with_defaults);
+ $last = $#$ccurllist;
+ if ($force & 2) { # local cpans probably out of date, don't reorder
+ @reordered = (0..$last);
+ } else {
+ @reordered =
+ sort {
+ (substr($ccurllist->[$b],0,4) eq "file")
+ <=>
+ (substr($ccurllist->[$a],0,4) eq "file")
+ or
+ defined($ThesiteURL)
+ and
+ ($ccurllist->[$b] eq $ThesiteURL)
+ <=>
+ ($ccurllist->[$a] eq $ThesiteURL)
+ } 0..$last;
+ }
+ my(@levels);
+ $Themethod ||= "";
+ $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
+ my @all_levels = (
+ ["dleasy", "file"],
+ ["dleasy"],
+ ["dlhard"],
+ ["dlhardest"],
+ ["dleasy", "http","defaultsites"],
+ ["dlhard", "http","defaultsites"],
+ ["dleasy", "ftp", "defaultsites"],
+ ["dlhard", "ftp", "defaultsites"],
+ ["dlhardest","", "defaultsites"],
+ );
+ if ($Themethod) {
+ @levels = grep {$_->[0] eq $Themethod} @all_levels;
+ push @levels, grep {$_->[0] ne $Themethod} @all_levels;
+ } else {
+ @levels = @all_levels;
+ }
+ @levels = qw/dleasy/ if $^O eq 'MacOS';
+ my($levelno);
+ local $ENV{FTP_PASSIVE} =
+ exists $CPAN::Config->{ftp_passive} ?
+ $CPAN::Config->{ftp_passive} : 1;
+ my $ret;
+ my $stats = $self->_new_stats($file);
+ for ($CPAN::Config->{connect_to_internet_ok}) {
+ $connect_to_internet_ok = $_ if not defined $connect_to_internet_ok and defined $_;
+ }
+ LEVEL: for $levelno (0..$#levels) {
+ my $level_tuple = $levels[$levelno];
+ my($level,$scheme,$sitetag) = @$level_tuple;
+ $self->mymkpath($aslocal_dir) unless $scheme && "file" eq $scheme;
+ my $defaultsites = $sitetag && $sitetag eq "defaultsites" && !@$ccurllist;
+ my @urllist;
+ if ($defaultsites) {
+ unless (defined $connect_to_internet_ok) {
+ $CPAN::Frontend->myprint(sprintf qq{
+I would like to connect to one of the following sites to get '%s':
+
+%s
+},
+ $file,
+ join("",map { " ".$_->text."\n" } @CPAN::Defaultsites),
+ );
+ my $answer = CPAN::Shell::colorable_makemaker_prompt("Is it OK to try to connect to the Internet?", "yes");
+ if ($answer =~ /^y/i) {
+ $connect_to_internet_ok = 1;
+ } else {
+ $connect_to_internet_ok = 0;
+ }
+ }
+ if ($connect_to_internet_ok) {
+ @urllist = @CPAN::Defaultsites;
+ } else {
+ my $sleep = 2;
+ # the tricky thing about dying here is that everybody
+ # believes that calls to exists() or all_objects() are
+ # safe.
+ require CPAN::Exception::blocked_urllist;
+ die CPAN::Exception::blocked_urllist->new;
+ }
+ } else { # ! $defaultsites
+ my @host_seq = $level =~ /dleasy/ ?
+ @reordered : 0..$last; # reordered has file and $Thesiteurl first
+ @urllist = map { $ccurllist->[$_] } @host_seq;
+ }
+ $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
+ my $aslocal_tempfile = $aslocal . ".tmp" . $$;
+ if (my $recommend = $self->_recommend_url_for($file,\@urllist)) {
+ @urllist = grep { $_ ne $recommend } @urllist;
+ unshift @urllist, $recommend;
+ }
+ $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
+ $ret = $self->hostdlxxx($level,$scheme,\@urllist,$file,$aslocal_tempfile,$stats);
+ if ($ret) {
+ CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
+ if ($ret eq $aslocal_tempfile) {
+ # if we got it exactly as we asked for, only then we
+ # want to rename
+ rename $aslocal_tempfile, $aslocal
+ or $CPAN::Frontend->mydie("Error while trying to rename ".
+ "'$ret' to '$aslocal': $!");
+ $ret = $aslocal;
+ }
+ elsif (-f $ret && $scheme eq 'file' ) {
+ # it's a local file, so there's nothing left to do, we
+ # let them read from where it is
+ }
+ $Themethod = $level;
+ my $now = time;
+ # utime $now, $now, $aslocal; # too bad, if we do that, we
+ # might alter a local mirror
+ $self->debug("level[$level]") if $CPAN::DEBUG;
+ last LEVEL;
+ } else {
+ unlink $aslocal_tempfile;
+ last if $CPAN::Signal; # need to cleanup
+ }
+ }
+ if ($ret) {
+ $stats->{filesize} = -s $ret;
+ }
+ $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
+ $self->_add_to_statistics($stats);
+ $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
+ if ($ret) {
+ unlink "$aslocal.bak$$";
+ return $ret;
+ }
+ unless ($CPAN::Signal) {
+ my(@mess);
+ local $" = " ";
+ if (@{$CPAN::Config->{urllist}}) {
+ push @mess,
+ qq{Please check, if the URLs I found in your configuration file \(}.
+ join(", ", @{$CPAN::Config->{urllist}}).
+ qq{\) are valid.};
+ } else {
+ push @mess, qq{Your urllist is empty!};
+ }
+ push @mess, qq{The urllist can be edited.},
+ qq{E.g. with 'o conf urllist push ftp://myurl/'};
+ $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
+ $CPAN::Frontend->mydie("Could not fetch $file\n");
+ }
+ if ($maybe_restore) {
+ rename "$aslocal.bak$$", $aslocal;
+ $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
+ $self->ls($aslocal) . "\n");
+ return $aslocal;
+ }
+ return;
+}
+
+sub mymkpath {
+ my($self, $aslocal_dir) = @_;
+ mkpath($aslocal_dir);
+ $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
+ qq{directory "$aslocal_dir".
+ I\'ll continue, but if you encounter problems, they may be due
+ to insufficient permissions.\n}) unless -w $aslocal_dir;
+}
+
+sub hostdlxxx {
+ my $self = shift;
+ my $level = shift;
+ my $scheme = shift;
+ my $h = shift;
+ $h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme;
+ my $method = "host$level";
+ $self->$method($h, @_);
+}
+
+sub _set_attempt {
+ my($self,$stats,$method,$url) = @_;
+ push @{$stats->{attempts}}, {
+ method => $method,
+ start => _mytime,
+ url => $url,
+ };
+}
+
+# package CPAN::FTP;
+sub hostdleasy { #called from hostdlxxx
+ my($self,$host_seq,$file,$aslocal,$stats) = @_;
+ my($ro_url);
+ HOSTEASY: for $ro_url (@$host_seq) {
+ $self->_set_attempt($stats,"dleasy",$ro_url);
+ my $url = "$ro_url$file";
+ $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
+ if ($url =~ /^file:/) {
+ my $l;
+ if ($CPAN::META->has_inst('URI::URL')) {
+ my $u = URI::URL->new($url);
+ $l = $u->file;
+ } else { # works only on Unix, is poorly constructed, but
+ # hopefully better than nothing.
+ # RFC 1738 says fileurl BNF is
+ # fileurl = "file://" [ host | "localhost" ] "/" fpath
+ # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
+ # the code
+ ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
+ $l =~ s|^file:||; # assume they
+ # meant
+ # file://localhost
+ $l =~ s|^/||s
+ if ! -f $l && $l =~ m|^/\w:|; # e.g. /P:
+ }
+ $self->debug("local file[$l]") if $CPAN::DEBUG;
+ if ( -f $l && -r _) {
+ $ThesiteURL = $ro_url;
+ return $l;
+ }
+ # If request is for a compressed file and we can find the
+ # uncompressed file also, return the path of the uncompressed file
+ # otherwise, decompress it and return the resulting path
+ if ($l =~ /(.+)\.gz$/) {
+ my $ungz = $1;
+ if ( -f $ungz && -r _) {
+ $ThesiteURL = $ro_url;
+ return $ungz;
+ }
+ elsif (-f $l && -r _) {
+ eval { CPAN::Tarzip->new($l)->gunzip($aslocal) };
+ if ( -f $aslocal && -s _) {
+ $ThesiteURL = $ro_url;
+ return $aslocal;
+ }
+ elsif (! -s $aslocal) {
+ unlink $aslocal;
+ }
+ elsif (-f $l) {
+ $CPAN::Frontend->mywarn("Error decompressing '$l': $@\n")
+ if $@;
+ return;
+ }
+ }
+ }
+ # Otherwise, return the local file path if it exists
+ elsif ( -f $l && -r _) {
+ $ThesiteURL = $ro_url;
+ return $l;
+ }
+ # If we can't find it, but there is a compressed version
+ # of it, then decompress it
+ elsif (-f "$l.gz") {
+ $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
+ eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
+ if ( -f $aslocal) {
+ $ThesiteURL = $ro_url;
+ return $aslocal;
+ }
+ else {
+ $CPAN::Frontend->mywarn("Error decompressing '$l': $@\n")
+ if $@;
+ return;
+ }
+ }
+ $CPAN::Frontend->mywarn("Could not find '$l'\n");
+ }
+ $self->debug("it was not a file URL") if $CPAN::DEBUG;
+ if ($CPAN::META->has_usable('LWP')) {
+ $CPAN::Frontend->myprint("Fetching with LWP:\n$url\n");
+ unless ($Ua) {
+ CPAN::LWP::UserAgent->config;
+ eval { $Ua = CPAN::LWP::UserAgent->new; };
+ if ($@) {
+ $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
+ }
+ }
+ my $res = $Ua->mirror($url, $aslocal);
+ if ($res->is_success) {
+ $ThesiteURL = $ro_url;
+ my $now = time;
+ utime $now, $now, $aslocal; # download time is more
+ # important than upload
+ # time
+ return $aslocal;
+ } elsif ($url !~ /\.gz(?!\n)\Z/) {
+ my $gzurl = "$url.gz";
+ $CPAN::Frontend->myprint("Fetching with LWP:\n$gzurl\n");
+ $res = $Ua->mirror($gzurl, "$aslocal.gz");
+ if ($res->is_success) {
+ if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
+ $ThesiteURL = $ro_url;
+ return $aslocal;
+ }
+ }
+ } else {
+ $CPAN::Frontend->myprint(sprintf(
+ "LWP failed with code[%s] message[%s]\n",
+ $res->code,
+ $res->message,
+ ));
+ # Alan Burlison informed me that in firewall environments
+ # Net::FTP can still succeed where LWP fails. So we do not
+ # skip Net::FTP anymore when LWP is available.
+ }
+ } elsif ($url =~ /^http:/i && $CPAN::META->has_usable('HTTP::Tiny')) {
+ require CPAN::HTTP::Client;
+ my $chc = CPAN::HTTP::Client->new(
+ proxy => $CPAN::Config->{http_proxy} || $ENV{http_proxy},
+ no_proxy => $CPAN::Config->{no_proxy} || $ENV{no_proxy},
+ );
+ for my $try ( $url, ( $url !~ /\.gz(?!\n)\Z/ ? "$url.gz" : () ) ) {
+ $CPAN::Frontend->myprint("Fetching with HTTP::Tiny:\n$try\n");
+ my $res = eval { $chc->mirror($try, $aslocal) };
+ if ( $res && $res->{success} ) {
+ $ThesiteURL = $ro_url;
+ my $now = time;
+ utime $now, $now, $aslocal; # download time is more
+ # important than upload
+ # time
+ return $aslocal;
+ }
+ elsif ( $res && $res->{status} ne '599') {
+ $CPAN::Frontend->myprint(sprintf(
+ "HTTP::Tiny failed with code[%s] message[%s]\n",
+ $res->{status},
+ $res->{reason},
+ )
+ );
+ }
+ elsif ( $res && $res->{status} eq '599') {
+ $CPAN::Frontend->myprint(sprintf(
+ "HTTP::Tiny failed with an internal error: %s\n",
+ $res->{content},
+ )
+ );
+ }
+ else {
+ my $err = $@ || 'Unknown error';
+ $CPAN::Frontend->myprint(sprintf(
+ "Error downloading with HTTP::Tiny: %s\n", $err
+ )
+ );
+ }
+ }
+ }
+ return if $CPAN::Signal;
+ if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
+ # that's the nice and easy way thanks to Graham
+ $self->debug("recognized ftp") if $CPAN::DEBUG;
+ my($host,$dir,$getfile) = ($1,$2,$3);
+ if ($CPAN::META->has_usable('Net::FTP')) {
+ $dir =~ s|/+|/|g;
+ $CPAN::Frontend->myprint("Fetching with Net::FTP:\n$url\n");
+ $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
+ "aslocal[$aslocal]") if $CPAN::DEBUG;
+ if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
+ $ThesiteURL = $ro_url;
+ return $aslocal;
+ }
+ if ($aslocal !~ /\.gz(?!\n)\Z/) {
+ my $gz = "$aslocal.gz";
+ $CPAN::Frontend->myprint("Fetching with Net::FTP\n$url.gz\n");
+ if (CPAN::FTP->ftp_get($host,
+ $dir,
+ "$getfile.gz",
+ $gz) &&
+ eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
+ ) {
+ $ThesiteURL = $ro_url;
+ return $aslocal;
+ }
+ }
+ # next HOSTEASY;
+ } else {
+ CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
+ }
+ }
+ if (
+ UNIVERSAL::can($ro_url,"text")
+ and
+ $ro_url->{FROM} eq "USER"
+ ) {
+ ##address #17973: default URLs should not try to override
+ ##user-defined URLs just because LWP is not available
+ my $ret = $self->hostdlhard([$ro_url],$file,$aslocal,$stats);
+ return $ret if $ret;
+ }
+ return if $CPAN::Signal;
+ }
+}
+
+# package CPAN::FTP;
+sub hostdlhard {
+ my($self,$host_seq,$file,$aslocal,$stats) = @_;
+
+ # Came back if Net::FTP couldn't establish connection (or
+ # failed otherwise) Maybe they are behind a firewall, but they
+ # gave us a socksified (or other) ftp program...
+
+ my($ro_url);
+ my($devnull) = $CPAN::Config->{devnull} || "";
+ # < /dev/null ";
+ my($aslocal_dir) = dirname($aslocal);
+ mkpath($aslocal_dir);
+ my $some_dl_success = 0;
+ my $any_attempt = 0;
+ HOSTHARD: for $ro_url (@$host_seq) {
+ $self->_set_attempt($stats,"dlhard",$ro_url);
+ my $url = "$ro_url$file";
+ my($proto,$host,$dir,$getfile);
+
+ # Courtesy Mark Conty mark_conty@cargill.com change from
+ # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
+ # to
+ if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
+ # proto not yet used
+ ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
+ } else {
+ next HOSTHARD; # who said, we could ftp anything except ftp?
+ }
+ next HOSTHARD if $proto eq "file"; # file URLs would have had
+ # success above. Likely a bogus URL
+
+ # making at least one attempt against a host
+ $any_attempt++;
+
+ $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
+
+ # Try the most capable first and leave ncftp* for last as it only
+ # does FTP.
+ my $proxy_vars = $self->_proxy_vars($ro_url);
+ DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
+ my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
+ next DLPRG unless defined $funkyftp;
+ next DLPRG if $funkyftp =~ /^\s*$/;
+
+ my($src_switch) = "";
+ my($chdir) = "";
+ my($stdout_redir) = " > \"$aslocal\"";
+ if ($f eq "lynx") {
+ $src_switch = " -source";
+ } elsif ($f eq "ncftp") {
+ next DLPRG unless $url =~ m{\Aftp://};
+ $src_switch = " -c";
+ } elsif ($f eq "wget") {
+ $src_switch = " -O \"$aslocal\"";
+ $stdout_redir = "";
+ } elsif ($f eq 'curl') {
+ $src_switch = ' -L -f -s -S --netrc-optional';
+ if ($proxy_vars->{http_proxy}) {
+ $src_switch .= qq{ -U "$proxy_vars->{proxy_user}:$proxy_vars->{proxy_pass}" -x "$proxy_vars->{http_proxy}"};
+ }
+ } elsif ($f eq "ncftpget") {
+ next DLPRG unless $url =~ m{\Aftp://};
+ $chdir = "cd $aslocal_dir && ";
+ $stdout_redir = "";
+ }
+ $CPAN::Frontend->myprint(
+ qq[
+Trying with
+ $funkyftp$src_switch
+to get
+ $url
+]);
+ my($system) =
+ "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
+ $self->debug("system[$system]") if $CPAN::DEBUG;
+ my($wstatus) = system($system);
+ if ($f eq "lynx") {
+ # lynx returns 0 when it fails somewhere
+ if (-s $aslocal) {
+ my $content = do { local *FH;
+ open FH, $aslocal or die;
+ local $/;
+ <FH> };
+ if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
+ $CPAN::Frontend->mywarn(qq{
+No success, the file that lynx has downloaded looks like an error message:
+$content
+});
+ $CPAN::Frontend->mysleep(1);
+ next DLPRG;
+ }
+ $some_dl_success++;
+ } else {
+ $CPAN::Frontend->myprint(qq{
+No success, the file that lynx has downloaded is an empty file.
+});
+ next DLPRG;
+ }
+ }
+ if ($wstatus == 0) {
+ if (-s $aslocal) {
+ # Looks good
+ $some_dl_success++;
+ }
+ $ThesiteURL = $ro_url;
+ return $aslocal;
+ } else {
+ my $estatus = $wstatus >> 8;
+ my $size = -f $aslocal ?
+ ", left\n$aslocal with size ".-s _ :
+ "\nWarning: expected file [$aslocal] doesn't exist";
+ $CPAN::Frontend->myprint(qq{
+ Function system("$system")
+ returned status $estatus (wstat $wstatus)$size
+ });
+ }
+ return if $CPAN::Signal;
+ } # download/transfer programs (DLPRG)
+ } # host
+ return unless $any_attempt;
+ if ($some_dl_success) {
+ $CPAN::Frontend->mywarn("Warning: doesn't seem we had substantial success downloading '$aslocal'. Don't know how to proceed.\n");
+ } else {
+ $CPAN::Frontend->mywarn("Warning: no success downloading '$aslocal'. Giving up on it.\n");
+ }
+ return;
+}
+
+#-> CPAN::FTP::_proxy_vars
+sub _proxy_vars {
+ my($self,$url) = @_;
+ my $ret = +{};
+ my $http_proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
+ if ($http_proxy) {
+ my($host) = $url =~ m|://([^/:]+)|;
+ my $want_proxy = 1;
+ my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'} || "";
+ my @noproxy = split /\s*,\s*/, $noproxy;
+ if ($host) {
+ DOMAIN: for my $domain (@noproxy) {
+ if ($host =~ /\Q$domain\E$/) { # cf. LWP::UserAgent
+ $want_proxy = 0;
+ last DOMAIN;
+ }
+ }
+ } else {
+ $CPAN::Frontend->mywarn(" Could not determine host from http_proxy '$http_proxy'\n");
+ }
+ if ($want_proxy) {
+ my($user, $pass) =
+ CPAN::HTTP::Credentials->get_proxy_credentials();
+ $ret = {
+ proxy_user => $user,
+ proxy_pass => $pass,
+ http_proxy => $http_proxy
+ };
+ }
+ }
+ return $ret;
+}
+
+# package CPAN::FTP;
+sub hostdlhardest {
+ my($self,$host_seq,$file,$aslocal,$stats) = @_;
+
+ return unless @$host_seq;
+ my($ro_url);
+ my($aslocal_dir) = dirname($aslocal);
+ mkpath($aslocal_dir);
+ my $ftpbin = $CPAN::Config->{ftp};
+ unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
+ $CPAN::Frontend->myprint("No external ftp command available\n\n");
+ return;
+ }
+ $CPAN::Frontend->mywarn(qq{
+As a last resort we now switch to the external ftp command '$ftpbin'
+to get '$aslocal'.
+
+Doing so often leads to problems that are hard to diagnose.
+
+If you're the victim of such problems, please consider unsetting the
+ftp config variable with
+
+ o conf ftp ""
+ o conf commit
+
+});
+ $CPAN::Frontend->mysleep(2);
+ HOSTHARDEST: for $ro_url (@$host_seq) {
+ $self->_set_attempt($stats,"dlhardest",$ro_url);
+ my $url = "$ro_url$file";
+ $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
+ unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
+ next;
+ }
+ my($host,$dir,$getfile) = ($1,$2,$3);
+ my $timestamp = 0;
+ my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
+ $ctime,$blksize,$blocks) = stat($aslocal);
+ $timestamp = $mtime ||= 0;
+ my($netrc) = CPAN::FTP::netrc->new;
+ my($netrcfile) = $netrc->netrc;
+ my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
+ my $targetfile = File::Basename::basename($aslocal);
+ my(@dialog);
+ push(
+ @dialog,
+ "lcd $aslocal_dir",
+ "cd /",
+ map("cd $_", split /\//, $dir), # RFC 1738
+ "bin",
+ "passive",
+ "get $getfile $targetfile",
+ "quit"
+ );
+ if (! $netrcfile) {
+ CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
+ } elsif ($netrc->hasdefault || $netrc->contains($host)) {
+ CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
+ $netrc->hasdefault,
+ $netrc->contains($host))) if $CPAN::DEBUG;
+ if ($netrc->protected) {
+ my $dialog = join "", map { " $_\n" } @dialog;
+ my $netrc_explain;
+ if ($netrc->contains($host)) {
+ $netrc_explain = "Relying that your .netrc entry for '$host' ".
+ "manages the login";
+ } else {
+ $netrc_explain = "Relying that your default .netrc entry ".
+ "manages the login";
+ }
+ $CPAN::Frontend->myprint(qq{
+ Trying with external ftp to get
+ '$url'
+ $netrc_explain
+ Sending the dialog
+$dialog
+}
+ );
+ $self->talk_ftp("$ftpbin$verbose $host",
+ @dialog);
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
+ $mtime ||= 0;
+ if ($mtime > $timestamp) {
+ $CPAN::Frontend->myprint("GOT $aslocal\n");
+ $ThesiteURL = $ro_url;
+ return $aslocal;
+ } else {
+ $CPAN::Frontend->myprint("Hmm... Still failed!\n");
+ }
+ return if $CPAN::Signal;
+ } else {
+ $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
+ qq{correctly protected.\n});
+ }
+ } else {
+ $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
+ nor does it have a default entry\n");
+ }
+
+ # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
+ # then and login manually to host, using e-mail as
+ # password.
+ $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
+ unshift(
+ @dialog,
+ "open $host",
+ "user anonymous $Config::Config{'cf_email'}"
+ );
+ my $dialog = join "", map { " $_\n" } @dialog;
+ $CPAN::Frontend->myprint(qq{
+ Trying with external ftp to get
+ $url
+ Sending the dialog
+$dialog
+}
+ );
+ $self->talk_ftp("$ftpbin$verbose -n", @dialog);
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
+ $mtime ||= 0;
+ if ($mtime > $timestamp) {
+ $CPAN::Frontend->myprint("GOT $aslocal\n");
+ $ThesiteURL = $ro_url;
+ return $aslocal;
+ } else {
+ $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
+ }
+ return if $CPAN::Signal;
+ $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
+ $CPAN::Frontend->mysleep(2);
+ } # host
+}
+
+# package CPAN::FTP;
+sub talk_ftp {
+ my($self,$command,@dialog) = @_;
+ my $fh = FileHandle->new;
+ $fh->open("|$command") or die "Couldn't open ftp: $!";
+ foreach (@dialog) { $fh->print("$_\n") }
+ $fh->close; # Wait for process to complete
+ my $wstatus = $?;
+ my $estatus = $wstatus >> 8;
+ $CPAN::Frontend->myprint(qq{
+Subprocess "|$command"
+ returned status $estatus (wstat $wstatus)
+}) if $wstatus;
+}
+
+# find2perl needs modularization, too, all the following is stolen
+# from there
+# CPAN::FTP::ls
+sub ls {
+ my($self,$name) = @_;
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
+ $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
+
+ my($perms,%user,%group);
+ my $pname = $name;
+
+ if ($blocks) {
+ $blocks = int(($blocks + 1) / 2);
+ }
+ else {
+ $blocks = int(($sizemm + 1023) / 1024);
+ }
+
+ if (-f _) { $perms = '-'; }
+ elsif (-d _) { $perms = 'd'; }
+ elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
+ elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
+ elsif (-p _) { $perms = 'p'; }
+ elsif (-S _) { $perms = 's'; }
+ else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
+
+ my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
+ my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
+ my $tmpmode = $mode;
+ my $tmp = $rwx[$tmpmode & 7];
+ $tmpmode >>= 3;
+ $tmp = $rwx[$tmpmode & 7] . $tmp;
+ $tmpmode >>= 3;
+ $tmp = $rwx[$tmpmode & 7] . $tmp;
+ substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
+ substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
+ substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
+ $perms .= $tmp;
+
+ my $user = $user{$uid} || $uid; # too lazy to implement lookup
+ my $group = $group{$gid} || $gid;
+
+ my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
+ my($timeyear);
+ my($moname) = $moname[$mon];
+ if (-M _ > 365.25 / 2) {
+ $timeyear = $year + 1900;
+ }
+ else {
+ $timeyear = sprintf("%02d:%02d", $hour, $min);
+ }
+
+ sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
+ $ino,
+ $blocks,
+ $perms,
+ $nlink,
+ $user,
+ $group,
+ $sizemm,
+ $moname,
+ $mday,
+ $timeyear,
+ $pname;
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/FTP/netrc.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/FTP/netrc.pm
new file mode 100644
index 0000000000..0778e8adbc
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/FTP/netrc.pm
@@ -0,0 +1,62 @@
+package CPAN::FTP::netrc;
+use strict;
+
+$CPAN::FTP::netrc::VERSION = $CPAN::FTP::netrc::VERSION = "1.01";
+
+# package CPAN::FTP::netrc;
+sub new {
+ my($class) = @_;
+ my $file = File::Spec->catfile($ENV{HOME},".netrc");
+
+ my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks)
+ = stat($file);
+ $mode ||= 0;
+ my $protected = 0;
+
+ my($fh,@machines,$hasdefault);
+ $hasdefault = 0;
+ $fh = FileHandle->new or die "Could not create a filehandle";
+
+ if($fh->open($file)) {
+ $protected = ($mode & 077) == 0;
+ local($/) = "";
+ NETRC: while (<$fh>) {
+ my(@tokens) = split " ", $_;
+ TOKEN: while (@tokens) {
+ my($t) = shift @tokens;
+ if ($t eq "default") {
+ $hasdefault++;
+ last NETRC;
+ }
+ last TOKEN if $t eq "macdef";
+ if ($t eq "machine") {
+ push @machines, shift @tokens;
+ }
+ }
+ }
+ } else {
+ $file = $hasdefault = $protected = "";
+ }
+
+ bless {
+ 'mach' => [@machines],
+ 'netrc' => $file,
+ 'hasdefault' => $hasdefault,
+ 'protected' => $protected,
+ }, $class;
+}
+
+# CPAN::FTP::netrc::hasdefault;
+sub hasdefault { shift->{'hasdefault'} }
+sub netrc { shift->{'netrc'} }
+sub protected { shift->{'protected'} }
+sub contains {
+ my($self,$mach) = @_;
+ for ( @{$self->{'mach'}} ) {
+ return 1 if $_ eq $mach;
+ }
+ return 0;
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/FirstTime.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/FirstTime.pm
new file mode 100644
index 0000000000..49fa8ab7b9
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/FirstTime.pm
@@ -0,0 +1,2117 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::FirstTime;
+use strict;
+
+use ExtUtils::MakeMaker ();
+use FileHandle ();
+use File::Basename ();
+use File::Path ();
+use File::Spec ();
+use CPAN::Mirrors ();
+use vars qw($VERSION $auto_config);
+$VERSION = "5.5311";
+
+=head1 NAME
+
+CPAN::FirstTime - Utility for CPAN::Config file Initialization
+
+=head1 SYNOPSIS
+
+CPAN::FirstTime::init()
+
+=head1 DESCRIPTION
+
+The init routine asks a few questions and writes a CPAN/Config.pm or
+CPAN/MyConfig.pm file (depending on what it is currently using).
+
+In the following all questions and explanations regarding config
+variables are collected.
+
+=cut
+
+# down until the next =back the manpage must be parsed by the program
+# because the text is used in the init dialogues.
+
+my @podpara = split /\n\n/, <<'=back';
+
+=over 2
+
+=item auto_commit
+
+Normally CPAN.pm keeps config variables in memory and changes need to
+be saved in a separate 'o conf commit' command to make them permanent
+between sessions. If you set the 'auto_commit' option to true, changes
+to a config variable are always automatically committed to disk.
+
+Always commit changes to config variables to disk?
+
+=item build_cache
+
+CPAN.pm can limit the size of the disk area for keeping the build
+directories with all the intermediate files.
+
+Cache size for build directory (in MB)?
+
+=item build_dir
+
+Directory where the build process takes place?
+
+=item build_dir_reuse
+
+Until version 1.88 CPAN.pm never trusted the contents of the build_dir
+directory between sessions. Since 1.88_58 CPAN.pm has a YAML-based
+mechanism that makes it possible to share the contents of the
+build_dir/ directory between different sessions with the same version
+of perl. People who prefer to test things several days before
+installing will like this feature because it saves a lot of time.
+
+If you say yes to the following question, CPAN will try to store
+enough information about the build process so that it can pick up in
+future sessions at the same state of affairs as it left a previous
+session.
+
+Store and re-use state information about distributions between
+CPAN.pm sessions?
+
+=item build_requires_install_policy
+
+When a module declares another one as a 'build_requires' prerequisite
+this means that the other module is only needed for building or
+testing the module but need not be installed permanently. In this case
+you may wish to install that other module nonetheless or just keep it
+in the 'build_dir' directory to have it available only temporarily.
+Installing saves time on future installations but makes the perl
+installation bigger.
+
+You can choose if you want to always install (yes), never install (no)
+or be always asked. In the latter case you can set the default answer
+for the question to yes (ask/yes) or no (ask/no).
+
+Policy on installing 'build_requires' modules (yes, no, ask/yes,
+ask/no)?
+
+=item cache_metadata
+
+To considerably speed up the initial CPAN shell startup, it is
+possible to use Storable to create a cache of metadata. If Storable is
+not available, the normal index mechanism will be used.
+
+Note: this mechanism is not used when use_sqlite is on and SQLLite is
+running.
+
+Cache metadata (yes/no)?
+
+=item check_sigs
+
+CPAN packages can be digitally signed by authors and thus verified
+with the security provided by strong cryptography. The exact mechanism
+is defined in the Module::Signature module. While this is generally
+considered a good thing, it is not always convenient to the end user
+to install modules that are signed incorrectly or where the key of the
+author is not available or where some prerequisite for
+Module::Signature has a bug and so on.
+
+With the check_sigs parameter you can turn signature checking on and
+off. The default is off for now because the whole tool chain for the
+functionality is not yet considered mature by some. The author of
+CPAN.pm would recommend setting it to true most of the time and
+turning it off only if it turns out to be annoying.
+
+Note that if you do not have Module::Signature installed, no signature
+checks will be performed at all.
+
+Always try to check and verify signatures if a SIGNATURE file is in
+the package and Module::Signature is installed (yes/no)?
+
+=item cleanup_after_install
+
+Users who install modules and do not intend to look back, can free
+occupied disk space quickly by letting CPAN.pm cleanup each build
+directory immediately after a successful install.
+
+Remove build directory after a successful install? (yes/no)?
+
+=item colorize_output
+
+When you have Term::ANSIColor installed, you can turn on colorized
+output to have some visual differences between normal CPAN.pm output,
+warnings, debugging output, and the output of the modules being
+installed. Set your favorite colors after some experimenting with the
+Term::ANSIColor module.
+
+Please note that on Windows platforms colorized output also requires
+the Win32::Console::ANSI module.
+
+Do you want to turn on colored output?
+
+=item colorize_print
+
+Color for normal output?
+
+=item colorize_warn
+
+Color for warnings?
+
+=item colorize_debug
+
+Color for debugging messages?
+
+=item commandnumber_in_prompt
+
+The prompt of the cpan shell can contain the current command number
+for easier tracking of the session or be a plain string.
+
+Do you want the command number in the prompt (yes/no)?
+
+=item connect_to_internet_ok
+
+If you have never defined your own C<urllist> in your configuration
+then C<CPAN.pm> will be hesitant to use the built in default sites for
+downloading. It will ask you once per session if a connection to the
+internet is OK and only if you say yes, it will try to connect. But to
+avoid this question, you can choose your favorite download sites once
+and get away with it. Or, if you have no favorite download sites
+answer yes to the following question.
+
+If no urllist has been chosen yet, would you prefer CPAN.pm to connect
+to the built-in default sites without asking? (yes/no)?
+
+=item ftp_passive
+
+Shall we always set the FTP_PASSIVE environment variable when dealing
+with ftp download (yes/no)?
+
+=item ftpstats_period
+
+Statistics about downloads are truncated by size and period
+simultaneously.
+
+How many days shall we keep statistics about downloads?
+
+=item ftpstats_size
+
+Statistics about downloads are truncated by size and period
+simultaneously.
+
+How many items shall we keep in the statistics about downloads?
+
+=item getcwd
+
+CPAN.pm changes the current working directory often and needs to
+determine its own current working directory. Per default it uses
+Cwd::cwd but if this doesn't work on your system for some reason,
+alternatives can be configured according to the following table:
+
+ cwd Cwd::cwd
+ getcwd Cwd::getcwd
+ fastcwd Cwd::fastcwd
+ getdcwd Cwd::getdcwd
+ backtickcwd external command cwd
+
+Preferred method for determining the current working directory?
+
+=item halt_on_failure
+
+Normally, CPAN.pm continues processing the full list of targets and
+dependencies, even if one of them fails. However, you can specify
+that CPAN should halt after the first failure. (Note that optional
+recommended or suggested modules that fail will not cause a halt.)
+
+Do you want to halt on failure (yes/no)?
+
+=item histfile
+
+If you have one of the readline packages (Term::ReadLine::Perl,
+Term::ReadLine::Gnu, possibly others) installed, the interactive CPAN
+shell will have history support. The next two questions deal with the
+filename of the history file and with its size. If you do not want to
+set this variable, please hit SPACE ENTER to the following question.
+
+File to save your history?
+
+=item histsize
+
+Number of lines to save?
+
+=item inactivity_timeout
+
+Sometimes you may wish to leave the processes run by CPAN alone
+without caring about them. Because the Makefile.PL or the Build.PL
+sometimes contains question you're expected to answer, you can set a
+timer that will kill a 'perl Makefile.PL' process after the specified
+time in seconds.
+
+If you set this value to 0, these processes will wait forever. This is
+the default and recommended setting.
+
+Timeout for inactivity during {Makefile,Build}.PL?
+
+=item index_expire
+
+The CPAN indexes are usually rebuilt once or twice per hour, but the
+typical CPAN mirror mirrors only once or twice per day. Depending on
+the quality of your mirror and your desire to be on the bleeding edge,
+you may want to set the following value to more or less than one day
+(which is the default). It determines after how many days CPAN.pm
+downloads new indexes.
+
+Let the index expire after how many days?
+
+=item inhibit_startup_message
+
+When the CPAN shell is started it normally displays a greeting message
+that contains the running version and the status of readline support.
+
+Do you want to turn this message off?
+
+=item keep_source_where
+
+Unless you are accessing the CPAN on your filesystem via a file: URL,
+CPAN.pm needs to keep the source files it downloads somewhere. Please
+supply a directory where the downloaded files are to be kept.
+
+Download target directory?
+
+=item load_module_verbosity
+
+When CPAN.pm loads a module it needs for some optional feature, it
+usually reports about module name and version. Choose 'v' to get this
+message, 'none' to suppress it.
+
+Verbosity level for loading modules (none or v)?
+
+=item makepl_arg
+
+Every Makefile.PL is run by perl in a separate process. Likewise we
+run 'make' and 'make install' in separate processes. If you have
+any parameters (e.g. PREFIX, UNINST or the like) you want to
+pass to the calls, please specify them here.
+
+If you don't understand this question, just press ENTER.
+
+Typical frequently used settings:
+
+ PREFIX=~/perl # non-root users (please see manual for more hints)
+
+Parameters for the 'perl Makefile.PL' command?
+
+=item make_arg
+
+Parameters for the 'make' command? Typical frequently used setting:
+
+ -j3 # dual processor system (on GNU make)
+
+Your choice:
+
+=item make_install_arg
+
+Parameters for the 'make install' command?
+Typical frequently used setting:
+
+ UNINST=1 # to always uninstall potentially conflicting files
+ # (but do NOT use with local::lib or INSTALL_BASE)
+
+Your choice:
+
+=item make_install_make_command
+
+Do you want to use a different make command for 'make install'?
+Cautious people will probably prefer:
+
+ su root -c make
+ or
+ sudo make
+ or
+ /path1/to/sudo -u admin_account /path2/to/make
+
+or some such. Your choice:
+
+=item mbuildpl_arg
+
+A Build.PL is run by perl in a separate process. Likewise we run
+'./Build' and './Build install' in separate processes. If you have any
+parameters you want to pass to the calls, please specify them here.
+
+Typical frequently used settings:
+
+ --install_base /home/xxx # different installation directory
+
+Parameters for the 'perl Build.PL' command?
+
+=item mbuild_arg
+
+Parameters for the './Build' command? Setting might be:
+
+ --extra_linker_flags -L/usr/foo/lib # non-standard library location
+
+Your choice:
+
+=item mbuild_install_arg
+
+Parameters for the './Build install' command? Typical frequently used
+setting:
+
+ --uninst 1 # uninstall conflicting files
+ # (but do NOT use with local::lib or INSTALL_BASE)
+
+Your choice:
+
+=item mbuild_install_build_command
+
+Do you want to use a different command for './Build install'? Sudo
+users will probably prefer:
+
+ su root -c ./Build
+ or
+ sudo ./Build
+ or
+ /path1/to/sudo -u admin_account ./Build
+
+or some such. Your choice:
+
+=item pager
+
+What is your favorite pager program?
+
+=item prefer_installer
+
+When you have Module::Build installed and a module comes with both a
+Makefile.PL and a Build.PL, which shall have precedence?
+
+The main two standard installer modules are the old and well
+established ExtUtils::MakeMaker (for short: EUMM) which uses the
+Makefile.PL. And the next generation installer Module::Build (MB)
+which works with the Build.PL (and often comes with a Makefile.PL
+too). If a module comes only with one of the two we will use that one
+but if both are supplied then a decision must be made between EUMM and
+MB. See also http://rt.cpan.org/Ticket/Display.html?id=29235 for a
+discussion about the right default.
+
+Or, as a third option you can choose RAND which will make a random
+decision (something regular CPAN testers will enjoy).
+
+In case you can choose between running a Makefile.PL or a Build.PL,
+which installer would you prefer (EUMM or MB or RAND)?
+
+=item prefs_dir
+
+CPAN.pm can store customized build environments based on regular
+expressions for distribution names. These are YAML files where the
+default options for CPAN.pm and the environment can be overridden and
+dialog sequences can be stored that can later be executed by an
+Expect.pm object. The CPAN.pm distribution comes with some prefab YAML
+files that cover sample distributions that can be used as blueprints
+to store your own prefs. Please check out the distroprefs/ directory of
+the CPAN.pm distribution to get a quick start into the prefs system.
+
+Directory where to store default options/environment/dialogs for
+building modules that need some customization?
+
+=item prerequisites_policy
+
+The CPAN module can detect when a module which you are trying to build
+depends on prerequisites. If this happens, it can build the
+prerequisites for you automatically ('follow'), ask you for
+confirmation ('ask'), or just ignore them ('ignore'). Choosing
+'follow' also sets PERL_AUTOINSTALL and PERL_EXTUTILS_AUTOINSTALL for
+"--defaultdeps" if not already set.
+
+Please set your policy to one of the three values.
+
+Policy on building prerequisites (follow, ask or ignore)?
+
+=item randomize_urllist
+
+CPAN.pm can introduce some randomness when using hosts for download
+that are configured in the urllist parameter. Enter a numeric value
+between 0 and 1 to indicate how often you want to let CPAN.pm try a
+random host from the urllist. A value of one specifies to always use a
+random host as the first try. A value of zero means no randomness at
+all. Anything in between specifies how often, on average, a random
+host should be tried first.
+
+Randomize parameter
+
+=item recommends_policy
+
+(Experimental feature!) Some CPAN modules recommend additional, optional dependencies. These should
+generally be installed except in resource constrained environments. When this
+policy is true, recommended modules will be included with required modules.
+
+Include recommended modules?
+
+=item scan_cache
+
+By default, each time the CPAN module is started, cache scanning is
+performed to keep the cache size in sync ('atstart'). Alternatively,
+scanning and cleanup can happen when CPAN exits ('atexit'). To prevent
+any cache cleanup, answer 'never'.
+
+Perform cache scanning ('atstart', 'atexit' or 'never')?
+
+=item shell
+
+What is your favorite shell?
+
+=item show_unparsable_versions
+
+During the 'r' command CPAN.pm finds modules without version number.
+When the command finishes, it prints a report about this. If you
+want this report to be very verbose, say yes to the following
+variable.
+
+Show all individual modules that have no $VERSION?
+
+=item show_upload_date
+
+The 'd' and the 'm' command normally only show you information they
+have in their in-memory database and thus will never connect to the
+internet. If you set the 'show_upload_date' variable to true, 'm' and
+'d' will additionally show you the upload date of the module or
+distribution. Per default this feature is off because it may require a
+net connection to get at the upload date.
+
+Always try to show upload date with 'd' and 'm' command (yes/no)?
+
+=item show_zero_versions
+
+During the 'r' command CPAN.pm finds modules with a version number of
+zero. When the command finishes, it prints a report about this. If you
+want this report to be very verbose, say yes to the following
+variable.
+
+Show all individual modules that have a $VERSION of zero?
+
+=item suggests_policy
+
+(Experimental feature!) Some CPAN modules suggest additional, optional dependencies. These 'suggest'
+dependencies provide enhanced operation. When this policy is true, suggested
+modules will be included with required modules.
+
+Include suggested modules?
+
+=item tar_verbosity
+
+When CPAN.pm uses the tar command, which switch for the verbosity
+shall be used? Choose 'none' for quiet operation, 'v' for file
+name listing, 'vv' for full listing.
+
+Tar command verbosity level (none or v or vv)?
+
+=item term_is_latin
+
+The next option deals with the charset (a.k.a. character set) your
+terminal supports. In general, CPAN is English speaking territory, so
+the charset does not matter much but some CPAN have names that are
+outside the ASCII range. If your terminal supports UTF-8, you should
+say no to the next question. If it expects ISO-8859-1 (also known as
+LATIN1) then you should say yes. If it supports neither, your answer
+does not matter because you will not be able to read the names of some
+authors anyway. If you answer no, names will be output in UTF-8.
+
+Your terminal expects ISO-8859-1 (yes/no)?
+
+=item term_ornaments
+
+When using Term::ReadLine, you can turn ornaments on so that your
+input stands out against the output from CPAN.pm.
+
+Do you want to turn ornaments on?
+
+=item test_report
+
+The goal of the CPAN Testers project (http://testers.cpan.org/) is to
+test as many CPAN packages as possible on as many platforms as
+possible. This provides valuable feedback to module authors and
+potential users to identify bugs or platform compatibility issues and
+improves the overall quality and value of CPAN.
+
+One way you can contribute is to send test results for each module
+that you install. If you install the CPAN::Reporter module, you have
+the option to automatically generate and deliver test reports to CPAN
+Testers whenever you run tests on a CPAN package.
+
+See the CPAN::Reporter documentation for additional details and
+configuration settings. If your firewall blocks outgoing traffic,
+you may need to configure CPAN::Reporter before sending reports.
+
+Generate test reports if CPAN::Reporter is installed (yes/no)?
+
+=item perl5lib_verbosity
+
+When CPAN.pm extends @INC via PERL5LIB, it prints a list of
+directories added (or a summary of how many directories are
+added). Choose 'v' to get this message, 'none' to suppress it.
+
+Verbosity level for PERL5LIB changes (none or v)?
+
+=item prefer_external_tar
+
+Per default all untar operations are done with the perl module
+Archive::Tar; by setting this variable to true the external tar
+command is used if available; on Unix this is usually preferred
+because they have a reliable and fast gnutar implementation.
+
+Use the external tar program instead of Archive::Tar?
+
+=item trust_test_report_history
+
+When a distribution has already been tested by CPAN::Reporter on
+this machine, CPAN can skip the test phase and just rely on the
+test report history instead.
+
+Note that this will not apply to distributions that failed tests
+because of missing dependencies. Also, tests can be run
+regardless of the history using "force".
+
+Do you want to rely on the test report history (yes/no)?
+
+=item use_prompt_default
+
+When this is true, CPAN will set PERL_MM_USE_DEFAULT to a true
+value. This causes ExtUtils::MakeMaker (and compatible) prompts
+to use default values instead of stopping to prompt you to answer
+questions. It also sets NONINTERACTIVE_TESTING to a true value to
+signal more generally that distributions should not try to
+interact with you.
+
+Do you want to use prompt defaults (yes/no)?
+
+=item use_sqlite
+
+CPAN::SQLite is a layer between the index files that are downloaded
+from the CPAN and CPAN.pm that speeds up metadata queries and reduces
+memory consumption of CPAN.pm considerably.
+
+Use CPAN::SQLite if available? (yes/no)?
+
+=item version_timeout
+
+This timeout prevents CPAN from hanging when trying to parse a
+pathologically coded $VERSION from a module.
+
+The default is 15 seconds. If you set this value to 0, no timeout
+will occur, but this is not recommended.
+
+Timeout for parsing module versions?
+
+=item yaml_load_code
+
+Both YAML.pm and YAML::Syck are capable of deserialising code. As this
+requires a string eval, which might be a security risk, you can use
+this option to enable or disable the deserialisation of code via
+CPAN::DeferredCode. (Note: This does not work under perl 5.6)
+
+Do you want to enable code deserialisation (yes/no)?
+
+=item yaml_module
+
+At the time of this writing (2009-03) there are three YAML
+implementations working: YAML, YAML::Syck, and YAML::XS. The latter
+two are faster but need a C compiler installed on your system. There
+may be more alternative YAML conforming modules. When I tried two
+other players, YAML::Tiny and YAML::Perl, they seemed not powerful
+enough to work with CPAN.pm. This may have changed in the meantime.
+
+Which YAML implementation would you prefer?
+
+=back
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
+use vars qw( %prompts );
+
+{
+
+ my @prompts = (
+
+auto_config => qq{
+CPAN.pm requires configuration, but most of it can be done automatically.
+If you answer 'no' below, you will enter an interactive dialog for each
+configuration option instead.
+
+Would you like to configure as much as possible automatically?},
+
+auto_pick => qq{
+Would you like me to automatically choose some CPAN mirror
+sites for you? (This means connecting to the Internet)},
+
+config_intro => qq{
+
+The following questions are intended to help you with the
+configuration. The CPAN module needs a directory of its own to cache
+important index files and maybe keep a temporary mirror of CPAN files.
+This may be a site-wide or a personal directory.
+
+},
+
+# cpan_home => qq{ },
+
+cpan_home_where => qq{
+
+First of all, I'd like to create this directory. Where?
+
+},
+
+external_progs => qq{
+
+The CPAN module will need a few external programs to work properly.
+Please correct me, if I guess the wrong path for a program. Don't
+panic if you do not have some of them, just press ENTER for those. To
+disable the use of a program, you can type a space followed by ENTER.
+
+},
+
+proxy_intro => qq{
+
+If you're accessing the net via proxies, you can specify them in the
+CPAN configuration or via environment variables. The variable in
+the \$CPAN::Config takes precedence.
+
+},
+
+proxy_user => qq{
+
+If your proxy is an authenticating proxy, you can store your username
+permanently. If you do not want that, just press ENTER. You will then
+be asked for your username in every future session.
+
+},
+
+proxy_pass => qq{
+
+Your password for the authenticating proxy can also be stored
+permanently on disk. If this violates your security policy, just press
+ENTER. You will then be asked for the password in every future
+session.
+
+},
+
+urls_intro => qq{
+Now you need to choose your CPAN mirror sites. You can let me
+pick mirrors for you, you can select them from a list or you
+can enter them by hand.
+},
+
+urls_picker_intro => qq{First, pick a nearby continent and country by typing in the number(s)
+in front of the item(s) you want to select. You can pick several of
+each, separated by spaces. Then, you will be presented with a list of
+URLs of CPAN mirrors in the countries you selected, along with
+previously selected URLs. Select some of those URLs, or just keep the
+old list. Finally, you will be prompted for any extra URLs -- file:,
+ftp:, or http: -- that host a CPAN mirror.
+
+You should select more than one (just in case the first isn't available).
+
+},
+
+password_warn => qq{
+
+Warning: Term::ReadKey seems not to be available, your password will
+be echoed to the terminal!
+
+},
+
+install_help => qq{
+Warning: You do not have write permission for Perl library directories.
+
+To install modules, you need to configure a local Perl library directory or
+escalate your privileges. CPAN can help you by bootstrapping the local::lib
+module or by configuring itself to use 'sudo' (if available). You may also
+resolve this problem manually if you need to customize your setup.
+
+What approach do you want? (Choose 'local::lib', 'sudo' or 'manual')
+},
+
+local_lib_installed => qq{
+local::lib is installed. You must now add the following environment variables
+to your shell configuration files (or registry, if you are on Windows) and
+then restart your command line shell and CPAN before installing modules:
+
+},
+
+ );
+
+ die "Coding error in \@prompts declaration. Odd number of elements, above"
+ if (@prompts % 2);
+
+ %prompts = @prompts;
+
+ if (scalar(keys %prompts) != scalar(@prompts)/2) {
+ my %already;
+ for my $item (0..$#prompts) {
+ next if $item % 2;
+ die "$prompts[$item] is duplicated\n" if $already{$prompts[$item]}++;
+ }
+ }
+
+ shift @podpara;
+ while (@podpara) {
+ warn "Alert: cannot parse my own manpage for init dialog" unless $podpara[0] =~ s/^=item\s+//;
+ my $name = shift @podpara;
+ my @para;
+ while (@podpara && $podpara[0] !~ /^=item/) {
+ push @para, shift @podpara;
+ }
+ $prompts{$name} = pop @para;
+ if (@para) {
+ $prompts{$name . "_intro"} = join "", map { "$_\n\n" } @para;
+ }
+ }
+
+}
+
+sub init {
+ my($configpm, %args) = @_;
+ use Config;
+ # extra args after 'o conf init'
+ my $matcher = $args{args} && @{$args{args}} ? $args{args}[0] : '';
+ if ($matcher =~ /^\/(.*)\/$/) {
+ # case /regex/ => take the first, ignore the rest
+ $matcher = $1;
+ shift @{$args{args}};
+ if (@{$args{args}}) {
+ local $" = " ";
+ $CPAN::Frontend->mywarn("Ignoring excessive arguments '@{$args{args}}'");
+ $CPAN::Frontend->mysleep(2);
+ }
+ } elsif (0 == length $matcher) {
+ } elsif (0 && $matcher eq "~") { # extremely buggy, but a nice idea
+ my @unconfigured = sort grep { not exists $CPAN::Config->{$_}
+ or not defined $CPAN::Config->{$_}
+ or not length $CPAN::Config->{$_}
+ } keys %$CPAN::Config;
+ $matcher = "\\b(".join("|", @unconfigured).")\\b";
+ $CPAN::Frontend->mywarn("matcher[$matcher]");
+ } else {
+ # case WORD... => all arguments must be valid
+ for my $arg (@{$args{args}}) {
+ unless (exists $CPAN::HandleConfig::keys{$arg}) {
+ $CPAN::Frontend->mywarn("'$arg' is not a valid configuration variable\n");
+ return;
+ }
+ }
+ $matcher = "\\b(".join("|",@{$args{args}}).")\\b";
+ }
+ CPAN->debug("matcher[$matcher]") if $CPAN::DEBUG;
+
+ unless ($CPAN::VERSION) {
+ require CPAN::Nox;
+ }
+ require CPAN::HandleConfig;
+ CPAN::HandleConfig::require_myconfig_or_config();
+ $CPAN::Config ||= {};
+ local($/) = "\n";
+ local($\) = "";
+ local($|) = 1;
+
+ my($ans,$default); # why so half global?
+
+ #
+ #= Files, directories
+ #
+
+ local *_real_prompt;
+ if ( $args{autoconfig} ) {
+ $auto_config = 1;
+ } elsif ($matcher) {
+ $auto_config = 0;
+ } else {
+ my $_conf = prompt($prompts{auto_config}, "yes");
+ $auto_config = ($_conf and $_conf =~ /^y/i) ? 1 : 0;
+ }
+ CPAN->debug("auto_config[$auto_config]") if $CPAN::DEBUG;
+ if ( $auto_config ) {
+ local $^W = 0;
+ # prototype should match that of &MakeMaker::prompt
+ my $current_second = time;
+ my $current_second_count = 0;
+ my $i_am_mad = 0;
+ # silent prompting -- just quietly use default
+ *_real_prompt = sub { return $_[1] };
+ }
+
+ #
+ # bootstrap local::lib or sudo
+ #
+ unless ( $matcher
+ || _can_write_to_libdirs() || _using_installbase() || _using_sudo()
+ ) {
+ local $auto_config = 0; # We *must* ask, even under autoconfig
+ local *_real_prompt; # We *must* show prompt
+ my_prompt_loop(install_help => 'local::lib', $matcher,
+ 'local::lib|sudo|manual');
+ }
+ $CPAN::Config->{install_help} ||= ''; # Temporary to suppress warnings
+
+ if (!$matcher or q{
+ build_dir
+ build_dir_reuse
+ cpan_home
+ keep_source_where
+ prefs_dir
+ } =~ /$matcher/) {
+ $CPAN::Frontend->myprint($prompts{config_intro}) unless $auto_config;
+
+ init_cpan_home($matcher);
+
+ my_dflt_prompt("keep_source_where",
+ File::Spec->catdir($CPAN::Config->{cpan_home},"sources"),
+ $matcher,
+ );
+ my_dflt_prompt("build_dir",
+ File::Spec->catdir($CPAN::Config->{cpan_home},"build"),
+ $matcher
+ );
+ my_yn_prompt(build_dir_reuse => 0, $matcher);
+ my_dflt_prompt("prefs_dir",
+ File::Spec->catdir($CPAN::Config->{cpan_home},"prefs"),
+ $matcher
+ );
+ }
+
+ #
+ #= Config: auto_commit
+ #
+
+ my_yn_prompt(auto_commit => 0, $matcher);
+
+ #
+ #= Cache size, Index expire
+ #
+ my_dflt_prompt(build_cache => 100, $matcher);
+
+ my_dflt_prompt(index_expire => 1, $matcher);
+ my_prompt_loop(scan_cache => 'atstart', $matcher, 'atstart|atexit|never');
+ my_yn_prompt(cleanup_after_install => 0, $matcher);
+
+ #
+ #= cache_metadata
+ #
+
+ my_yn_prompt(cache_metadata => 1, $matcher);
+ my_yn_prompt(use_sqlite => 0, $matcher);
+
+ #
+ #= Do we follow PREREQ_PM?
+ #
+
+ my_prompt_loop(prerequisites_policy => 'follow', $matcher,
+ 'follow|ask|ignore');
+ my_prompt_loop(build_requires_install_policy => 'yes', $matcher,
+ 'yes|no|ask/yes|ask/no');
+ my_yn_prompt(recommends_policy => 1, $matcher);
+ my_yn_prompt(suggests_policy => 0, $matcher);
+
+ #
+ #= Module::Signature
+ #
+ my_yn_prompt(check_sigs => 0, $matcher);
+
+ #
+ #= CPAN::Reporter
+ #
+ if (!$matcher or 'test_report' =~ /$matcher/) {
+ my_yn_prompt(test_report => 0, $matcher);
+ if (
+ $matcher &&
+ $CPAN::Config->{test_report} &&
+ $CPAN::META->has_inst("CPAN::Reporter") &&
+ CPAN::Reporter->can('configure')
+ ) {
+ my $_conf = prompt("Would you like me configure CPAN::Reporter now?", "yes");
+ if ($_conf =~ /^y/i) {
+ $CPAN::Frontend->myprint("\nProceeding to configure CPAN::Reporter.\n");
+ CPAN::Reporter::configure();
+ $CPAN::Frontend->myprint("\nReturning to CPAN configuration.\n");
+ }
+ }
+ }
+
+ my_yn_prompt(trust_test_report_history => 0, $matcher);
+
+ #
+ #= YAML vs. YAML::Syck
+ #
+ if (!$matcher or "yaml_module" =~ /$matcher/) {
+ my_dflt_prompt(yaml_module => "YAML", $matcher);
+ my $old_v = $CPAN::Config->{load_module_verbosity};
+ $CPAN::Config->{load_module_verbosity} = q[none];
+ if (!$auto_config && !$CPAN::META->has_inst($CPAN::Config->{yaml_module})) {
+ $CPAN::Frontend->mywarn
+ ("Warning (maybe harmless): '$CPAN::Config->{yaml_module}' not installed.\n");
+ $CPAN::Frontend->mysleep(3);
+ }
+ $CPAN::Config->{load_module_verbosity} = $old_v;
+ }
+
+ #
+ #= YAML code deserialisation
+ #
+ my_yn_prompt(yaml_load_code => 0, $matcher);
+
+ #
+ #= External programs
+ #
+ my(@path) = split /$Config{'path_sep'}/, $ENV{'PATH'};
+ $CPAN::Frontend->myprint($prompts{external_progs})
+ if !$matcher && !$auto_config;
+ _init_external_progs($matcher, {
+ path => \@path,
+ progs => [ qw/make bzip2 gzip tar unzip gpg patch applypatch/ ],
+ shortcut => 0
+ });
+ _init_external_progs($matcher, {
+ path => \@path,
+ progs => [ qw/wget curl lynx ncftpget ncftp ftp/ ],
+ shortcut => 1
+ });
+
+ {
+ my $path = $CPAN::Config->{'pager'} ||
+ $ENV{PAGER} || find_exe("less",\@path) ||
+ find_exe("more",\@path) || ($^O eq 'MacOS' ? $ENV{EDITOR} : 0 )
+ || "more";
+ my_dflt_prompt(pager => $path, $matcher);
+ }
+
+ {
+ my $path = $CPAN::Config->{'shell'};
+ if ($path && File::Spec->file_name_is_absolute($path)) {
+ $CPAN::Frontend->mywarn("Warning: configured $path does not exist\n")
+ unless -e $path;
+ $path = "";
+ }
+ $path ||= $ENV{SHELL};
+ $path ||= $ENV{COMSPEC} if $^O eq "MSWin32";
+ if ($^O eq 'MacOS') {
+ $CPAN::Config->{'shell'} = 'not_here';
+ } else {
+ $path ||= 'sh', $path =~ s,\\,/,g if $^O eq 'os2'; # Cosmetic only
+ my_dflt_prompt(shell => $path, $matcher);
+ }
+ }
+
+ {
+ my $tar = $CPAN::Config->{tar};
+ my $prefer_external_tar = $CPAN::Config->{prefer_external_tar}; # XXX not yet supported
+ unless (defined $prefer_external_tar) {
+ if ($^O =~ /(MSWin32|solaris)/) {
+ # both have a record of broken tars
+ $prefer_external_tar = 0;
+ } elsif ($tar) {
+ $prefer_external_tar = 1;
+ } else {
+ $prefer_external_tar = 0;
+ }
+ }
+ my_yn_prompt(prefer_external_tar => $prefer_external_tar, $matcher);
+ }
+
+ #
+ # verbosity
+ #
+
+ my_prompt_loop(tar_verbosity => 'none', $matcher,
+ 'none|v|vv');
+ my_prompt_loop(load_module_verbosity => 'none', $matcher,
+ 'none|v');
+ my_prompt_loop(perl5lib_verbosity => 'none', $matcher,
+ 'none|v');
+ my_yn_prompt(inhibit_startup_message => 0, $matcher);
+
+ #
+ #= Installer, arguments to make etc.
+ #
+
+ my_prompt_loop(prefer_installer => 'MB', $matcher, 'MB|EUMM|RAND');
+
+ if (!$matcher or 'makepl_arg make_arg' =~ /$matcher/) {
+ my_dflt_prompt(makepl_arg => "", $matcher);
+ my_dflt_prompt(make_arg => "", $matcher);
+ if ( $CPAN::Config->{makepl_arg} =~ /LIBS=|INC=/ ) {
+ $CPAN::Frontend->mywarn(
+ "Warning: Using LIBS or INC in makepl_arg will likely break distributions\n" .
+ "that specify their own LIBS or INC options in Makefile.PL.\n"
+ );
+ }
+
+ }
+
+ require CPAN::HandleConfig;
+ if (exists $CPAN::HandleConfig::keys{make_install_make_command}) {
+ # as long as Windows needs $self->_build_command, we cannot
+ # support sudo on windows :-)
+ my $default = $CPAN::Config->{make} || "";
+ if ( $default && $CPAN::Config->{install_help} eq 'sudo' ) {
+ if ( find_exe('sudo') ) {
+ $default = "sudo $default";
+ delete $CPAN::Config->{make_install_make_command}
+ unless $CPAN::Config->{make_install_make_command} =~ /sudo/;
+ }
+ else {
+ $CPAN::Frontend->mywarnonce("Could not find 'sudo' in PATH\n");
+ }
+ }
+ my_dflt_prompt(make_install_make_command => $default, $matcher);
+ }
+
+ my_dflt_prompt(make_install_arg => $CPAN::Config->{make_arg} || "",
+ $matcher);
+
+ my_dflt_prompt(mbuildpl_arg => "", $matcher);
+ my_dflt_prompt(mbuild_arg => "", $matcher);
+
+ if (exists $CPAN::HandleConfig::keys{mbuild_install_build_command}
+ and $^O ne "MSWin32") {
+ # as long as Windows needs $self->_build_command, we cannot
+ # support sudo on windows :-)
+ my $default = $^O eq 'VMS' ? '@Build.com' : "./Build";
+ if ( $CPAN::Config->{install_help} eq 'sudo' ) {
+ if ( find_exe('sudo') ) {
+ $default = "sudo $default";
+ delete $CPAN::Config->{mbuild_install_build_command}
+ unless $CPAN::Config->{mbuild_install_build_command} =~ /sudo/;
+ }
+ else {
+ $CPAN::Frontend->mywarnonce("Could not find 'sudo' in PATH\n");
+ }
+ }
+ my_dflt_prompt(mbuild_install_build_command => $default, $matcher);
+ }
+
+ my_dflt_prompt(mbuild_install_arg => "", $matcher);
+
+ #
+ #== use_prompt_default
+ #
+ my_yn_prompt(use_prompt_default => 0, $matcher);
+
+ #
+ #= Alarm period
+ #
+
+ my_dflt_prompt(inactivity_timeout => 0, $matcher);
+ my_dflt_prompt(version_timeout => 15, $matcher);
+
+ #
+ #== halt_on_failure
+ #
+ my_yn_prompt(halt_on_failure => 0, $matcher);
+
+ #
+ #= Proxies
+ #
+
+ my @proxy_vars = qw/ftp_proxy http_proxy no_proxy/;
+ my @proxy_user_vars = qw/proxy_user proxy_pass/;
+ if (!$matcher or "@proxy_vars @proxy_user_vars" =~ /$matcher/) {
+ $CPAN::Frontend->myprint($prompts{proxy_intro}) unless $auto_config;
+
+ for (@proxy_vars) {
+ $prompts{$_} = "Your $_?";
+ my_dflt_prompt($_ => $ENV{$_}||"", $matcher);
+ }
+
+ if ($CPAN::Config->{ftp_proxy} ||
+ $CPAN::Config->{http_proxy}) {
+
+ $default = $CPAN::Config->{proxy_user} || $CPAN::LWP::UserAgent::USER || "";
+
+ $CPAN::Frontend->myprint($prompts{proxy_user}) unless $auto_config;
+
+ if ($CPAN::Config->{proxy_user} = prompt("Your proxy user id?",$default)) {
+ $CPAN::Frontend->myprint($prompts{proxy_pass}) unless $auto_config;
+
+ if ($CPAN::META->has_inst("Term::ReadKey")) {
+ Term::ReadKey::ReadMode("noecho");
+ } else {
+ $CPAN::Frontend->myprint($prompts{password_warn}) unless $auto_config;
+ }
+ $CPAN::Config->{proxy_pass} = prompt_no_strip("Your proxy password?");
+ if ($CPAN::META->has_inst("Term::ReadKey")) {
+ Term::ReadKey::ReadMode("restore");
+ }
+ $CPAN::Frontend->myprint("\n\n") unless $auto_config;
+ }
+ }
+ }
+
+ #
+ #= how plugins work
+ #
+
+ # XXX MISSING: my_array_prompt to be used with plugins. We did something like this near
+ # git log -p fd68f8f5e33f4cecea4fdb7abc5ee19c12f138f0..test-notest-test-dependency
+ # Need to do similar steps for plugin_list. As long as we do not support it here, people
+ # must use the cpan shell prompt to write something like
+ # o conf plugin_list push CPAN::Plugin::Specfile=dir,/tmp/foo-20141013,...
+ # o conf commit
+
+ #
+ #= how FTP works
+ #
+
+ my_yn_prompt(ftp_passive => 1, $matcher);
+
+ #
+ #= how cwd works
+ #
+
+ my_prompt_loop(getcwd => 'cwd', $matcher,
+ 'cwd|getcwd|fastcwd|getdcwd|backtickcwd');
+
+ #
+ #= the CPAN shell itself (prompt, color)
+ #
+
+ my_yn_prompt(commandnumber_in_prompt => 1, $matcher);
+ my_yn_prompt(term_ornaments => 1, $matcher);
+ if ("colorize_output colorize_print colorize_warn colorize_debug" =~ $matcher) {
+ my_yn_prompt(colorize_output => 0, $matcher);
+ if ($CPAN::Config->{colorize_output}) {
+ if ($CPAN::META->has_inst("Term::ANSIColor")) {
+ my $T="gYw";
+ $CPAN::Frontend->myprint( " on_ on_y ".
+ " on_ma on_\n") unless $auto_config;
+ $CPAN::Frontend->myprint( " on_black on_red green ellow ".
+ "on_blue genta on_cyan white\n") unless $auto_config;
+
+ for my $FG ("", "bold",
+ map {$_,"bold $_"} "black","red","green",
+ "yellow","blue",
+ "magenta",
+ "cyan","white") {
+ $CPAN::Frontend->myprint(sprintf( "%12s ", $FG)) unless $auto_config;
+ for my $BG ("",map {"on_$_"} qw(black red green yellow
+ blue magenta cyan white)) {
+ $CPAN::Frontend->myprint( $FG||$BG ?
+ Term::ANSIColor::colored(" $T ","$FG $BG") : " $T ") unless $auto_config;
+ }
+ $CPAN::Frontend->myprint( "\n" ) unless $auto_config;
+ }
+ $CPAN::Frontend->myprint( "\n" ) unless $auto_config;
+ }
+ for my $tuple (
+ ["colorize_print", "bold blue on_white"],
+ ["colorize_warn", "bold red on_white"],
+ ["colorize_debug", "black on_cyan"],
+ ) {
+ my_dflt_prompt($tuple->[0] => $tuple->[1], $matcher);
+ if ($CPAN::META->has_inst("Term::ANSIColor")) {
+ eval { Term::ANSIColor::color($CPAN::Config->{$tuple->[0]})};
+ if ($@) {
+ $CPAN::Config->{$tuple->[0]} = $tuple->[1];
+ $CPAN::Frontend->mywarn($@."setting to default '$tuple->[1]'\n");
+ }
+ }
+ }
+ }
+ }
+
+ #
+ #== term_is_latin
+ #
+
+ my_yn_prompt(term_is_latin => 1, $matcher);
+
+ #
+ #== save history in file 'histfile'
+ #
+
+ if (!$matcher or 'histfile histsize' =~ /$matcher/) {
+ $CPAN::Frontend->myprint($prompts{histfile_intro}) unless $auto_config;
+ defined($default = $CPAN::Config->{histfile}) or
+ $default = File::Spec->catfile($CPAN::Config->{cpan_home},"histfile");
+ my_dflt_prompt(histfile => $default, $matcher);
+
+ if ($CPAN::Config->{histfile}) {
+ defined($default = $CPAN::Config->{histsize}) or $default = 100;
+ my_dflt_prompt(histsize => $default, $matcher);
+ }
+ }
+
+ #
+ #== do an ls on the m or the d command
+ #
+ my_yn_prompt(show_upload_date => 0, $matcher);
+
+ #
+ #== verbosity at the end of the r command
+ #
+ if (!$matcher
+ or 'show_unparsable_versions' =~ /$matcher/
+ or 'show_zero_versions' =~ /$matcher/
+ ) {
+ my_yn_prompt(show_unparsable_versions => 0, $matcher);
+ my_yn_prompt(show_zero_versions => 0, $matcher);
+ }
+
+ #
+ #= MIRRORED.BY and conf_sites()
+ #
+
+ # Let's assume they want to use the internet and make them turn it
+ # off if they really don't.
+ my_yn_prompt("connect_to_internet_ok" => 1, $matcher);
+
+ # Allow matching but don't show during manual config
+ if ($matcher) {
+ if ("randomize_urllist" =~ $matcher) {
+ my_dflt_prompt(randomize_urllist => 0, $matcher);
+ }
+ if ("ftpstats_size" =~ $matcher) {
+ my_dflt_prompt(ftpstats_size => 99, $matcher);
+ }
+ if ("ftpstats_period" =~ $matcher) {
+ my_dflt_prompt(ftpstats_period => 14, $matcher);
+ }
+ }
+
+ $CPAN::Config->{urllist} ||= [];
+
+ if ($auto_config) {
+ if(@{ $CPAN::Config->{urllist} }) {
+ $CPAN::Frontend->myprint(
+ "Your 'urllist' is already configured. Type 'o conf init urllist' to change it.\n"
+ );
+ }
+ else {
+ $CPAN::Config->{urllist} = [ 'http://www.cpan.org/' ];
+ }
+ }
+ elsif (!$matcher || "urllist" =~ $matcher) {
+ _do_pick_mirrors();
+ }
+
+ if ($auto_config) {
+ $CPAN::Frontend->myprint(
+ "\nAutoconfiguration complete.\n"
+ );
+ $auto_config = 0; # reset
+ }
+
+ # bootstrap local::lib now if requested
+ if ( $CPAN::Config->{install_help} eq 'local::lib' ) {
+ if ( ! @{ $CPAN::Config->{urllist} } ) {
+ $CPAN::Frontend->myprint(
+ "Skipping local::lib bootstrap because 'urllist' is not configured.\n"
+ );
+ }
+ else {
+ $CPAN::Frontend->myprint("\nAttempting to bootstrap local::lib...\n");
+ $CPAN::Frontend->myprint("\nWriting $configpm for bootstrap...\n");
+ delete $CPAN::Config->{install_help}; # temporary only
+ CPAN::HandleConfig->commit;
+ my($dist, $locallib);
+ $locallib = CPAN::Shell->expand('Module', 'local::lib');
+ if ( $locallib and $dist = $locallib->distribution ) {
+ # this is a hack to force bootstrapping
+ $dist->{prefs}{pl}{commandline} = "$^X Makefile.PL --bootstrap";
+ # Set @INC for this process so we find things as they bootstrap
+ require lib;
+ lib->import(_local_lib_inc_path());
+ eval { $dist->install };
+ }
+ if ( ! $dist || (my $err = $@) ) {
+ $err ||= 'Could not locate local::lib in the CPAN index';
+ $CPAN::Frontend->mywarn("Error bootstrapping local::lib: $@\n");
+ $CPAN::Frontend->myprint("From the CPAN Shell, you might try 'look local::lib' and \n"
+ . "run 'perl Makefile --bootstrap' and see if that is successful. Then\n"
+ . "restart your CPAN client\n"
+ );
+ }
+ else {
+ _local_lib_config();
+ }
+ }
+ }
+
+ # install_help is temporary for configuration and not saved
+ delete $CPAN::Config->{install_help};
+
+ $CPAN::Frontend->myprint("\n");
+ if ($matcher && !$CPAN::Config->{auto_commit}) {
+ $CPAN::Frontend->myprint("Please remember to call 'o conf commit' to ".
+ "make the config permanent!\n");
+ } else {
+ CPAN::HandleConfig->commit;
+ }
+
+ if (! $matcher) {
+ $CPAN::Frontend->myprint(
+ "\nYou can re-run configuration any time with 'o conf init' in the CPAN shell\n"
+ );
+ }
+
+}
+
+sub _local_lib_config {
+ # Set environment stuff for this process
+ require local::lib;
+
+ # Tell user about environment vars to set
+ $CPAN::Frontend->myprint($prompts{local_lib_installed});
+ local $ENV{SHELL} = $CPAN::Config->{shell} || $ENV{SHELL};
+ my $shellvars = local::lib->environment_vars_string_for(_local_lib_path());
+ $CPAN::Frontend->myprint($shellvars);
+
+ # Set %ENV after getting string above
+ my %env = local::lib->build_environment_vars_for(_local_lib_path(), 1);
+ while ( my ($k, $v) = each %env ) {
+ $ENV{$k} = $v;
+ }
+
+ # Offer to mangle the shell config
+ my $munged_rc;
+ if ( my $rc = _find_shell_config() ) {
+ local $auto_config = 0; # We *must* ask, even under autoconfig
+ local *_real_prompt; # We *must* show prompt
+ my $_conf = prompt(
+ "\nWould you like me to append that to $rc now?", "yes"
+ );
+ if ($_conf =~ /^y/i) {
+ open my $fh, ">>", $rc;
+ print {$fh} "\n$shellvars";
+ close $fh;
+ $munged_rc++;
+ }
+ }
+
+ # Warn at exit time
+ if ($munged_rc) {
+ push @{$CPAN::META->_exit_messages}, << "HERE";
+
+*** Remember to restart your shell before running cpan again ***
+HERE
+ }
+ else {
+ push @{$CPAN::META->_exit_messages}, << "HERE";
+
+*** Remember to add these environment variables to your shell config
+ and restart your shell before running cpan again ***
+
+$shellvars
+HERE
+ }
+}
+
+{
+ my %shell_rc_map = (
+ map { $_ => ".${_}rc" } qw/ bash tcsh csh /,
+ map { $_ => ".profile" } qw/dash ash sh/,
+ zsh => ".zshenv",
+ );
+
+ sub _find_shell_config {
+ my $shell = File::Basename::basename($CPAN::Config->{shell});
+ if ( my $rc = $shell_rc_map{$shell} ) {
+ my $path = File::Spec->catfile($ENV{HOME}, $rc);
+ return $path if -w $path;
+ }
+ }
+}
+
+
+sub _local_lib_inc_path {
+ return File::Spec->catdir(_local_lib_path(), qw/lib perl5/);
+}
+
+sub _local_lib_path {
+ return File::Spec->catdir(_local_lib_home(), 'perl5');
+}
+
+# Adapted from resolve_home_path() in local::lib -- this is where
+# local::lib thinks the user's home is
+{
+ my $local_lib_home;
+ sub _local_lib_home {
+ $local_lib_home ||= File::Spec->rel2abs( do {
+ if ($CPAN::META->has_usable("File::HomeDir") && File::HomeDir->VERSION >= 0.65) {
+ File::HomeDir->my_home;
+ } elsif (defined $ENV{HOME}) {
+ $ENV{HOME};
+ } else {
+ (getpwuid $<)[7] || "~";
+ }
+ });
+ }
+}
+
+sub _do_pick_mirrors {
+ local *_real_prompt;
+ *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt;
+ $CPAN::Frontend->myprint($prompts{urls_intro});
+ # Only prompt for auto-pick if Net::Ping is new enough to do timings
+ my $_conf = 'n';
+ if ( $CPAN::META->has_usable("Net::Ping") && Net::Ping->VERSION gt '2.13') {
+ $_conf = prompt($prompts{auto_pick}, "yes");
+ } else {
+ prompt("Autoselection disabled due to Net::Ping missing or insufficient. Please press ENTER");
+ }
+ my @old_list = @{ $CPAN::Config->{urllist} };
+ if ( $_conf =~ /^y/i ) {
+ conf_sites( auto_pick => 1 ) or bring_your_own();
+ }
+ else {
+ _print_urllist('Current') if @old_list;
+ my $msg = scalar @old_list
+ ? "\nWould you like to edit the urllist or pick new mirrors from a list?"
+ : "\nWould you like to pick from the CPAN mirror list?" ;
+ my $_conf = prompt($msg, "yes");
+ if ( $_conf =~ /^y/i ) {
+ conf_sites();
+ }
+ bring_your_own();
+ }
+ _print_urllist('New');
+}
+
+sub _init_external_progs {
+ my($matcher,$args) = @_;
+ my $PATH = $args->{path};
+ my @external_progs = @{ $args->{progs} };
+ my $shortcut = $args->{shortcut};
+ my $showed_make_warning;
+
+ if (!$matcher or "@external_progs" =~ /$matcher/) {
+ my $old_warn = $^W;
+ local $^W if $^O eq 'MacOS';
+ local $^W = $old_warn;
+ my $progname;
+ for $progname (@external_progs) {
+ next if $matcher && $progname !~ /$matcher/;
+ if ($^O eq 'MacOS') {
+ $CPAN::Config->{$progname} = 'not_here';
+ next;
+ }
+
+ my $progcall = $progname;
+ unless ($matcher) {
+ # we really don't need ncftp if we have ncftpget, but
+ # if they chose this dialog via matcher, they shall have it
+ next if $progname eq "ncftp" && $CPAN::Config->{ncftpget} gt " ";
+ }
+ my $path = $CPAN::Config->{$progname}
+ || $Config::Config{$progname}
+ || "";
+ if (File::Spec->file_name_is_absolute($path)) {
+ # testing existence is not good enough, some have these exe
+ # extensions
+
+ # warn "Warning: configured $path does not exist\n" unless -e $path;
+ # $path = "";
+ } elsif ($path =~ /^\s+$/) {
+ # preserve disabled programs
+ } else {
+ $path = '';
+ }
+ unless ($path) {
+ # e.g. make -> nmake
+ $progcall = $Config::Config{$progname} if $Config::Config{$progname};
+ }
+
+ $path ||= find_exe($progcall,$PATH);
+ unless ($path) { # not -e $path, because find_exe already checked that
+ local $"=";";
+ $CPAN::Frontend->mywarn("Warning: $progcall not found in PATH[@$PATH]\n") unless $auto_config;
+ _beg_for_make(), $showed_make_warning++ if $progname eq "make";
+ }
+ $prompts{$progname} = "Where is your $progname program?";
+ $path = my_dflt_prompt($progname,$path,$matcher,1); # 1 => no strip spaces
+ my $disabling = $path =~ m/^\s*$/;
+
+ # don't let them disable or misconfigure make without warning
+ if ( $progname eq "make" && ( $disabling || ! _check_found($path) ) ) {
+ if ( $disabling && $showed_make_warning ) {
+ next;
+ }
+ else {
+ _beg_for_make() unless $showed_make_warning++;
+ undef $CPAN::Config->{$progname};
+ $CPAN::Frontend->mywarn("Press SPACE and ENTER to disable make (NOT RECOMMENDED)\n");
+ redo;
+ }
+ }
+ elsif ( $disabling ) {
+ next;
+ }
+ elsif ( _check_found( $CPAN::Config->{$progname} ) ) {
+ last if $shortcut && !$matcher;
+ }
+ else {
+ undef $CPAN::Config->{$progname};
+ $CPAN::Frontend->mywarn("Press SPACE and ENTER to disable $progname\n");
+ redo;
+ }
+ }
+ }
+}
+
+sub _check_found {
+ my ($prog) = @_;
+ if ( ! -f $prog ) {
+ $CPAN::Frontend->mywarn("Warning: '$prog' does not exist\n")
+ unless $auto_config;
+ return;
+ }
+ elsif ( ! -x $prog ) {
+ $CPAN::Frontend->mywarn("Warning: '$prog' is not executable\n")
+ unless $auto_config;
+ return;
+ }
+ return 1;
+}
+
+sub _beg_for_make {
+ $CPAN::Frontend->mywarn(<<"HERE");
+
+ALERT: 'make' is an essential tool for building perl Modules.
+Please make sure you have 'make' (or some equivalent) working.
+
+HERE
+ if ($^O eq "MSWin32") {
+ $CPAN::Frontend->mywarn(<<"HERE");
+Windows users may want to follow this procedure when back in the CPAN shell:
+
+ look YVES/scripts/alien_nmake.pl
+ perl alien_nmake.pl
+
+This will install nmake on your system which can be used as a 'make'
+substitute. You can then revisit this dialog with
+
+ o conf init make
+
+HERE
+ }
+}
+
+sub init_cpan_home {
+ my($matcher) = @_;
+ if (!$matcher or 'cpan_home' =~ /$matcher/) {
+ my $cpan_home =
+ $CPAN::Config->{cpan_home} || CPAN::HandleConfig::cpan_home();
+ if (-d $cpan_home) {
+ $CPAN::Frontend->myprint(
+ "\nI see you already have a directory\n" .
+ "\n$cpan_home\n" .
+ "Shall we use it as the general CPAN build and cache directory?\n\n"
+ ) unless $auto_config;
+ } else {
+ # no cpan-home, must prompt and get one
+ $CPAN::Frontend->myprint($prompts{cpan_home_where}) unless $auto_config;
+ }
+
+ my $default = $cpan_home;
+ my $loop = 0;
+ my($last_ans,$ans);
+ $CPAN::Frontend->myprint(" <cpan_home>\n") unless $auto_config;
+ PROMPT: while ($ans = prompt("CPAN build and cache directory?",$default)) {
+ if (File::Spec->file_name_is_absolute($ans)) {
+ my @cpan_home = split /[\/\\]/, $ans;
+ DIR: for my $dir (@cpan_home) {
+ if ($dir =~ /^~/ and (!$last_ans or $ans ne $last_ans)) {
+ $CPAN::Frontend
+ ->mywarn("Warning: a tilde in the path will be ".
+ "taken as a literal tilde. Please ".
+ "confirm again if you want to keep it\n");
+ $last_ans = $default = $ans;
+ next PROMPT;
+ }
+ }
+ } else {
+ require Cwd;
+ my $cwd = Cwd::cwd();
+ my $absans = File::Spec->catdir($cwd,$ans);
+ $CPAN::Frontend->mywarn("The path '$ans' is not an ".
+ "absolute path. Please specify ".
+ "an absolute path\n");
+ $default = $absans;
+ next PROMPT;
+ }
+ eval { File::Path::mkpath($ans); }; # dies if it can't
+ if ($@) {
+ $CPAN::Frontend->mywarn("Couldn't create directory $ans.\n".
+ "Please retry.\n");
+ next PROMPT;
+ }
+ if (-d $ans && -w _) {
+ last PROMPT;
+ } else {
+ $CPAN::Frontend->mywarn("Couldn't find directory $ans\n".
+ "or directory is not writable. Please retry.\n");
+ if (++$loop > 5) {
+ $CPAN::Frontend->mydie("Giving up");
+ }
+ }
+ }
+ $CPAN::Config->{cpan_home} = $ans;
+ }
+}
+
+sub my_dflt_prompt {
+ my ($item, $dflt, $m, $no_strip) = @_;
+ my $default = $CPAN::Config->{$item} || $dflt;
+
+ if (!$auto_config && (!$m || $item =~ /$m/)) {
+ if (my $intro = $prompts{$item . "_intro"}) {
+ $CPAN::Frontend->myprint($intro);
+ }
+ $CPAN::Frontend->myprint(" <$item>\n");
+ $CPAN::Config->{$item} =
+ $no_strip ? prompt_no_strip($prompts{$item}, $default)
+ : prompt( $prompts{$item}, $default);
+ } else {
+ $CPAN::Config->{$item} = $default;
+ }
+ return $CPAN::Config->{$item};
+}
+
+sub my_yn_prompt {
+ my ($item, $dflt, $m) = @_;
+ my $default;
+ defined($default = $CPAN::Config->{$item}) or $default = $dflt;
+
+ # $DB::single = 1;
+ if (!$auto_config && (!$m || $item =~ /$m/)) {
+ if (my $intro = $prompts{$item . "_intro"}) {
+ $CPAN::Frontend->myprint($intro);
+ }
+ $CPAN::Frontend->myprint(" <$item>\n");
+ my $ans = prompt($prompts{$item}, $default ? 'yes' : 'no');
+ $CPAN::Config->{$item} = ($ans =~ /^[y1]/i ? 1 : 0);
+ } else {
+ $CPAN::Config->{$item} = $default;
+ }
+}
+
+sub my_prompt_loop {
+ my ($item, $dflt, $m, $ok) = @_;
+ my $default = $CPAN::Config->{$item} || $dflt;
+ my $ans;
+
+ if (!$auto_config && (!$m || $item =~ /$m/)) {
+ $CPAN::Frontend->myprint($prompts{$item . "_intro"});
+ $CPAN::Frontend->myprint(" <$item>\n");
+ do { $ans = prompt($prompts{$item}, $default);
+ } until $ans =~ /$ok/;
+ $CPAN::Config->{$item} = $ans;
+ } else {
+ $CPAN::Config->{$item} = $default;
+ }
+}
+
+
+# Here's the logic about the MIRRORED.BY file. There are a number of scenarios:
+# (1) We have a cached MIRRORED.BY file
+# (1a) We're auto-picking
+# - Refresh it automatically if it's old
+# (1b) Otherwise, ask if using cached is ok. If old, default to no.
+# - If cached is not ok, get it from the Internet. If it succeeds we use
+# the new file. Otherwise, we use the old file.
+# (2) We don't have a copy at all
+# (2a) If we are allowed to connect, we try to get a new copy. If it succeeds,
+# we use it, otherwise, we warn about failure
+# (2b) If we aren't allowed to connect,
+
+sub conf_sites {
+ my %args = @_;
+ # auto pick implies using the internet
+ $CPAN::Config->{connect_to_internet_ok} = 1 if $args{auto_pick};
+
+ my $m = 'MIRRORED.BY';
+ my $mby = File::Spec->catfile($CPAN::Config->{keep_source_where},$m);
+ File::Path::mkpath(File::Basename::dirname($mby));
+ # Why are we using MIRRORED.BY from the current directory?
+ # Is this for testing? -- dagolden, 2009-11-05
+ if (-f $mby && -f $m && -M $m < -M $mby) {
+ require File::Copy;
+ File::Copy::copy($m,$mby) or die "Could not update $mby: $!";
+ }
+ local $^T = time;
+ # if we have a cached copy is not older than 60 days, we either
+ # use it or refresh it or fall back to it if the refresh failed.
+ if ($mby && -f $mby && -s _ > 0 ) {
+ my $very_old = (-M $mby > 60);
+ my $mtime = localtime((stat _)[9]);
+ # if auto_pick, refresh anything old automatically
+ if ( $args{auto_pick} ) {
+ if ( $very_old ) {
+ $CPAN::Frontend->myprint(qq{Trying to refresh your mirror list\n});
+ eval { CPAN::FTP->localize($m,$mby,3,1) }
+ or $CPAN::Frontend->myprint(qq{Refresh failed. Using the old cached copy instead.\n});
+ $CPAN::Frontend->myprint("\n");
+ }
+ }
+ else {
+ my $prompt = qq{Found a cached mirror list as of $mtime
+
+If you'd like to just use the cached copy, answer 'yes', below.
+If you'd like an updated copy of the mirror list, answer 'no' and
+I'll get a fresh one from the Internet.
+
+Shall I use the cached mirror list?};
+ my $ans = prompt($prompt, $very_old ? "no" : "yes");
+ if ($ans =~ /^n/i) {
+ $CPAN::Frontend->myprint(qq{Trying to refresh your mirror list\n});
+ # you asked for it from the Internet
+ $CPAN::Config->{connect_to_internet_ok} = 1;
+ eval { CPAN::FTP->localize($m,$mby,3,1) }
+ or $CPAN::Frontend->myprint(qq{Refresh failed. Using the old cached copy instead.\n});
+ $CPAN::Frontend->myprint("\n");
+ }
+ }
+ }
+ # else there is no cached copy and we must fetch or fail
+ else {
+ # If they haven't agree to connect to the internet, ask again
+ if ( ! $CPAN::Config->{connect_to_internet_ok} ) {
+ my $prompt = q{You are missing a copy of the CPAN mirror list.
+
+May I connect to the Internet to get it?};
+ my $ans = prompt($prompt, "yes");
+ if ($ans =~ /^y/i) {
+ $CPAN::Config->{connect_to_internet_ok} = 1;
+ }
+ }
+
+ # Now get it from the Internet or complain
+ if ( $CPAN::Config->{connect_to_internet_ok} ) {
+ $CPAN::Frontend->myprint(qq{Trying to fetch a mirror list from the Internet\n});
+ eval { CPAN::FTP->localize($m,$mby,3,1) }
+ or $CPAN::Frontend->mywarn(<<'HERE');
+We failed to get a copy of the mirror list from the Internet.
+You will need to provide CPAN mirror URLs yourself.
+HERE
+ $CPAN::Frontend->myprint("\n");
+ }
+ else {
+ $CPAN::Frontend->mywarn(<<'HERE');
+You will need to provide CPAN mirror URLs yourself or set
+'o conf connect_to_internet_ok 1' and try again.
+HERE
+ }
+ }
+
+ # if we finally have a good local MIRRORED.BY, get on with picking
+ if (-f $mby && -s _ > 0){
+ $CPAN::Config->{urllist} =
+ $args{auto_pick} ? auto_mirrored_by($mby) : choose_mirrored_by($mby);
+ return 1;
+ }
+
+ return;
+}
+
+sub find_exe {
+ my($exe,$path) = @_;
+ $path ||= [split /$Config{'path_sep'}/, $ENV{'PATH'}];
+ my($dir);
+ #warn "in find_exe exe[$exe] path[@$path]";
+ for $dir (@$path) {
+ my $abs = File::Spec->catfile($dir,$exe);
+ if (($abs = MM->maybe_command($abs))) {
+ return $abs;
+ }
+ }
+}
+
+sub picklist {
+ my($items,$prompt,$default,$require_nonempty,$empty_warning)=@_;
+ CPAN->debug("picklist('$items','$prompt','$default','$require_nonempty',".
+ "'$empty_warning')") if $CPAN::DEBUG;
+ $default ||= '';
+
+ my $pos = 0;
+
+ my @nums;
+ SELECTION: while (1) {
+
+ # display, at most, 15 items at a time
+ my $limit = $#{ $items } - $pos;
+ $limit = 15 if $limit > 15;
+
+ # show the next $limit items, get the new position
+ $pos = display_some($items, $limit, $pos, $default);
+ $pos = 0 if $pos >= @$items;
+
+ my $num = prompt($prompt,$default);
+
+ @nums = split (' ', $num);
+ {
+ my %seen;
+ @nums = grep { !$seen{$_}++ } @nums;
+ }
+ my $i = scalar @$items;
+ unrangify(\@nums);
+ if (0 == @nums) {
+ # cannot allow nothing because nothing means paging!
+ # return;
+ } elsif (grep (/\D/ || $_ < 1 || $_ > $i, @nums)) {
+ $CPAN::Frontend->mywarn("invalid items entered, try again\n");
+ if ("@nums" =~ /\D/) {
+ $CPAN::Frontend->mywarn("(we are expecting only numbers between 1 and $i)\n");
+ }
+ next SELECTION;
+ }
+ if ($require_nonempty && !@nums) {
+ $CPAN::Frontend->mywarn("$empty_warning\n");
+ }
+
+ # a blank line continues...
+ unless (@nums){
+ $CPAN::Frontend->mysleep(0.1); # prevent hot spinning process on the next bug
+ next SELECTION;
+ }
+ last;
+ }
+ for (@nums) { $_-- }
+ @{$items}[@nums];
+}
+
+sub unrangify ($) {
+ my($nums) = $_[0];
+ my @nums2 = ();
+ while (@{$nums||[]}) {
+ my $n = shift @$nums;
+ if ($n =~ /^(\d+)-(\d+)$/) {
+ my @range = $1 .. $2;
+ # warn "range[@range]";
+ push @nums2, @range;
+ } else {
+ push @nums2, $n;
+ }
+ }
+ push @$nums, @nums2;
+}
+
+sub display_some {
+ my ($items, $limit, $pos, $default) = @_;
+ $pos ||= 0;
+
+ my @displayable = @$items[$pos .. ($pos + $limit)];
+ for my $item (@displayable) {
+ $CPAN::Frontend->myprint(sprintf "(%d) %s\n", ++$pos, $item);
+ }
+ my $hit_what = $default ? "SPACE ENTER" : "ENTER";
+ $CPAN::Frontend->myprint(sprintf("%d more items, hit %s to show them\n",
+ (@$items - $pos),
+ $hit_what,
+ ))
+ if $pos < @$items;
+ return $pos;
+}
+
+sub auto_mirrored_by {
+ my $local = shift or return;
+ local $|=1;
+ $CPAN::Frontend->myprint("Looking for CPAN mirrors near you (please be patient)\n");
+ my $mirrors = CPAN::Mirrors->new($local);
+
+ my $cnt = 0;
+ my @best = $mirrors->best_mirrors(
+ how_many => 3,
+ callback => sub {
+ $CPAN::Frontend->myprint(".");
+ if ($cnt++>60) { $cnt=0; $CPAN::Frontend->myprint("\n"); }
+ },
+ );
+
+ my $urllist = [ map { $_->http } @best ];
+ push @$urllist, grep { /^file:/ } @{$CPAN::Config->{urllist}};
+ $CPAN::Frontend->myprint(" done!\n\n");
+
+ return $urllist
+}
+
+sub choose_mirrored_by {
+ my $local = shift or return;
+ my ($default);
+ my $mirrors = CPAN::Mirrors->new($local);
+ my @previous_urls = @{$CPAN::Config->{urllist}};
+
+ $CPAN::Frontend->myprint($prompts{urls_picker_intro});
+
+ my (@cont, $cont, %cont, @countries, @urls, %seen);
+ my $no_previous_warn =
+ "Sorry! since you don't have any existing picks, you must make a\n" .
+ "geographic selection.";
+ my $offer_cont = [sort $mirrors->continents];
+ if (@previous_urls) {
+ push @$offer_cont, "(edit previous picks)";
+ $default = @$offer_cont;
+ } else {
+ # cannot allow nothing because nothing means paging!
+ # push @$offer_cont, "(none of the above)";
+ }
+ @cont = picklist($offer_cont,
+ "Select your continent (or several nearby continents)",
+ $default,
+ ! @previous_urls,
+ $no_previous_warn);
+ # cannot allow nothing because nothing means paging!
+ # return unless @cont;
+
+ foreach $cont (@cont) {
+ my @c = sort $mirrors->countries($cont);
+ @cont{@c} = map ($cont, 0..$#c);
+ @c = map ("$_ ($cont)", @c) if @cont > 1;
+ push (@countries, @c);
+ }
+ if (@previous_urls && @countries) {
+ push @countries, "(edit previous picks)";
+ $default = @countries;
+ }
+
+ if (@countries) {
+ @countries = picklist (\@countries,
+ "Select your country (or several nearby countries)",
+ $default,
+ ! @previous_urls,
+ $no_previous_warn);
+ %seen = map (($_ => 1), @previous_urls);
+ # hmmm, should take list of defaults from CPAN::Config->{'urllist'}...
+ foreach my $country (@countries) {
+ next if $country =~ /edit previous picks/;
+ (my $bare_country = $country) =~ s/ \(.*\)//;
+ my @u;
+ for my $m ( $mirrors->mirrors($bare_country) ) {
+ push @u, $m->ftp if $m->ftp;
+ push @u, $m->http if $m->http;
+ }
+ @u = grep (! $seen{$_}, @u);
+ @u = map ("$_ ($bare_country)", @u)
+ if @countries > 1;
+ push (@urls, sort @u);
+ }
+ }
+ push (@urls, map ("$_ (previous pick)", @previous_urls));
+ my $prompt = "Select as many URLs as you like (by number),
+put them on one line, separated by blanks, hyphenated ranges allowed
+ e.g. '1 4 5' or '7 1-4 8'";
+ if (@previous_urls) {
+ $default = join (' ', ((scalar @urls) - (scalar @previous_urls) + 1) ..
+ (scalar @urls));
+ $prompt .= "\n(or just hit ENTER to keep your previous picks)";
+ }
+
+ @urls = picklist (\@urls, $prompt, $default);
+ foreach (@urls) { s/ \(.*\)//; }
+ return [ @urls ];
+}
+
+sub bring_your_own {
+ my $urllist = [ @{$CPAN::Config->{urllist}} ];
+ my %seen = map (($_ => 1), @$urllist);
+ my($ans,@urls);
+ my $eacnt = 0; # empty answers
+ $CPAN::Frontend->myprint(<<'HERE');
+Now you can enter your own CPAN URLs by hand. A local CPAN mirror can be
+listed using a 'file:' URL like 'file:///path/to/cpan/'
+
+HERE
+ do {
+ my $prompt = "Enter another URL or ENTER to quit:";
+ unless (%seen) {
+ $prompt = qq{CPAN.pm needs at least one URL where it can fetch CPAN files from.
+
+Please enter your CPAN site:};
+ }
+ $ans = prompt ($prompt, "");
+
+ if ($ans) {
+ $ans =~ s|/?\z|/|; # has to end with one slash
+ # XXX This manipulation is odd. Shouldn't we check that $ans is
+ # a directory before converting to file:///? And we need /// below,
+ # too, don't we? -- dagolden, 2009-11-05
+ $ans = "file:$ans" unless $ans =~ /:/; # without a scheme is a file:
+ if ($ans =~ /^\w+:\/./) {
+ push @urls, $ans unless $seen{$ans}++;
+ } else {
+ $CPAN::Frontend->
+ myprint(sprintf(qq{"%s" doesn\'t look like an URL at first sight.
+I\'ll ignore it for now.
+You can add it to your %s
+later if you\'re sure it\'s right.\n},
+ $ans,
+ $INC{'CPAN/MyConfig.pm'}
+ || $INC{'CPAN/Config.pm'}
+ || "configuration file",
+ ));
+ }
+ } else {
+ if (++$eacnt >= 5) {
+ $CPAN::Frontend->
+ mywarn("Giving up.\n");
+ $CPAN::Frontend->mysleep(5);
+ return;
+ }
+ }
+ } while $ans || !%seen;
+
+ @$urllist = CPAN::_uniq(@$urllist, @urls);
+ $CPAN::Config->{urllist} = $urllist;
+}
+
+sub _print_urllist {
+ my ($which) = @_;
+ $CPAN::Frontend->myprint("$which urllist\n");
+ for ( @{$CPAN::Config->{urllist} || []} ) {
+ $CPAN::Frontend->myprint(" $_\n")
+ };
+}
+
+sub _can_write_to_libdirs {
+ return -w $Config{installprivlib}
+ && -w $Config{installarchlib}
+ && -w $Config{installsitelib}
+ && -w $Config{installsitearch}
+}
+
+sub _using_installbase {
+ return 1 if $ENV{PERL_MM_OPT} && $ENV{PERL_MM_OPT} =~ /install_base/i;
+ return 1 if grep { ($CPAN::Config->{$_}||q{}) =~ /install_base/i }
+ qw(makepl_arg make_install_arg mbuildpl_arg mbuild_install_arg);
+ return;
+}
+
+sub _using_sudo {
+ return 1 if grep { ($CPAN::Config->{$_}||q{}) =~ /sudo/ }
+ qw(make_install_make_command mbuild_install_build_command);
+ return;
+}
+
+sub _strip_spaces {
+ $_[0] =~ s/^\s+//; # no leading spaces
+ $_[0] =~ s/\s+\z//; # no trailing spaces
+}
+
+sub prompt ($;$) {
+ unless (defined &_real_prompt) {
+ *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt;
+ }
+ my $ans = _real_prompt(@_);
+
+ _strip_spaces($ans);
+ $CPAN::Frontend->myprint("\n") unless $auto_config;
+
+ return $ans;
+}
+
+
+sub prompt_no_strip ($;$) {
+ unless (defined &_real_prompt) {
+ *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt;
+ }
+ return _real_prompt(@_);
+}
+
+
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/HTTP/Client.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/HTTP/Client.pm
new file mode 100644
index 0000000000..4fc792c26a
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/HTTP/Client.pm
@@ -0,0 +1,254 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::HTTP::Client;
+use strict;
+use vars qw(@ISA);
+use CPAN::HTTP::Credentials;
+use HTTP::Tiny 0.005;
+
+$CPAN::HTTP::Client::VERSION = $CPAN::HTTP::Client::VERSION = "1.9601";
+
+# CPAN::HTTP::Client is adapted from parts of cpanm by Tatsuhiko Miyagawa
+# and parts of LWP by Gisle Aas
+
+sub new {
+ my $class = shift;
+ my %args = @_;
+ for my $k ( keys %args ) {
+ $args{$k} = '' unless defined $args{$k};
+ }
+ $args{no_proxy} = [split(",", $args{no_proxy}) ] if $args{no_proxy};
+ return bless \%args, $class;
+}
+
+# This executes a request with redirection (up to 5) and returns the
+# response structure generated by HTTP::Tiny
+#
+# If authentication fails, it will attempt to get new authentication
+# information and repeat up to 5 times
+
+sub mirror {
+ my($self, $uri, $path) = @_;
+
+ my $want_proxy = $self->_want_proxy($uri);
+ my $http = HTTP::Tiny->new(
+ $want_proxy ? (proxy => $self->{proxy}) : ()
+ );
+
+ my ($response, %headers);
+ my $retries = 0;
+ while ( $retries++ < 5 ) {
+ $response = $http->mirror( $uri, $path, {headers => \%headers} );
+ if ( $response->{status} eq '401' ) {
+ last unless $self->_get_auth_params( $response, 'non_proxy' );
+ }
+ elsif ( $response->{status} eq '407' ) {
+ last unless $self->_get_auth_params( $response, 'proxy' );
+ }
+ else {
+ last; # either success or failure
+ }
+ my %headers = (
+ $self->_auth_headers( $uri, 'non_proxy' ),
+ ( $want_proxy ? $self->_auth_headers($uri, 'proxy') : () ),
+ );
+ }
+
+ return $response;
+}
+
+sub _want_proxy {
+ my ($self, $uri) = @_;
+ return unless $self->{proxy};
+ my($host) = $uri =~ m|://([^/:]+)|;
+ return ! grep { $host =~ /\Q$_\E$/ } @{ $self->{no_proxy} || [] };
+}
+
+# Generates the authentication headers for a given mode
+# C<mode> is 'proxy' or 'non_proxy'
+# C<_${mode}_type> is 'basic' or 'digest'
+# C<_${mode}_params> will be the challenge parameters from the 401/407 headers
+sub _auth_headers {
+ my ($self, $uri, $mode) = @_;
+ # Get names for our mode-specific attributes
+ my ($type_key, $param_key) = map {"_" . $mode . $_} qw/_type _params/;
+
+ # If _prepare_auth has not been called, we can't prepare headers
+ return unless $self->{$type_key};
+
+ # Get user credentials for mode
+ my $cred_method = "get_" . ($mode ? "proxy" : "non_proxy") ."_credentials";
+ my ($user, $pass) = CPAN::HTTP::Credentials->$cred_method;
+
+ # Generate the header for the mode & type
+ my $header = $mode eq 'proxy' ? 'Proxy-Authorization' : 'Authorization';
+ my $value_method = "_" . $self->{$type_key} . "_auth";
+ my $value = $self->$value_method($user, $pass, $self->{$param_key}, $uri);
+
+ # If we didn't get a value, we didn't have the right modules available
+ return $value ? ( $header, $value ) : ();
+}
+
+# Extract authentication parameters from headers, but clear any prior
+# credentials if we failed (so we might prompt user for password again)
+sub _get_auth_params {
+ my ($self, $response, $mode) = @_;
+ my $prefix = $mode eq 'proxy' ? 'Proxy' : 'WWW';
+ my ($type_key, $param_key) = map {"_" . $mode . $_} qw/_type _params/;
+ if ( ! $response->{success} ) { # auth failed
+ my $method = "clear_${mode}_credentials";
+ CPAN::HTTP::Credentials->$method;
+ delete $self->{$_} for $type_key, $param_key;
+ }
+ ($self->{$type_key}, $self->{$param_key}) =
+ $self->_get_challenge( $response, "${prefix}-Authenticate");
+ return $self->{$type_key};
+}
+
+# Extract challenge type and parameters for a challenge list
+sub _get_challenge {
+ my ($self, $response, $auth_header) = @_;
+
+ my $auth_list = $response->{headers}(lc $auth_header);
+ return unless defined $auth_list;
+ $auth_list = [$auth_list] unless ref $auth_list;
+
+ for my $challenge (@$auth_list) {
+ $challenge =~ tr/,/;/; # "," is used to separate auth-params!!
+ ($challenge) = $self->split_header_words($challenge);
+ my $scheme = shift(@$challenge);
+ shift(@$challenge); # no value
+ $challenge = { @$challenge }; # make rest into a hash
+
+ unless ($scheme =~ /^(basic|digest)$/) {
+ next; # bad scheme
+ }
+ $scheme = $1; # untainted now
+
+ return ($scheme, $challenge);
+ }
+ return;
+}
+
+# Generate a basic authentication header value
+sub _basic_auth {
+ my ($self, $user, $pass) = @_;
+ unless ( $CPAN::META->has_usable('MIME::Base64') ) {
+ $CPAN::Frontend->mywarn(
+ "MIME::Base64 is required for 'Basic' style authentication"
+ );
+ return;
+ }
+ return "Basic " . MIME::Base64::encode_base64("$user\:$pass", q{});
+}
+
+# Generate a digest authentication header value
+sub _digest_auth {
+ my ($self, $user, $pass, $auth_param, $uri) = @_;
+ unless ( $CPAN::META->has_usable('Digest::MD5') ) {
+ $CPAN::Frontend->mywarn(
+ "Digest::MD5 is required for 'Digest' style authentication"
+ );
+ return;
+ }
+
+ my $nc = sprintf "%08X", ++$self->{_nonce_count}{$auth_param->{nonce}};
+ my $cnonce = sprintf "%8x", time;
+
+ my ($path) = $uri =~ m{^\w+?://[^/]+(/.*)$};
+ $path = "/" unless defined $path;
+
+ my $md5 = Digest::MD5->new;
+
+ my(@digest);
+ $md5->add(join(":", $user, $auth_param->{realm}, $pass));
+ push(@digest, $md5->hexdigest);
+ $md5->reset;
+
+ push(@digest, $auth_param->{nonce});
+
+ if ($auth_param->{qop}) {
+ push(@digest, $nc, $cnonce, ($auth_param->{qop} =~ m|^auth[,;]auth-int$|) ? 'auth' : $auth_param->{qop});
+ }
+
+ $md5->add(join(":", 'GET', $path));
+ push(@digest, $md5->hexdigest);
+ $md5->reset;
+
+ $md5->add(join(":", @digest));
+ my($digest) = $md5->hexdigest;
+ $md5->reset;
+
+ my %resp = map { $_ => $auth_param->{$_} } qw(realm nonce opaque);
+ @resp{qw(username uri response algorithm)} = ($user, $path, $digest, "MD5");
+
+ if (($auth_param->{qop} || "") =~ m|^auth([,;]auth-int)?$|) {
+ @resp{qw(qop cnonce nc)} = ("auth", $cnonce, $nc);
+ }
+
+ my(@order) =
+ qw(username realm qop algorithm uri nonce nc cnonce response opaque);
+ my @pairs;
+ for (@order) {
+ next unless defined $resp{$_};
+ push(@pairs, "$_=" . qq("$resp{$_}"));
+ }
+
+ my $auth_value = "Digest " . join(", ", @pairs);
+ return $auth_value;
+}
+
+# split_header_words adapted from HTTP::Headers::Util
+sub split_header_words {
+ my ($self, @words) = @_;
+ my @res = $self->_split_header_words(@words);
+ for my $arr (@res) {
+ for (my $i = @$arr - 2; $i >= 0; $i -= 2) {
+ $arr->[$i] = lc($arr->[$i]);
+ }
+ }
+ return @res;
+}
+
+sub _split_header_words {
+ my($self, @val) = @_;
+ my @res;
+ for (@val) {
+ my @cur;
+ while (length) {
+ if (s/^\s*(=*[^\s=;,]+)//) { # 'token' or parameter 'attribute'
+ push(@cur, $1);
+ # a quoted value
+ if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) {
+ my $val = $1;
+ $val =~ s/\\(.)/$1/g;
+ push(@cur, $val);
+ # some unquoted value
+ }
+ elsif (s/^\s*=\s*([^;,\s]*)//) {
+ my $val = $1;
+ $val =~ s/\s+$//;
+ push(@cur, $val);
+ # no value, a lone token
+ }
+ else {
+ push(@cur, undef);
+ }
+ }
+ elsif (s/^\s*,//) {
+ push(@res, [@cur]) if @cur;
+ @cur = ();
+ }
+ elsif (s/^\s*;// || s/^\s+//) {
+ # continue
+ }
+ else {
+ die "This should not happen: '$_'";
+ }
+ }
+ push(@res, \@cur) if @cur;
+ }
+ @res;
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/HTTP/Credentials.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/HTTP/Credentials.pm
new file mode 100644
index 0000000000..96a9880092
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/HTTP/Credentials.pm
@@ -0,0 +1,91 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::HTTP::Credentials;
+use strict;
+use vars qw($USER $PASSWORD $PROXY_USER $PROXY_PASSWORD);
+
+$CPAN::HTTP::Credentials::VERSION = $CPAN::HTTP::Credentials::VERSION = "1.9601";
+
+sub clear_credentials {
+ clear_non_proxy_credentials();
+ clear_proxy_credentials();
+}
+
+sub clear_non_proxy_credentials {
+ undef $USER;
+ undef $PASSWORD;
+}
+
+sub clear_proxy_credentials {
+ undef $PROXY_USER;
+ undef $PROXY_PASSWORD;
+}
+
+sub get_proxy_credentials {
+ my $self = shift;
+ if ($PROXY_USER && $PROXY_PASSWORD) {
+ return ($PROXY_USER, $PROXY_PASSWORD);
+ }
+ if ( defined $CPAN::Config->{proxy_user}
+ && $CPAN::Config->{proxy_user}
+ ) {
+ $PROXY_USER = $CPAN::Config->{proxy_user};
+ $PROXY_PASSWORD = $CPAN::Config->{proxy_pass} || "";
+ return ($PROXY_USER, $PROXY_PASSWORD);
+ }
+ my $username_prompt = "\nProxy authentication needed!
+ (Note: to permanently configure username and password run
+ o conf proxy_user your_username
+ o conf proxy_pass your_password
+ )\nUsername:";
+ ($PROXY_USER, $PROXY_PASSWORD) =
+ _get_username_and_password_from_user($username_prompt);
+ return ($PROXY_USER,$PROXY_PASSWORD);
+}
+
+sub get_non_proxy_credentials {
+ my $self = shift;
+ if ($USER && $PASSWORD) {
+ return ($USER, $PASSWORD);
+ }
+ if ( defined $CPAN::Config->{username} ) {
+ $USER = $CPAN::Config->{username};
+ $PASSWORD = $CPAN::Config->{password} || "";
+ return ($USER, $PASSWORD);
+ }
+ my $username_prompt = "\nAuthentication needed!
+ (Note: to permanently configure username and password run
+ o conf username your_username
+ o conf password your_password
+ )\nUsername:";
+
+ ($USER, $PASSWORD) =
+ _get_username_and_password_from_user($username_prompt);
+ return ($USER,$PASSWORD);
+}
+
+sub _get_username_and_password_from_user {
+ my $username_message = shift;
+ my ($username,$password);
+
+ ExtUtils::MakeMaker->import(qw(prompt));
+ $username = prompt($username_message);
+ if ($CPAN::META->has_inst("Term::ReadKey")) {
+ Term::ReadKey::ReadMode("noecho");
+ }
+ else {
+ $CPAN::Frontend->mywarn(
+ "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
+ );
+ }
+ $password = prompt("Password:");
+
+ if ($CPAN::META->has_inst("Term::ReadKey")) {
+ Term::ReadKey::ReadMode("restore");
+ }
+ $CPAN::Frontend->myprint("\n\n");
+ return ($username,$password);
+}
+
+1;
+
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/HandleConfig.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/HandleConfig.pm
new file mode 100644
index 0000000000..c72439f92c
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/HandleConfig.pm
@@ -0,0 +1,800 @@
+package CPAN::HandleConfig;
+use strict;
+use vars qw(%can %keys $loading $VERSION);
+use File::Path ();
+use File::Spec ();
+use File::Basename ();
+use Carp ();
+
+=head1 NAME
+
+CPAN::HandleConfig - internal configuration handling for CPAN.pm
+
+=cut
+
+$VERSION = "5.5008"; # see also CPAN::Config::VERSION at end of file
+
+%can = (
+ commit => "Commit changes to disk",
+ defaults => "Reload defaults from disk",
+ help => "Short help about 'o conf' usage",
+ init => "Interactive setting of all options",
+);
+
+# Q: where is the "How do I add a new config option" HOWTO?
+# A1: svn diff -r 757:758 # where dagolden added test_report [git e997b71de88f1019a1472fc13cb97b1b7f96610f]
+# A2: svn diff -r 985:986 # where andk added yaml_module [git 312b6d9b12b1bdec0b6e282d853482145475021f]
+# A3: 1. add new config option to %keys below
+# 2. add a Pod description in CPAN::FirstTime; it should include a
+# prompt line; see others for examples
+# 3. add a "matcher" section in CPAN::FirstTime::init that includes
+# a prompt function; see others for examples
+# 4. add config option to documentation section in CPAN.pm
+
+%keys = map { $_ => undef }
+ (
+ "applypatch",
+ "auto_commit",
+ "build_cache",
+ "build_dir",
+ "build_dir_reuse",
+ "build_requires_install_policy",
+ "bzip2",
+ "cache_metadata",
+ "check_sigs",
+ "cleanup_after_install",
+ "colorize_debug",
+ "colorize_output",
+ "colorize_print",
+ "colorize_warn",
+ "commandnumber_in_prompt",
+ "commands_quote",
+ "connect_to_internet_ok",
+ "cpan_home",
+ "curl",
+ "dontload_hash", # deprecated after 1.83_68 (rev. 581)
+ "dontload_list",
+ "ftp",
+ "ftp_passive",
+ "ftp_proxy",
+ "ftpstats_size",
+ "ftpstats_period",
+ "getcwd",
+ "gpg",
+ "gzip",
+ "halt_on_failure",
+ "histfile",
+ "histsize",
+ "http_proxy",
+ "inactivity_timeout",
+ "index_expire",
+ "inhibit_startup_message",
+ "keep_source_where",
+ "load_module_verbosity",
+ "lynx",
+ "make",
+ "make_arg",
+ "make_install_arg",
+ "make_install_make_command",
+ "makepl_arg",
+ "mbuild_arg",
+ "mbuild_install_arg",
+ "mbuild_install_build_command",
+ "mbuildpl_arg",
+ "ncftp",
+ "ncftpget",
+ "no_proxy",
+ "pager",
+ "password",
+ "patch",
+ "patches_dir",
+ "perl5lib_verbosity",
+ "plugin_list",
+ "prefer_external_tar",
+ "prefer_installer",
+ "prefs_dir",
+ "prerequisites_policy",
+ "proxy_pass",
+ "proxy_user",
+ "randomize_urllist",
+ "recommends_policy",
+ "scan_cache",
+ "shell",
+ "show_unparsable_versions",
+ "show_upload_date",
+ "show_zero_versions",
+ "suggests_policy",
+ "tar",
+ "tar_verbosity",
+ "term_is_latin",
+ "term_ornaments",
+ "test_report",
+ "trust_test_report_history",
+ "unzip",
+ "urllist",
+ "use_prompt_default",
+ "use_sqlite",
+ "username",
+ "version_timeout",
+ "wait_list",
+ "wget",
+ "yaml_load_code",
+ "yaml_module",
+ );
+
+my %prefssupport = map { $_ => 1 }
+ (
+ "build_requires_install_policy",
+ "check_sigs",
+ "make",
+ "make_install_make_command",
+ "prefer_installer",
+ "test_report",
+ );
+
+# returns true on successful action
+sub edit {
+ my($self,@args) = @_;
+ return unless @args;
+ CPAN->debug("self[$self]args[".join(" | ",@args)."]");
+ my($o,$str,$func,$args,$key_exists);
+ $o = shift @args;
+ if($can{$o}) {
+ my $success = $self->$o(args => \@args); # o conf init => sub init => sub load
+ unless ($success) {
+ die "Panic: could not configure CPAN.pm for args [@args]. Giving up.";
+ }
+ } else {
+ CPAN->debug("o[$o]") if $CPAN::DEBUG;
+ unless (exists $keys{$o}) {
+ $CPAN::Frontend->mywarn("Warning: unknown configuration variable '$o'\n");
+ }
+ my $changed;
+
+
+ # one day I used randomize_urllist for a boolean, so we must
+ # list them explicitly --ak
+ if (0) {
+ } elsif ($o =~ /^(wait_list|urllist|dontload_list|plugin_list)$/) {
+
+ #
+ # ARRAYS
+ #
+
+ $func = shift @args;
+ $func ||= "";
+ CPAN->debug("func[$func]args[@args]") if $CPAN::DEBUG;
+ # Let's avoid eval, it's easier to comprehend without.
+ if ($func eq "push") {
+ push @{$CPAN::Config->{$o}}, @args;
+ $changed = 1;
+ } elsif ($func eq "pop") {
+ pop @{$CPAN::Config->{$o}};
+ $changed = 1;
+ } elsif ($func eq "shift") {
+ shift @{$CPAN::Config->{$o}};
+ $changed = 1;
+ } elsif ($func eq "unshift") {
+ unshift @{$CPAN::Config->{$o}}, @args;
+ $changed = 1;
+ } elsif ($func eq "splice") {
+ my $offset = shift @args || 0;
+ my $length = shift @args || 0;
+ splice @{$CPAN::Config->{$o}}, $offset, $length, @args; # may warn
+ $changed = 1;
+ } elsif ($func) {
+ $CPAN::Config->{$o} = [$func, @args];
+ $changed = 1;
+ } else {
+ $self->prettyprint($o);
+ }
+ if ($changed) {
+ if ($o eq "urllist") {
+ # reset the cached values
+ undef $CPAN::FTP::Thesite;
+ undef $CPAN::FTP::Themethod;
+ $CPAN::Index::LAST_TIME = 0;
+ } elsif ($o eq "dontload_list") {
+ # empty it, it will be built up again
+ $CPAN::META->{dontload_hash} = {};
+ }
+ }
+ } elsif ($o =~ /_hash$/) {
+
+ #
+ # HASHES
+ #
+
+ if (@args==1 && $args[0] eq "") {
+ @args = ();
+ } elsif (@args % 2) {
+ push @args, "";
+ }
+ $CPAN::Config->{$o} = { @args };
+ $changed = 1;
+ } else {
+
+ #
+ # SCALARS
+ #
+
+ if (defined $args[0]) {
+ $CPAN::CONFIG_DIRTY = 1;
+ $CPAN::Config->{$o} = $args[0];
+ $changed = 1;
+ }
+ $self->prettyprint($o)
+ if exists $keys{$o} or defined $CPAN::Config->{$o};
+ }
+ if ($changed) {
+ if ($CPAN::Config->{auto_commit}) {
+ $self->commit;
+ } else {
+ $CPAN::CONFIG_DIRTY = 1;
+ $CPAN::Frontend->myprint("Please use 'o conf commit' to ".
+ "make the config permanent!\n\n");
+ }
+ }
+ }
+}
+
+sub prettyprint {
+ my($self,$k) = @_;
+ my $v = $CPAN::Config->{$k};
+ if (ref $v) {
+ my(@report);
+ if (ref $v eq "ARRAY") {
+ @report = map {"\t$_ \[$v->[$_]]\n"} 0..$#$v;
+ } else {
+ @report = map
+ {
+ sprintf "\t%-18s => %s\n",
+ "[$_]",
+ defined $v->{$_} ? "[$v->{$_}]" : "undef"
+ } sort keys %$v;
+ }
+ $CPAN::Frontend->myprint(
+ join(
+ "",
+ sprintf(
+ " %-18s\n",
+ $k
+ ),
+ @report
+ )
+ );
+ } elsif (defined $v) {
+ $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
+ } else {
+ $CPAN::Frontend->myprint(sprintf " %-18s undef\n", $k);
+ }
+}
+
+# generally, this should be called without arguments so that the currently
+# loaded config file is where changes are committed.
+sub commit {
+ my($self,@args) = @_;
+ CPAN->debug("args[@args]") if $CPAN::DEBUG;
+ if ($CPAN::RUN_DEGRADED) {
+ $CPAN::Frontend->mydie(
+ "'o conf commit' disabled in ".
+ "degraded mode. Maybe try\n".
+ " !undef \$CPAN::RUN_DEGRADED\n"
+ );
+ }
+ my ($configpm, $must_reload);
+
+ # XXX does anything do this? can it be simplified? -- dagolden, 2011-01-19
+ if (@args) {
+ if ($args[0] eq "args") {
+ # we have not signed that contract
+ } else {
+ $configpm = $args[0];
+ }
+ }
+
+ # use provided name or the current config or create a new MyConfig
+ $configpm ||= require_myconfig_or_config() || make_new_config();
+
+ # commit to MyConfig if we can't write to Config
+ if ( ! -w $configpm && $configpm =~ m{CPAN/Config\.pm} ) {
+ my $myconfig = _new_config_name();
+ $CPAN::Frontend->mywarn(
+ "Your $configpm file\n".
+ "is not writable. I will attempt to write your configuration to\n" .
+ "$myconfig instead.\n\n"
+ );
+ $configpm = make_new_config();
+ $must_reload++; # so it gets loaded as $INC{'CPAN/MyConfig.pm'}
+ }
+
+ # XXX why not just "-w $configpm"? -- dagolden, 2011-01-19
+ my($mode);
+ if (-f $configpm) {
+ $mode = (stat $configpm)[2];
+ if ($mode && ! -w _) {
+ _die_cant_write_config($configpm);
+ }
+ }
+
+ $self->_write_config_file($configpm);
+ require_myconfig_or_config() if $must_reload;
+
+ #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
+ #chmod $mode, $configpm;
+###why was that so? $self->defaults;
+ $CPAN::Frontend->myprint("commit: wrote '$configpm'\n");
+ $CPAN::CONFIG_DIRTY = 0;
+ 1;
+}
+
+sub _write_config_file {
+ my ($self, $configpm) = @_;
+ my $msg;
+ $msg = <<EOF if $configpm =~ m{CPAN/Config\.pm};
+
+# This is CPAN.pm's systemwide configuration file. This file provides
+# defaults for users, and the values can be changed in a per-user
+# configuration file.
+
+EOF
+ $msg ||= "\n";
+ my($fh) = FileHandle->new;
+ rename $configpm, "$configpm~" if -f $configpm;
+ open $fh, ">$configpm" or
+ $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
+ $fh->print(qq[$msg\$CPAN::Config = \{\n]);
+ foreach (sort keys %$CPAN::Config) {
+ unless (exists $keys{$_}) {
+ # do not drop them: forward compatibility!
+ $CPAN::Frontend->mywarn("Unknown config variable '$_'\n");
+ next;
+ }
+ $fh->print(
+ " '$_' => ",
+ $self->neatvalue($CPAN::Config->{$_}),
+ ",\n"
+ );
+ }
+ $fh->print("};\n1;\n__END__\n");
+ close $fh;
+
+ return;
+}
+
+
+# stolen from MakeMaker; not taking the original because it is buggy;
+# bugreport will have to say: keys of hashes remain unquoted and can
+# produce syntax errors
+sub neatvalue {
+ my($self, $v) = @_;
+ return "undef" unless defined $v;
+ my($t) = ref $v;
+ unless ($t) {
+ $v =~ s/\\/\\\\/g;
+ return "q[$v]";
+ }
+ if ($t eq 'ARRAY') {
+ my(@m, @neat);
+ push @m, "[";
+ foreach my $elem (@$v) {
+ push @neat, "q[$elem]";
+ }
+ push @m, join ", ", @neat;
+ push @m, "]";
+ return join "", @m;
+ }
+ return "$v" unless $t eq 'HASH';
+ my @m;
+ foreach my $key (sort keys %$v) {
+ my $val = $v->{$key};
+ push(@m,"q[$key]=>".$self->neatvalue($val)) ;
+ }
+ return "{ ".join(', ',@m)." }";
+}
+
+sub defaults {
+ my($self) = @_;
+ if ($CPAN::RUN_DEGRADED) {
+ $CPAN::Frontend->mydie(
+ "'o conf defaults' disabled in ".
+ "degraded mode. Maybe try\n".
+ " !undef \$CPAN::RUN_DEGRADED\n"
+ );
+ }
+ my $done;
+ for my $config (qw(CPAN/MyConfig.pm CPAN/Config.pm)) {
+ if ($INC{$config}) {
+ CPAN->debug("INC{'$config'}[$INC{$config}]") if $CPAN::DEBUG;
+ CPAN::Shell->_reload_this($config,{reloforce => 1});
+ $CPAN::Frontend->myprint("'$INC{$config}' reread\n");
+ last;
+ }
+ }
+ $CPAN::CONFIG_DIRTY = 0;
+ 1;
+}
+
+=head2 C<< CLASS->safe_quote ITEM >>
+
+Quotes an item to become safe against spaces
+in shell interpolation. An item is enclosed
+in double quotes if:
+
+ - the item contains spaces in the middle
+ - the item does not start with a quote
+
+This happens to avoid shell interpolation
+problems when whitespace is present in
+directory names.
+
+This method uses C<commands_quote> to determine
+the correct quote. If C<commands_quote> is
+a space, no quoting will take place.
+
+
+if it starts and ends with the same quote character: leave it as it is
+
+if it contains no whitespace: leave it as it is
+
+if it contains whitespace, then
+
+if it contains quotes: better leave it as it is
+
+else: quote it with the correct quote type for the box we're on
+
+=cut
+
+{
+ # Instead of patching the guess, set commands_quote
+ # to the right value
+ my ($quotes,$use_quote)
+ = $^O eq 'MSWin32'
+ ? ('"', '"')
+ : (q{"'}, "'")
+ ;
+
+ sub safe_quote {
+ my ($self, $command) = @_;
+ # Set up quote/default quote
+ my $quote = $CPAN::Config->{commands_quote} || $quotes;
+
+ if ($quote ne ' '
+ and defined($command )
+ and $command =~ /\s/
+ and $command !~ /[$quote]/) {
+ return qq<$use_quote$command$use_quote>
+ }
+ return $command;
+ }
+}
+
+sub init {
+ my($self,@args) = @_;
+ CPAN->debug("self[$self]args[".join(",",@args)."]");
+ $self->load(do_init => 1, @args);
+ 1;
+}
+
+# Loads CPAN::MyConfig or fall-back to CPAN::Config. Will not reload a file
+# if already loaded. Returns the path to the file %INC or else the empty string
+#
+# Note -- if CPAN::Config were loaded and CPAN::MyConfig subsequently
+# created, calling this again will leave *both* in %INC
+
+sub require_myconfig_or_config () {
+ if ( $INC{"CPAN/MyConfig.pm"} || _try_loading("CPAN::MyConfig", cpan_home())) {
+ return $INC{"CPAN/MyConfig.pm"};
+ }
+ elsif ( $INC{"CPAN/Config.pm"} || _try_loading("CPAN::Config") ) {
+ return $INC{"CPAN/Config.pm"};
+ }
+ else {
+ return q{};
+ }
+}
+
+# Load a module, but ignore "can't locate..." errors
+# Optionally take a list of directories to add to @INC for the load
+sub _try_loading {
+ my ($module, @dirs) = @_;
+ (my $file = $module) =~ s{::}{/}g;
+ $file .= ".pm";
+
+ local @INC = @INC;
+ for my $dir ( @dirs ) {
+ if ( -f File::Spec->catfile($dir, $file) ) {
+ unshift @INC, $dir;
+ last;
+ }
+ }
+
+ eval { require $file };
+ my $err_myconfig = $@;
+ if ($err_myconfig and $err_myconfig !~ m#locate \Q$file\E#) {
+ die "Error while requiring ${module}:\n$err_myconfig";
+ }
+ return $INC{$file};
+}
+
+# prioritized list of possible places for finding "CPAN/MyConfig.pm"
+sub cpan_home_dir_candidates {
+ my @dirs;
+ my $old_v = $CPAN::Config->{load_module_verbosity};
+ $CPAN::Config->{load_module_verbosity} = q[none];
+ if ($CPAN::META->has_usable('File::HomeDir')) {
+ if ($^O ne 'darwin') {
+ push @dirs, File::HomeDir->my_data;
+ # my_data is ~/Library/Application Support on darwin,
+ # which causes issues in the toolchain.
+ }
+ push @dirs, File::HomeDir->my_home;
+ }
+ # Windows might not have HOME, so check it first
+ push @dirs, $ENV{HOME} if $ENV{HOME};
+ # Windows might have these instead
+ push( @dirs, File::Spec->catpath($ENV{HOMEDRIVE}, $ENV{HOMEPATH}, '') )
+ if $ENV{HOMEDRIVE} && $ENV{HOMEPATH};
+ push @dirs, $ENV{USERPROFILE} if $ENV{USERPROFILE};
+
+ $CPAN::Config->{load_module_verbosity} = $old_v;
+ my $dotcpan = $^O eq 'VMS' ? '_cpan' : '.cpan';
+ @dirs = map { File::Spec->catdir($_, $dotcpan) } grep { defined } @dirs;
+ return wantarray ? @dirs : $dirs[0];
+}
+
+sub load {
+ my($self, %args) = @_;
+ $CPAN::Be_Silent+=0; # protect against 'used only once'
+ $CPAN::Be_Silent++ if $args{be_silent}; # do not use; planned to be removed in 2011
+ my $do_init = delete $args{do_init} || 0;
+ my $make_myconfig = delete $args{make_myconfig};
+ $loading = 0 unless defined $loading;
+
+ my $configpm = require_myconfig_or_config;
+ my @miss = $self->missing_config_data;
+ CPAN->debug("do_init[$do_init]loading[$loading]miss[@miss]") if $CPAN::DEBUG;
+ return unless $do_init || @miss;
+
+ # I'm not how we'd ever wind up in a recursive loop, but I'm leaving
+ # this here for safety's sake -- dagolden, 2011-01-19
+ return if $loading;
+ local $loading = ($loading||0) + 1;
+
+ # Warn if we have a config file, but things were found missing
+ if ($configpm && @miss && !$do_init) {
+ if ($make_myconfig || ( ! -w $configpm && $configpm =~ m{CPAN/Config\.pm})) {
+ $configpm = make_new_config();
+ $CPAN::Frontend->myprint(<<END);
+The system CPAN configuration file has provided some default values,
+but you need to complete the configuration dialog for CPAN.pm.
+Configuration will be written to
+ <<$configpm>>
+END
+ }
+ else {
+ $CPAN::Frontend->myprint(<<END);
+Sorry, we have to rerun the configuration dialog for CPAN.pm due to
+some missing parameters. Configuration will be written to
+ <<$configpm>>
+
+END
+ }
+ }
+
+ require CPAN::FirstTime;
+ return CPAN::FirstTime::init($configpm || make_new_config(), %args);
+}
+
+# Creates a new, empty config file at the preferred location
+# Any existing will be renamed with a ".bak" suffix if possible
+# If the file cannot be created, an exception is thrown
+sub make_new_config {
+ my $configpm = _new_config_name();
+ my $configpmdir = File::Basename::dirname( $configpm );
+ File::Path::mkpath($configpmdir) unless -d $configpmdir;
+
+ if ( -w $configpmdir ) {
+ #_#_# following code dumped core on me with 5.003_11, a.k.
+ if( -f $configpm ) {
+ my $configpm_bak = "$configpm.bak";
+ unlink $configpm_bak if -f $configpm_bak;
+ if( rename $configpm, $configpm_bak ) {
+ $CPAN::Frontend->mywarn(<<END);
+Old configuration file $configpm
+ moved to $configpm_bak
+END
+ }
+ }
+ my $fh = FileHandle->new;
+ if ($fh->open(">$configpm")) {
+ $fh->print("1;\n");
+ return $configpm;
+ }
+ }
+ _die_cant_write_config($configpm);
+}
+
+sub _die_cant_write_config {
+ my ($configpm) = @_;
+ $CPAN::Frontend->mydie(<<"END");
+WARNING: CPAN.pm is unable to write a configuration file. You
+must be able to create and write to '$configpm'.
+
+Aborting configuration.
+END
+
+}
+
+# From candidate directories, we would like (in descending preference order):
+# * the one that contains a MyConfig file
+# * one that exists (even without MyConfig)
+# * the first one on the list
+sub cpan_home {
+ my @dirs = cpan_home_dir_candidates();
+ for my $d (@dirs) {
+ return $d if -f "$d/CPAN/MyConfig.pm";
+ }
+ for my $d (@dirs) {
+ return $d if -d $d;
+ }
+ return $dirs[0];
+}
+
+sub _new_config_name {
+ return File::Spec->catfile(cpan_home(), 'CPAN', 'MyConfig.pm');
+}
+
+# returns mandatory but missing entries in the Config
+sub missing_config_data {
+ my(@miss);
+ for (
+ "auto_commit",
+ "build_cache",
+ "build_dir",
+ "cache_metadata",
+ "cpan_home",
+ "ftp_proxy",
+ #"gzip",
+ "http_proxy",
+ "index_expire",
+ #"inhibit_startup_message",
+ "keep_source_where",
+ #"make",
+ "make_arg",
+ "make_install_arg",
+ "makepl_arg",
+ "mbuild_arg",
+ "mbuild_install_arg",
+ ($^O eq "MSWin32" ? "" : "mbuild_install_build_command"),
+ "mbuildpl_arg",
+ "no_proxy",
+ #"pager",
+ "prerequisites_policy",
+ "scan_cache",
+ #"tar",
+ #"unzip",
+ "urllist",
+ ) {
+ next unless exists $keys{$_};
+ push @miss, $_ unless defined $CPAN::Config->{$_};
+ }
+ return @miss;
+}
+
+sub help {
+ $CPAN::Frontend->myprint(q[
+Known options:
+ commit commit session changes to disk
+ defaults reload default config values from disk
+ help this help
+ init enter a dialog to set all or a set of parameters
+
+Edit key values as in the following (the "o" is a literal letter o):
+ o conf build_cache 15
+ o conf build_dir "/foo/bar"
+ o conf urllist shift
+ o conf urllist unshift ftp://ftp.foo.bar/
+ o conf inhibit_startup_message 1
+
+]);
+ 1; #don't reprint CPAN::Config
+}
+
+sub cpl {
+ my($word,$line,$pos) = @_;
+ $word ||= "";
+ CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
+ my(@words) = split " ", substr($line,0,$pos+1);
+ if (
+ defined($words[2])
+ and
+ $words[2] =~ /list$/
+ and
+ (
+ @words == 3
+ ||
+ @words == 4 && length($word)
+ )
+ ) {
+ return grep /^\Q$word\E/, qw(splice shift unshift pop push);
+ } elsif (defined($words[2])
+ and
+ $words[2] eq "init"
+ and
+ (
+ @words == 3
+ ||
+ @words >= 4 && length($word)
+ )) {
+ return sort grep /^\Q$word\E/, keys %keys;
+ } elsif (@words >= 4) {
+ return ();
+ }
+ my %seen;
+ my(@o_conf) = sort grep { !$seen{$_}++ }
+ keys %can,
+ keys %$CPAN::Config,
+ keys %keys;
+ return grep /^\Q$word\E/, @o_conf;
+}
+
+sub prefs_lookup {
+ my($self,$distro,$what) = @_;
+
+ if ($prefssupport{$what}) {
+ return $CPAN::Config->{$what} unless
+ $distro
+ and $distro->prefs
+ and $distro->prefs->{cpanconfig}
+ and defined $distro->prefs->{cpanconfig}{$what};
+ return $distro->prefs->{cpanconfig}{$what};
+ } else {
+ $CPAN::Frontend->mywarn("Warning: $what not yet officially ".
+ "supported for distroprefs, doing a normal lookup");
+ return $CPAN::Config->{$what};
+ }
+}
+
+
+{
+ package
+ CPAN::Config; ####::###### #hide from indexer
+ # note: J. Nick Koston wrote me that they are using
+ # CPAN::Config->commit although undocumented. I suggested
+ # CPAN::Shell->o("conf","commit") even when ugly it is at least
+ # documented
+
+ # that's why I added the CPAN::Config class with autoload and
+ # deprecated warning
+
+ use strict;
+ use vars qw($AUTOLOAD $VERSION);
+ $VERSION = "5.5008";
+
+ # formerly CPAN::HandleConfig was known as CPAN::Config
+ sub AUTOLOAD { ## no critic
+ my $class = shift; # e.g. in dh-make-perl: CPAN::Config
+ my($l) = $AUTOLOAD;
+ $CPAN::Frontend->mywarn("Dispatching deprecated method '$l' to CPAN::HandleConfig\n");
+ $l =~ s/.*:://;
+ CPAN::HandleConfig->$l(@_);
+ }
+}
+
+1;
+
+__END__
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# End:
+# vim: ts=4 sts=4 sw=4:
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Index.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Index.pm
new file mode 100644
index 0000000000..59e75dcaee
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Index.pm
@@ -0,0 +1,626 @@
+package CPAN::Index;
+use strict;
+use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED $VERSION);
+$VERSION = "2.12";
+@CPAN::Index::ISA = qw(CPAN::Debug);
+$LAST_TIME ||= 0;
+$DATE_OF_03 ||= 0;
+# use constant PROTOCOL => "2.0"; # commented out to avoid warning on upgrade from 1.57
+sub PROTOCOL { 2.0 }
+
+#-> sub CPAN::Index::force_reload ;
+sub force_reload {
+ my($class) = @_;
+ $CPAN::Index::LAST_TIME = 0;
+ $class->reload(1);
+}
+
+my @indexbundle =
+ (
+ {
+ reader => "rd_authindex",
+ dir => "authors",
+ remotefile => '01mailrc.txt.gz',
+ shortlocalfile => '01mailrc.gz',
+ },
+ {
+ reader => "rd_modpacks",
+ dir => "modules",
+ remotefile => '02packages.details.txt.gz',
+ shortlocalfile => '02packag.gz',
+ },
+ {
+ reader => "rd_modlist",
+ dir => "modules",
+ remotefile => '03modlist.data.gz',
+ shortlocalfile => '03mlist.gz',
+ },
+ );
+
+#-> sub CPAN::Index::reload ;
+sub reload {
+ my($self,$force) = @_;
+ my $time = time;
+
+ # XXX check if a newer one is available. (We currently read it
+ # from time to time)
+ for ($CPAN::Config->{index_expire}) {
+ $_ = 0.001 unless $_ && $_ > 0.001;
+ }
+ unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
+ # debug here when CPAN doesn't seem to read the Metadata
+ require Carp;
+ Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
+ }
+ unless ($CPAN::META->{PROTOCOL}) {
+ $self->read_metadata_cache;
+ $CPAN::META->{PROTOCOL} ||= "1.0";
+ }
+ if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
+ # warn "Setting last_time to 0";
+ $LAST_TIME = 0; # No warning necessary
+ }
+ if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
+ and ! $force) {
+ # called too often
+ # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
+ } elsif (0) {
+ # IFF we are developing, it helps to wipe out the memory
+ # between reloads, otherwise it is not what a user expects.
+ undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
+ $CPAN::META = CPAN->new;
+ } else {
+ my($debug,$t2);
+ local $LAST_TIME = $time;
+ local $CPAN::META->{PROTOCOL} = PROTOCOL;
+
+ my $needshort = $^O eq "dos";
+
+ INX: for my $indexbundle (@indexbundle) {
+ my $reader = $indexbundle->{reader};
+ my $localfile = $needshort ? $indexbundle->{shortlocalfile} : $indexbundle->{remotefile};
+ my $localpath = File::Spec->catfile($indexbundle->{dir}, $localfile);
+ my $remote = join "/", $indexbundle->{dir}, $indexbundle->{remotefile};
+ my $localized = $self->reload_x($remote, $localpath, $force);
+ $self->$reader($localized); # may die but we let the shell catch it
+ if ($CPAN::DEBUG){
+ $t2 = time;
+ $debug = "timing reading 01[".($t2 - $time)."]";
+ $time = $t2;
+ }
+ return if $CPAN::Signal; # this is sometimes lengthy
+ }
+ $self->write_metadata_cache;
+ if ($CPAN::DEBUG){
+ $t2 = time;
+ $debug .= "03[".($t2 - $time)."]";
+ $time = $t2;
+ }
+ CPAN->debug($debug) if $CPAN::DEBUG;
+ }
+ if ($CPAN::Config->{build_dir_reuse}) {
+ $self->reanimate_build_dir;
+ }
+ if (CPAN::_sqlite_running()) {
+ $CPAN::SQLite->reload(time => $time, force => $force)
+ if not $LAST_TIME;
+ }
+ $LAST_TIME = $time;
+ $CPAN::META->{PROTOCOL} = PROTOCOL;
+}
+
+#-> sub CPAN::Index::reanimate_build_dir ;
+sub reanimate_build_dir {
+ my($self) = @_;
+ unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
+ return;
+ }
+ return if $HAVE_REANIMATED++;
+ my $d = $CPAN::Config->{build_dir};
+ my $dh = DirHandle->new;
+ opendir $dh, $d or return; # does not exist
+ my $dirent;
+ my $i = 0;
+ my $painted = 0;
+ my $restored = 0;
+ my $start = CPAN::FTP::_mytime();
+ my @candidates = map { $_->[0] }
+ sort { $b->[1] <=> $a->[1] }
+ map { [ $_, -M File::Spec->catfile($d,$_) ] }
+ grep {/(.+)\.yml$/ && -d File::Spec->catfile($d,$1)} readdir $dh;
+ if ( @candidates ) {
+ $CPAN::Frontend->myprint
+ (sprintf("Reading %d yaml file%s from %s/\n",
+ scalar @candidates,
+ @candidates==1 ? "" : "s",
+ $CPAN::Config->{build_dir}
+ ));
+ DISTRO: for $i (0..$#candidates) {
+ my $dirent = $candidates[$i];
+ my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
+ if ($@) {
+ warn "Error while parsing file '$dirent'; error: '$@'";
+ next DISTRO;
+ }
+ my $c = $y->[0];
+ if ($c && $c->{perl} && $c->{distribution} && CPAN->_perl_fingerprint($c->{perl})) {
+ my $key = $c->{distribution}{ID};
+ for my $k (keys %{$c->{distribution}}) {
+ if ($c->{distribution}{$k}
+ && ref $c->{distribution}{$k}
+ && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
+ $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
+ }
+ }
+
+ #we tried to restore only if element already
+ #exists; but then we do not work with metadata
+ #turned off.
+ my $do
+ = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
+ = $c->{distribution};
+ for my $skipper (qw(
+ badtestcnt
+ configure_requires_later
+ configure_requires_later_for
+ force_update
+ later
+ later_for
+ notest
+ should_report
+ sponsored_mods
+ prefs
+ negative_prefs_cache
+ )) {
+ delete $do->{$skipper};
+ }
+ if ($do->can("tested_ok_but_not_installed")) {
+ if ($do->tested_ok_but_not_installed) {
+ $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
+ } else {
+ next DISTRO;
+ }
+ }
+ $restored++;
+ }
+ $i++;
+ while (($painted/76) < ($i/@candidates)) {
+ $CPAN::Frontend->myprint(".");
+ $painted++;
+ }
+ }
+ }
+ else {
+ $CPAN::Frontend->myprint("Build_dir empty, nothing to restore\n");
+ }
+ my $took = CPAN::FTP::_mytime() - $start;
+ $CPAN::Frontend->myprint(sprintf(
+ "DONE\nRestored the state of %s (in %.4f secs)\n",
+ $restored || "none",
+ $took,
+ ));
+}
+
+
+#-> sub CPAN::Index::reload_x ;
+sub reload_x {
+ my($cl,$wanted,$localname,$force) = @_;
+ $force |= 2; # means we're dealing with an index here
+ CPAN::HandleConfig->load; # we should guarantee loading wherever
+ # we rely on Config XXX
+ $localname ||= $wanted;
+ my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
+ $localname);
+ if (
+ -f $abs_wanted &&
+ -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
+ !($force & 1)
+ ) {
+ my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
+ $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
+ qq{day$s. I\'ll use that.});
+ return $abs_wanted;
+ } else {
+ $force |= 1; # means we're quite serious about it.
+ }
+ return CPAN::FTP->localize($wanted,$abs_wanted,$force);
+}
+
+#-> sub CPAN::Index::rd_authindex ;
+sub rd_authindex {
+ my($cl, $index_target) = @_;
+ return unless defined $index_target;
+ return if CPAN::_sqlite_running();
+ my @lines;
+ $CPAN::Frontend->myprint("Reading '$index_target'\n");
+ local(*FH);
+ tie *FH, 'CPAN::Tarzip', $index_target;
+ local($/) = "\n";
+ local($_);
+ push @lines, split /\012/ while <FH>;
+ my $i = 0;
+ my $painted = 0;
+ foreach (@lines) {
+ my($userid,$fullname,$email) =
+ m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
+ $fullname ||= $email;
+ if ($userid && $fullname && $email) {
+ my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
+ $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
+ } else {
+ CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
+ }
+ $i++;
+ while (($painted/76) < ($i/@lines)) {
+ $CPAN::Frontend->myprint(".");
+ $painted++;
+ }
+ return if $CPAN::Signal;
+ }
+ $CPAN::Frontend->myprint("DONE\n");
+}
+
+sub userid {
+ my($self,$dist) = @_;
+ $dist = $self->{'id'} unless defined $dist;
+ my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
+ $ret;
+}
+
+#-> sub CPAN::Index::rd_modpacks ;
+sub rd_modpacks {
+ my($self, $index_target) = @_;
+ return unless defined $index_target;
+ return if CPAN::_sqlite_running();
+ $CPAN::Frontend->myprint("Reading '$index_target'\n");
+ my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
+ local $_;
+ CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
+ my $slurp = "";
+ my $chunk;
+ while (my $bytes = $fh->READ(\$chunk,8192)) {
+ $slurp.=$chunk;
+ }
+ my @lines = split /\012/, $slurp;
+ CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
+ undef $fh;
+ # read header
+ my($line_count,$last_updated);
+ while (@lines) {
+ my $shift = shift(@lines);
+ last if $shift =~ /^\s*$/;
+ $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
+ $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
+ }
+ CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
+ my $errors = 0;
+ if (not defined $line_count) {
+
+ $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
+Please check the validity of the index file by comparing it to more
+than one CPAN mirror. I'll continue but problems seem likely to
+happen.\a
+});
+ $errors++;
+ $CPAN::Frontend->mysleep(5);
+ } elsif ($line_count != scalar @lines) {
+
+ $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
+contains a Line-Count header of %d but I see %d lines there. Please
+check the validity of the index file by comparing it to more than one
+CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
+$index_target, $line_count, scalar(@lines));
+
+ }
+ if (not defined $last_updated) {
+
+ $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
+Please check the validity of the index file by comparing it to more
+than one CPAN mirror. I'll continue but problems seem likely to
+happen.\a
+});
+ $errors++;
+ $CPAN::Frontend->mysleep(5);
+ } else {
+
+ $CPAN::Frontend
+ ->myprint(sprintf qq{ Database was generated on %s\n},
+ $last_updated);
+ $DATE_OF_02 = $last_updated;
+
+ my $age = time;
+ if ($CPAN::META->has_inst('HTTP::Date')) {
+ require HTTP::Date;
+ $age -= HTTP::Date::str2time($last_updated);
+ } else {
+ $CPAN::Frontend->mywarn(" HTTP::Date not available\n");
+ require Time::Local;
+ my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
+ $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
+ $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
+ }
+ $age /= 3600*24;
+ if ($age > 30) {
+
+ $CPAN::Frontend
+ ->mywarn(sprintf
+ qq{Warning: This index file is %d days old.
+ Please check the host you chose as your CPAN mirror for staleness.
+ I'll continue but problems seem likely to happen.\a\n},
+ $age);
+
+ } elsif ($age < -1) {
+
+ $CPAN::Frontend
+ ->mywarn(sprintf
+ qq{Warning: Your system date is %d days behind this index file!
+ System time: %s
+ Timestamp index file: %s
+ Please fix your system time, problems with the make command expected.\n},
+ -$age,
+ scalar gmtime,
+ $DATE_OF_02,
+ );
+
+ }
+ }
+
+
+ # A necessity since we have metadata_cache: delete what isn't
+ # there anymore
+ my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
+ CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
+ my(%exists);
+ my $i = 0;
+ my $painted = 0;
+ LINE: foreach (@lines) {
+ # before 1.56 we split into 3 and discarded the rest. From
+ # 1.57 we assign remaining text to $comment thus allowing to
+ # influence isa_perl
+ my($mod,$version,$dist,$comment) = split " ", $_, 4;
+ unless ($mod && defined $version && $dist) {
+ require Dumpvalue;
+ my $dv = Dumpvalue->new(tick => '"');
+ $CPAN::Frontend->mywarn(sprintf "Could not split line[%s]\n", $dv->stringify($_));
+ if ($errors++ >= 5){
+ $CPAN::Frontend->mydie("Giving up parsing your $index_target, too many errors");
+ }
+ next LINE;
+ }
+ my($bundle,$id,$userid);
+
+ if ($mod eq 'CPAN' &&
+ ! (
+ CPAN::Queue->exists('Bundle::CPAN') ||
+ CPAN::Queue->exists('CPAN')
+ )
+ ) {
+ local($^W)= 0;
+ if ($version > $CPAN::VERSION) {
+ $CPAN::Frontend->mywarn(qq{
+ New CPAN.pm version (v$version) available.
+ [Currently running version is v$CPAN::VERSION]
+ You might want to try
+ install CPAN
+ reload cpan
+ to both upgrade CPAN.pm and run the new version without leaving
+ the current session.
+
+}); #});
+ $CPAN::Frontend->mysleep(2);
+ $CPAN::Frontend->myprint(qq{\n});
+ }
+ last if $CPAN::Signal;
+ } elsif ($mod =~ /^Bundle::(.*)/) {
+ $bundle = $1;
+ }
+
+ if ($bundle) {
+ $id = $CPAN::META->instance('CPAN::Bundle',$mod);
+ # Let's make it a module too, because bundles have so much
+ # in common with modules.
+
+ # Changed in 1.57_63: seems like memory bloat now without
+ # any value, so commented out
+
+ # $CPAN::META->instance('CPAN::Module',$mod);
+
+ } else {
+
+ # instantiate a module object
+ $id = $CPAN::META->instance('CPAN::Module',$mod);
+
+ }
+
+ # Although CPAN prohibits same name with different version the
+ # indexer may have changed the version for the same distro
+ # since the last time ("Force Reindexing" feature)
+ if ($id->cpan_file ne $dist
+ ||
+ $id->cpan_version ne $version
+ ) {
+ $userid = $id->userid || $self->userid($dist);
+ $id->set(
+ 'CPAN_USERID' => $userid,
+ 'CPAN_VERSION' => $version,
+ 'CPAN_FILE' => $dist,
+ );
+ }
+
+ # instantiate a distribution object
+ if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
+ # we do not need CONTAINSMODS unless we do something with
+ # this dist, so we better produce it on demand.
+
+ ## my $obj = $CPAN::META->instance(
+ ## 'CPAN::Distribution' => $dist
+ ## );
+ ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
+ } else {
+ $CPAN::META->instance(
+ 'CPAN::Distribution' => $dist
+ )->set(
+ 'CPAN_USERID' => $userid,
+ 'CPAN_COMMENT' => $comment,
+ );
+ }
+ if ($secondtime) {
+ for my $name ($mod,$dist) {
+ # $self->debug("exists name[$name]") if $CPAN::DEBUG;
+ $exists{$name} = undef;
+ }
+ }
+ $i++;
+ while (($painted/76) < ($i/@lines)) {
+ $CPAN::Frontend->myprint(".");
+ $painted++;
+ }
+ return if $CPAN::Signal;
+ }
+ $CPAN::Frontend->myprint("DONE\n");
+ if ($secondtime) {
+ for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
+ for my $o ($CPAN::META->all_objects($class)) {
+ next if exists $exists{$o->{ID}};
+ $CPAN::META->delete($class,$o->{ID});
+ # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
+ # if $CPAN::DEBUG;
+ }
+ }
+ }
+}
+
+#-> sub CPAN::Index::rd_modlist ;
+sub rd_modlist {
+ my($cl,$index_target) = @_;
+ return unless defined $index_target;
+ return if CPAN::_sqlite_running();
+ $CPAN::Frontend->myprint("Reading '$index_target'\n");
+ my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
+ local $_;
+ my $slurp = "";
+ my $chunk;
+ while (my $bytes = $fh->READ(\$chunk,8192)) {
+ $slurp.=$chunk;
+ }
+ my @eval2 = split /\012/, $slurp;
+
+ while (@eval2) {
+ my $shift = shift(@eval2);
+ if ($shift =~ /^Date:\s+(.*)/) {
+ if ($DATE_OF_03 eq $1) {
+ $CPAN::Frontend->myprint("Unchanged.\n");
+ return;
+ }
+ ($DATE_OF_03) = $1;
+ }
+ last if $shift =~ /^\s*$/;
+ }
+ push @eval2, q{CPAN::Modulelist->data;};
+ local($^W) = 0;
+ my($compmt) = Safe->new("CPAN::Safe1");
+ my($eval2) = join("\n", @eval2);
+ CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
+ my $ret = $compmt->reval($eval2);
+ Carp::confess($@) if $@;
+ return if $CPAN::Signal;
+ my $i = 0;
+ my $until = keys(%$ret);
+ my $painted = 0;
+ CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
+ for (sort keys %$ret) {
+ my $obj = $CPAN::META->instance("CPAN::Module",$_);
+ delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
+ $obj->set(%{$ret->{$_}});
+ $i++;
+ while (($painted/76) < ($i/$until)) {
+ $CPAN::Frontend->myprint(".");
+ $painted++;
+ }
+ return if $CPAN::Signal;
+ }
+ $CPAN::Frontend->myprint("DONE\n");
+}
+
+#-> sub CPAN::Index::write_metadata_cache ;
+sub write_metadata_cache {
+ my($self) = @_;
+ return unless $CPAN::Config->{'cache_metadata'};
+ return if CPAN::_sqlite_running();
+ return unless $CPAN::META->has_usable("Storable");
+ my $cache;
+ foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
+ CPAN::Distribution)) {
+ $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
+ }
+ my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
+ $cache->{last_time} = $LAST_TIME;
+ $cache->{DATE_OF_02} = $DATE_OF_02;
+ $cache->{PROTOCOL} = PROTOCOL;
+ $CPAN::Frontend->myprint("Writing $metadata_file\n");
+ eval { Storable::nstore($cache, $metadata_file) };
+ $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
+}
+
+#-> sub CPAN::Index::read_metadata_cache ;
+sub read_metadata_cache {
+ my($self) = @_;
+ return unless $CPAN::Config->{'cache_metadata'};
+ return if CPAN::_sqlite_running();
+ return unless $CPAN::META->has_usable("Storable");
+ my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
+ return unless -r $metadata_file and -f $metadata_file;
+ $CPAN::Frontend->myprint("Reading '$metadata_file'\n");
+ my $cache;
+ eval { $cache = Storable::retrieve($metadata_file) };
+ $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
+ if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) {
+ $LAST_TIME = 0;
+ return;
+ }
+ if (exists $cache->{PROTOCOL}) {
+ if (PROTOCOL > $cache->{PROTOCOL}) {
+ $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
+ "with protocol v%s, requiring v%s\n",
+ $cache->{PROTOCOL},
+ PROTOCOL)
+ );
+ return;
+ }
+ } else {
+ $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
+ "with protocol v1.0\n");
+ return;
+ }
+ my $clcnt = 0;
+ my $idcnt = 0;
+ while(my($class,$v) = each %$cache) {
+ next unless $class =~ /^CPAN::/;
+ $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
+ while (my($id,$ro) = each %$v) {
+ $CPAN::META->{readwrite}{$class}{$id} ||=
+ $class->new(ID=>$id, RO=>$ro);
+ $idcnt++;
+ }
+ $clcnt++;
+ }
+ unless ($clcnt) { # sanity check
+ $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
+ return;
+ }
+ if ($idcnt < 1000) {
+ $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
+ "in $metadata_file\n");
+ return;
+ }
+ $CPAN::META->{PROTOCOL} ||=
+ $cache->{PROTOCOL}; # reading does not up or downgrade, but it
+ # does initialize to some protocol
+ $LAST_TIME = $cache->{last_time};
+ $DATE_OF_02 = $cache->{DATE_OF_02};
+ $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
+ if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
+ return;
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/InfoObj.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/InfoObj.pm
new file mode 100644
index 0000000000..9198316c69
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/InfoObj.pm
@@ -0,0 +1,224 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::InfoObj;
+use strict;
+
+use CPAN::Debug;
+@CPAN::InfoObj::ISA = qw(CPAN::Debug);
+
+use Cwd qw(chdir);
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5";
+
+sub ro {
+ my $self = shift;
+ exists $self->{RO} and return $self->{RO};
+}
+
+#-> sub CPAN::InfoObj::cpan_userid
+sub cpan_userid {
+ my $self = shift;
+ my $ro = $self->ro;
+ if ($ro) {
+ return $ro->{CPAN_USERID} || "N/A";
+ } else {
+ $self->debug("ID[$self->{ID}]");
+ # N/A for bundles found locally
+ return "N/A";
+ }
+}
+
+sub id { shift->{ID}; }
+
+#-> sub CPAN::InfoObj::new ;
+sub new {
+ my $this = bless {}, shift;
+ %$this = @_;
+ $this
+}
+
+# The set method may only be used by code that reads index data or
+# otherwise "objective" data from the outside world. All session
+# related material may do anything else with instance variables but
+# must not touch the hash under the RO attribute. The reason is that
+# the RO hash gets written to Metadata file and is thus persistent.
+
+#-> sub CPAN::InfoObj::safe_chdir ;
+sub safe_chdir {
+ my($self,$todir) = @_;
+ # we die if we cannot chdir and we are debuggable
+ Carp::confess("safe_chdir called without todir argument")
+ unless defined $todir and length $todir;
+ if (chdir $todir) {
+ $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
+ if $CPAN::DEBUG;
+ } else {
+ if (-e $todir) {
+ unless (-x $todir) {
+ unless (chmod 0755, $todir) {
+ my $cwd = CPAN::anycwd();
+ $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
+ "permission to change the permission; cannot ".
+ "chdir to '$todir'\n");
+ $CPAN::Frontend->mysleep(5);
+ $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
+ qq{to todir[$todir]: $!});
+ }
+ }
+ } else {
+ $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
+ }
+ if (chdir $todir) {
+ $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
+ if $CPAN::DEBUG;
+ } else {
+ my $cwd = CPAN::anycwd();
+ $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
+ qq{to todir[$todir] (a chmod has been issued): $!});
+ }
+ }
+}
+
+#-> sub CPAN::InfoObj::set ;
+sub set {
+ my($self,%att) = @_;
+ my $class = ref $self;
+
+ # This must be ||=, not ||, because only if we write an empty
+ # reference, only then the set method will write into the readonly
+ # area. But for Distributions that spring into existence, maybe
+ # because of a typo, we do not like it that they are written into
+ # the readonly area and made permanent (at least for a while) and
+ # that is why we do not "allow" other places to call ->set.
+ unless ($self->id) {
+ CPAN->debug("Bug? Empty ID, rejecting");
+ return;
+ }
+ my $ro = $self->{RO} =
+ $CPAN::META->{readonly}{$class}{$self->id} ||= {};
+
+ while (my($k,$v) = each %att) {
+ $ro->{$k} = $v;
+ }
+}
+
+#-> sub CPAN::InfoObj::as_glimpse ;
+sub as_glimpse {
+ my($self) = @_;
+ my(@m);
+ my $class = ref($self);
+ $class =~ s/^CPAN:://;
+ my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
+ push @m, sprintf "%-15s %s\n", $class, $id;
+ join "", @m;
+}
+
+#-> sub CPAN::InfoObj::as_string ;
+sub as_string {
+ my($self) = @_;
+ my(@m);
+ my $class = ref($self);
+ $class =~ s/^CPAN:://;
+ push @m, $class, " id = $self->{ID}\n";
+ my $ro;
+ unless ($ro = $self->ro) {
+ if (substr($self->{ID},-1,1) eq ".") { # directory
+ $ro = +{};
+ } else {
+ $CPAN::Frontend->mywarn("Unknown object $self->{ID}\n");
+ $CPAN::Frontend->mysleep(5);
+ return;
+ }
+ }
+ for (sort keys %$ro) {
+ # next if m/^(ID|RO)$/;
+ my $extra = "";
+ if ($_ eq "CPAN_USERID") {
+ $extra .= " (";
+ $extra .= $self->fullname;
+ my $email; # old perls!
+ if ($email = $CPAN::META->instance("CPAN::Author",
+ $self->cpan_userid
+ )->email) {
+ $extra .= " <$email>";
+ } else {
+ $extra .= " <no email>";
+ }
+ $extra .= ")";
+ } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
+ push @m, sprintf " %-12s %s\n", $_, $self->fullname;
+ next;
+ }
+ next unless defined $ro->{$_};
+ push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra;
+ }
+ KEY: for (sort keys %$self) {
+ next if m/^(ID|RO)$/;
+ unless (defined $self->{$_}) {
+ delete $self->{$_};
+ next KEY;
+ }
+ if (ref($self->{$_}) eq "ARRAY") {
+ push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
+ } elsif (ref($self->{$_}) eq "HASH") {
+ my $value;
+ if (/^CONTAINSMODS$/) {
+ $value = join(" ",sort keys %{$self->{$_}});
+ } elsif (/^prereq_pm$/) {
+ my @value;
+ my $v = $self->{$_};
+ for my $x (sort keys %$v) {
+ my @svalue;
+ for my $y (sort keys %{$v->{$x}}) {
+ push @svalue, "$y=>$v->{$x}{$y}";
+ }
+ push @value, "$x\:" . join ",", @svalue if @svalue;
+ }
+ $value = join ";", @value;
+ } else {
+ $value = $self->{$_};
+ }
+ push @m, sprintf(
+ " %-12s %s\n",
+ $_,
+ $value,
+ );
+ } else {
+ push @m, sprintf " %-12s %s\n", $_, $self->{$_};
+ }
+ }
+ join "", @m, "\n";
+}
+
+#-> sub CPAN::InfoObj::fullname ;
+sub fullname {
+ my($self) = @_;
+ $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
+}
+
+#-> sub CPAN::InfoObj::dump ;
+sub dump {
+ my($self, $what) = @_;
+ unless ($CPAN::META->has_inst("Data::Dumper")) {
+ $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
+ }
+ local $Data::Dumper::Sortkeys;
+ $Data::Dumper::Sortkeys = 1;
+ my $out = Data::Dumper::Dumper($what ? eval $what : $self);
+ if (length $out > 100000) {
+ my $fh_pager = FileHandle->new;
+ local($SIG{PIPE}) = "IGNORE";
+ my $pager = $CPAN::Config->{'pager'} || "cat";
+ $fh_pager->open("|$pager")
+ or die "Could not open pager $pager\: $!";
+ $fh_pager->print($out);
+ close $fh_pager;
+ } else {
+ $CPAN::Frontend->myprint($out);
+ }
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Kwalify.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Kwalify.pm
new file mode 100644
index 0000000000..3cade90b91
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Kwalify.pm
@@ -0,0 +1,136 @@
+=head1 NAME
+
+CPAN::Kwalify - Interface between CPAN.pm and Kwalify.pm
+
+=head1 SYNOPSIS
+
+ use CPAN::Kwalify;
+ validate($schema_name, $data, $file, $doc);
+
+=head1 DESCRIPTION
+
+=over
+
+=item _validate($schema_name, $data, $file, $doc)
+
+$schema_name is the name of a supported schema. Currently only
+C<distroprefs> is supported. $data is the data to be validated. $file
+is the absolute path to the file the data are coming from. $doc is the
+index of the document within $doc that is to be validated. The last
+two arguments are only there for better error reporting.
+
+Relies on being called from within CPAN.pm.
+
+Dies if something fails. Does not return anything useful.
+
+=item yaml($schema_name)
+
+Returns the YAML text of that schema. Dies if something fails.
+
+=back
+
+=head1 AUTHOR
+
+Andreas Koenig C<< <andk@cpan.org> >>
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+
+
+=cut
+
+
+use strict;
+
+package CPAN::Kwalify;
+use vars qw($VERSION $VAR1);
+$VERSION = "5.50";
+
+use File::Spec ();
+
+my %vcache = ();
+
+my $schema_loaded = {};
+
+sub _validate {
+ my($schema_name,$data,$abs,$y) = @_;
+ my $yaml_module = CPAN->_yaml_module;
+ if (
+ $CPAN::META->has_inst($yaml_module)
+ &&
+ $CPAN::META->has_inst("Kwalify")
+ ) {
+ my $load = UNIVERSAL::can($yaml_module,"Load");
+ unless ($schema_loaded->{$schema_name}) {
+ eval {
+ my $schema_yaml = yaml($schema_name);
+ $schema_loaded->{$schema_name} = $load->($schema_yaml);
+ };
+ if ($@) {
+ # we know that YAML.pm 0.62 cannot parse the schema,
+ # so we try a fallback
+ my $content = do {
+ my $path = __FILE__;
+ $path =~ s/\.pm$//;
+ $path = File::Spec->catfile($path, "$schema_name.dd");
+ local *FH;
+ open FH, $path or die "Could not open '$path': $!";
+ local $/;
+ <FH>;
+ };
+ $VAR1 = undef;
+ eval $content;
+ if (my $err = $@) {
+ die "parsing of '$schema_name.dd' failed: $err";
+ }
+ $schema_loaded->{$schema_name} = $VAR1;
+ }
+ }
+ }
+ if (my $schema = $schema_loaded->{$schema_name}) {
+ my $mtime = (stat $abs)[9];
+ for my $k (keys %{$vcache{$abs}}) {
+ delete $vcache{$abs}{$k} unless $k eq $mtime;
+ }
+ return if $vcache{$abs}{$mtime}{$y}++;
+ eval { Kwalify::validate($schema, $data) };
+ if (my $err = $@) {
+ my $info = {}; yaml($schema_name, info => $info);
+ die "validation of distropref '$abs'[$y] against schema '$info->{path}' failed: $err";
+ }
+ }
+}
+
+sub _clear_cache {
+ %vcache = ();
+}
+
+sub yaml {
+ my($schema_name, %opt) = @_;
+ my $content = do {
+ my $path = __FILE__;
+ $path =~ s/\.pm$//;
+ $path = File::Spec->catfile($path, "$schema_name.yml");
+ if ($opt{info}) {
+ $opt{info}{path} = $path;
+ }
+ local *FH;
+ open FH, $path or die "Could not open '$path': $!";
+ local $/;
+ <FH>;
+ };
+ return $content;
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# End:
+
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Kwalify/distroprefs.dd b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Kwalify/distroprefs.dd
new file mode 100644
index 0000000000..fd046271b8
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Kwalify/distroprefs.dd
@@ -0,0 +1,150 @@
+$VAR1 = {
+ "mapping" => {
+ "comment" => {
+ "type" => "text"
+ },
+ "cpanconfig" => {
+ "mapping" => {
+ "=" => {
+ "type" => "text"
+ }
+ },
+ "type" => "map"
+ },
+ "depends" => {
+ "mapping" => {
+ "build_requires" => {
+ "mapping" => {
+ "=" => {
+ "type" => "text"
+ }
+ },
+ "type" => "map"
+ },
+ "configure_requires" => {},
+ "requires" => {}
+ },
+ "type" => "map"
+ },
+ "disabled" => {
+ "enum" => [
+ 0,
+ 1
+ ],
+ "type" => "int"
+ },
+ "features" => {
+ "sequence" => [
+ {
+ "type" => "text"
+ }
+ ],
+ "type" => "seq"
+ },
+ "goto" => {
+ "type" => "text"
+ },
+ "install" => {
+ "mapping" => {
+ "args" => {
+ "sequence" => [
+ {
+ "type" => "text"
+ }
+ ],
+ "type" => "seq"
+ },
+ "commandline" => {
+ "type" => "text"
+ },
+ "eexpect" => {
+ "mapping" => {
+ "mode" => {
+ "enum" => [
+ "deterministic",
+ "anyorder"
+ ],
+ "type" => "text"
+ },
+ "reuse" => {
+ "type" => "int"
+ },
+ "talk" => {
+ "sequence" => [
+ {
+ "type" => "text"
+ }
+ ],
+ "type" => "seq"
+ },
+ "timeout" => {
+ "type" => "number"
+ }
+ },
+ "type" => "map"
+ },
+ "env" => {
+ "mapping" => {
+ "=" => {
+ "type" => "text"
+ }
+ },
+ "type" => "map"
+ },
+ "expect" => {
+ "sequence" => [
+ {
+ "type" => "text"
+ }
+ ],
+ "type" => "seq"
+ }
+ },
+ "type" => "map"
+ },
+ "make" => {},
+ "match" => {
+ "mapping" => {
+ "distribution" => {
+ "type" => "text"
+ },
+ "env" => {
+ "mapping" => {
+ "=" => {
+ "type" => "text"
+ }
+ },
+ "type" => "map"
+ },
+ "module" => {
+ "type" => "text"
+ },
+ "perl" => {
+ "type" => "text"
+ },
+ "perlconfig" => {}
+ },
+ "type" => "map"
+ },
+ "patches" => {
+ "sequence" => [
+ {
+ "type" => "text"
+ }
+ ],
+ "type" => "seq"
+ },
+ "pl" => {},
+ "reminder" => {
+ "type" => "text"
+ },
+ "test" => {}
+ },
+ "type" => "map"
+};
+$VAR1->{"mapping"}{"depends"}{"mapping"}{"configure_requires"} = $VAR1->{"mapping"}{"depends"}{"mapping"}{"build_requires"};
+$VAR1->{"mapping"}{"depends"}{"mapping"}{"requires"} = $VAR1->{"mapping"}{"depends"}{"mapping"}{"build_requires"};
+$VAR1->{"mapping"}{"make"} = $VAR1->{"mapping"}{"install"};
+$VAR1->{"mapping"}{"match"}{"mapping"}{"perlconfig"} = $VAR1->{"mapping"}{"match"}{"mapping"}{"env"};
+$VAR1->{"mapping"}{"pl"} = $VAR1->{"mapping"}{"install"};
+$VAR1->{"mapping"}{"test"} = $VAR1->{"mapping"}{"install"};
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Kwalify/distroprefs.yml b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Kwalify/distroprefs.yml
new file mode 100644
index 0000000000..431f174276
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Kwalify/distroprefs.yml
@@ -0,0 +1,92 @@
+---
+type: map
+mapping:
+ comment:
+ type: text
+ depends:
+ type: map
+ mapping:
+ configure_requires:
+ &requires_common
+ type: map
+ mapping:
+ =:
+ type: text
+ build_requires: *requires_common
+ requires: *requires_common
+ match:
+ type: map
+ mapping:
+ distribution:
+ type: text
+ module:
+ type: text
+ perl:
+ type: text
+ perlconfig:
+ &matchhash_common
+ type: map
+ mapping:
+ =:
+ type: text
+ env: *matchhash_common
+ install:
+ &args_env_expect
+ type: map
+ mapping:
+ args:
+ type: seq
+ sequence:
+ - type: text
+ commandline:
+ type: text
+ env:
+ type: map
+ mapping:
+ =:
+ type: text
+ expect:
+ type: seq
+ sequence:
+ - type: text
+ eexpect:
+ type: map
+ mapping:
+ mode:
+ type: text
+ enum:
+ - deterministic
+ - anyorder
+ timeout:
+ type: number
+ reuse:
+ type: int
+ talk:
+ type: seq
+ sequence:
+ - type: text
+ make: *args_env_expect
+ pl: *args_env_expect
+ test: *args_env_expect
+ patches:
+ type: seq
+ sequence:
+ - type: text
+ disabled:
+ type: int
+ enum:
+ - 0
+ - 1
+ goto:
+ type: text
+ cpanconfig:
+ type: map
+ mapping:
+ =:
+ type: text
+ features:
+ type: seq
+ sequence:
+ - type: text
+ reminder:
+ type: text
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/LWP/UserAgent.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/LWP/UserAgent.pm
new file mode 100644
index 0000000000..fe8bf27a4a
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/LWP/UserAgent.pm
@@ -0,0 +1,62 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::LWP::UserAgent;
+use strict;
+use vars qw(@ISA $USER $PASSWD $SETUPDONE);
+use CPAN::HTTP::Credentials;
+# we delay requiring LWP::UserAgent and setting up inheritance until we need it
+
+$CPAN::LWP::UserAgent::VERSION = $CPAN::LWP::UserAgent::VERSION = "1.9601";
+
+
+sub config {
+ return if $SETUPDONE;
+ if ($CPAN::META->has_usable('LWP::UserAgent')) {
+ require LWP::UserAgent;
+ @ISA = qw(Exporter LWP::UserAgent); ## no critic
+ $SETUPDONE++;
+ } else {
+ $CPAN::Frontend->mywarn(" LWP::UserAgent not available\n");
+ }
+}
+
+sub get_basic_credentials {
+ my($self, $realm, $uri, $proxy) = @_;
+ if ( $proxy ) {
+ return CPAN::HTTP::Credentials->get_proxy_credentials();
+ } else {
+ return CPAN::HTTP::Credentials->get_non_proxy_credentials();
+ }
+}
+
+sub no_proxy {
+ my ( $self, $no_proxy ) = @_;
+ return $self->SUPER::no_proxy( split(',',$no_proxy) );
+}
+
+# mirror(): Its purpose is to deal with proxy authentication. When we
+# call SUPER::mirror, we really call the mirror method in
+# LWP::UserAgent. LWP::UserAgent will then call
+# $self->get_basic_credentials or some equivalent and this will be
+# $self->dispatched to our own get_basic_credentials method.
+
+# Our own get_basic_credentials sets $USER and $PASSWD, two globals.
+
+# 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
+# although we have gone through our get_basic_credentials, the proxy
+# server refuses to connect. This could be a case where the username or
+# password has changed in the meantime, so I'm trying once again without
+# $USER and $PASSWD to give the get_basic_credentials routine another
+# chance to set $USER and $PASSWD.
+
+sub mirror {
+ my($self,$url,$aslocal) = @_;
+ my $result = $self->SUPER::mirror($url,$aslocal);
+ if ($result->code == 407) {
+ CPAN::HTTP::Credentials->clear_credentials;
+ $result = $self->SUPER::mirror($url,$aslocal);
+ }
+ $result;
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta.pm
new file mode 100644
index 0000000000..4a8e65c0fc
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta.pm
@@ -0,0 +1,1176 @@
+use 5.006;
+use strict;
+use warnings;
+package CPAN::Meta;
+
+our $VERSION = '2.150010';
+
+#pod =head1 SYNOPSIS
+#pod
+#pod use v5.10;
+#pod use strict;
+#pod use warnings;
+#pod use CPAN::Meta;
+#pod use Module::Load;
+#pod
+#pod my $meta = CPAN::Meta->load_file('META.json');
+#pod
+#pod printf "testing requirements for %s version %s\n",
+#pod $meta->name,
+#pod $meta->version;
+#pod
+#pod my $prereqs = $meta->effective_prereqs;
+#pod
+#pod for my $phase ( qw/configure runtime build test/ ) {
+#pod say "Requirements for $phase:";
+#pod my $reqs = $prereqs->requirements_for($phase, "requires");
+#pod for my $module ( sort $reqs->required_modules ) {
+#pod my $status;
+#pod if ( eval { load $module unless $module eq 'perl'; 1 } ) {
+#pod my $version = $module eq 'perl' ? $] : $module->VERSION;
+#pod $status = $reqs->accepts_module($module, $version)
+#pod ? "$version ok" : "$version not ok";
+#pod } else {
+#pod $status = "missing"
+#pod };
+#pod say " $module ($status)";
+#pod }
+#pod }
+#pod
+#pod =head1 DESCRIPTION
+#pod
+#pod Software distributions released to the CPAN include a F<META.json> or, for
+#pod older distributions, F<META.yml>, which describes the distribution, its
+#pod contents, and the requirements for building and installing the distribution.
+#pod The data structure stored in the F<META.json> file is described in
+#pod L<CPAN::Meta::Spec>.
+#pod
+#pod CPAN::Meta provides a simple class to represent this distribution metadata (or
+#pod I<distmeta>), along with some helpful methods for interrogating that data.
+#pod
+#pod The documentation below is only for the methods of the CPAN::Meta object. For
+#pod information on the meaning of individual fields, consult the spec.
+#pod
+#pod =cut
+
+use Carp qw(carp croak);
+use CPAN::Meta::Feature;
+use CPAN::Meta::Prereqs;
+use CPAN::Meta::Converter;
+use CPAN::Meta::Validator;
+use Parse::CPAN::Meta 1.4414 ();
+
+BEGIN { *_dclone = \&CPAN::Meta::Converter::_dclone }
+
+#pod =head1 STRING DATA
+#pod
+#pod The following methods return a single value, which is the value for the
+#pod corresponding entry in the distmeta structure. Values should be either undef
+#pod or strings.
+#pod
+#pod =for :list
+#pod * abstract
+#pod * description
+#pod * dynamic_config
+#pod * generated_by
+#pod * name
+#pod * release_status
+#pod * version
+#pod
+#pod =cut
+
+BEGIN {
+ my @STRING_READERS = qw(
+ abstract
+ description
+ dynamic_config
+ generated_by
+ name
+ release_status
+ version
+ );
+
+ no strict 'refs';
+ for my $attr (@STRING_READERS) {
+ *$attr = sub { $_[0]{ $attr } };
+ }
+}
+
+#pod =head1 LIST DATA
+#pod
+#pod These methods return lists of string values, which might be represented in the
+#pod distmeta structure as arrayrefs or scalars:
+#pod
+#pod =for :list
+#pod * authors
+#pod * keywords
+#pod * licenses
+#pod
+#pod The C<authors> and C<licenses> methods may also be called as C<author> and
+#pod C<license>, respectively, to match the field name in the distmeta structure.
+#pod
+#pod =cut
+
+BEGIN {
+ my @LIST_READERS = qw(
+ author
+ keywords
+ license
+ );
+
+ no strict 'refs';
+ for my $attr (@LIST_READERS) {
+ *$attr = sub {
+ my $value = $_[0]{ $attr };
+ croak "$attr must be called in list context"
+ unless wantarray;
+ return @{ _dclone($value) } if ref $value;
+ return $value;
+ };
+ }
+}
+
+sub authors { $_[0]->author }
+sub licenses { $_[0]->license }
+
+#pod =head1 MAP DATA
+#pod
+#pod These readers return hashrefs of arbitrary unblessed data structures, each
+#pod described more fully in the specification:
+#pod
+#pod =for :list
+#pod * meta_spec
+#pod * resources
+#pod * provides
+#pod * no_index
+#pod * prereqs
+#pod * optional_features
+#pod
+#pod =cut
+
+BEGIN {
+ my @MAP_READERS = qw(
+ meta-spec
+ resources
+ provides
+ no_index
+
+ prereqs
+ optional_features
+ );
+
+ no strict 'refs';
+ for my $attr (@MAP_READERS) {
+ (my $subname = $attr) =~ s/-/_/;
+ *$subname = sub {
+ my $value = $_[0]{ $attr };
+ return _dclone($value) if $value;
+ return {};
+ };
+ }
+}
+
+#pod =head1 CUSTOM DATA
+#pod
+#pod A list of custom keys are available from the C<custom_keys> method and
+#pod particular keys may be retrieved with the C<custom> method.
+#pod
+#pod say $meta->custom($_) for $meta->custom_keys;
+#pod
+#pod If a custom key refers to a data structure, a deep clone is returned.
+#pod
+#pod =cut
+
+sub custom_keys {
+ return grep { /^x_/i } keys %{$_[0]};
+}
+
+sub custom {
+ my ($self, $attr) = @_;
+ my $value = $self->{$attr};
+ return _dclone($value) if ref $value;
+ return $value;
+}
+
+#pod =method new
+#pod
+#pod my $meta = CPAN::Meta->new($distmeta_struct, \%options);
+#pod
+#pod Returns a valid CPAN::Meta object or dies if the supplied metadata hash
+#pod reference fails to validate. Older-format metadata will be up-converted to
+#pod version 2 if they validate against the original stated specification.
+#pod
+#pod It takes an optional hashref of options. Valid options include:
+#pod
+#pod =over
+#pod
+#pod =item *
+#pod
+#pod lazy_validation -- if true, new will attempt to convert the given metadata
+#pod to version 2 before attempting to validate it. This means than any
+#pod fixable errors will be handled by CPAN::Meta::Converter before validation.
+#pod (Note that this might result in invalid optional data being silently
+#pod dropped.) The default is false.
+#pod
+#pod =back
+#pod
+#pod =cut
+
+sub _new {
+ my ($class, $struct, $options) = @_;
+ my $self;
+
+ if ( $options->{lazy_validation} ) {
+ # try to convert to a valid structure; if succeeds, then return it
+ my $cmc = CPAN::Meta::Converter->new( $struct );
+ $self = $cmc->convert( version => 2 ); # valid or dies
+ return bless $self, $class;
+ }
+ else {
+ # validate original struct
+ my $cmv = CPAN::Meta::Validator->new( $struct );
+ unless ( $cmv->is_valid) {
+ die "Invalid metadata structure. Errors: "
+ . join(", ", $cmv->errors) . "\n";
+ }
+ }
+
+ # up-convert older spec versions
+ my $version = $struct->{'meta-spec'}{version} || '1.0';
+ if ( $version == 2 ) {
+ $self = $struct;
+ }
+ else {
+ my $cmc = CPAN::Meta::Converter->new( $struct );
+ $self = $cmc->convert( version => 2 );
+ }
+
+ return bless $self, $class;
+}
+
+sub new {
+ my ($class, $struct, $options) = @_;
+ my $self = eval { $class->_new($struct, $options) };
+ croak($@) if $@;
+ return $self;
+}
+
+#pod =method create
+#pod
+#pod my $meta = CPAN::Meta->create($distmeta_struct, \%options);
+#pod
+#pod This is same as C<new()>, except that C<generated_by> and C<meta-spec> fields
+#pod will be generated if not provided. This means the metadata structure is
+#pod assumed to otherwise follow the latest L<CPAN::Meta::Spec>.
+#pod
+#pod =cut
+
+sub create {
+ my ($class, $struct, $options) = @_;
+ my $version = __PACKAGE__->VERSION || 2;
+ $struct->{generated_by} ||= __PACKAGE__ . " version $version" ;
+ $struct->{'meta-spec'}{version} ||= int($version);
+ my $self = eval { $class->_new($struct, $options) };
+ croak ($@) if $@;
+ return $self;
+}
+
+#pod =method load_file
+#pod
+#pod my $meta = CPAN::Meta->load_file($distmeta_file, \%options);
+#pod
+#pod Given a pathname to a file containing metadata, this deserializes the file
+#pod according to its file suffix and constructs a new C<CPAN::Meta> object, just
+#pod like C<new()>. It will die if the deserialized version fails to validate
+#pod against its stated specification version.
+#pod
+#pod It takes the same options as C<new()> but C<lazy_validation> defaults to
+#pod true.
+#pod
+#pod =cut
+
+sub load_file {
+ my ($class, $file, $options) = @_;
+ $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
+
+ croak "load_file() requires a valid, readable filename"
+ unless -r $file;
+
+ my $self;
+ eval {
+ my $struct = Parse::CPAN::Meta->load_file( $file );
+ $self = $class->_new($struct, $options);
+ };
+ croak($@) if $@;
+ return $self;
+}
+
+#pod =method load_yaml_string
+#pod
+#pod my $meta = CPAN::Meta->load_yaml_string($yaml, \%options);
+#pod
+#pod This method returns a new CPAN::Meta object using the first document in the
+#pod given YAML string. In other respects it is identical to C<load_file()>.
+#pod
+#pod =cut
+
+sub load_yaml_string {
+ my ($class, $yaml, $options) = @_;
+ $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
+
+ my $self;
+ eval {
+ my ($struct) = Parse::CPAN::Meta->load_yaml_string( $yaml );
+ $self = $class->_new($struct, $options);
+ };
+ croak($@) if $@;
+ return $self;
+}
+
+#pod =method load_json_string
+#pod
+#pod my $meta = CPAN::Meta->load_json_string($json, \%options);
+#pod
+#pod This method returns a new CPAN::Meta object using the structure represented by
+#pod the given JSON string. In other respects it is identical to C<load_file()>.
+#pod
+#pod =cut
+
+sub load_json_string {
+ my ($class, $json, $options) = @_;
+ $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
+
+ my $self;
+ eval {
+ my $struct = Parse::CPAN::Meta->load_json_string( $json );
+ $self = $class->_new($struct, $options);
+ };
+ croak($@) if $@;
+ return $self;
+}
+
+#pod =method load_string
+#pod
+#pod my $meta = CPAN::Meta->load_string($string, \%options);
+#pod
+#pod If you don't know if a string contains YAML or JSON, this method will use
+#pod L<Parse::CPAN::Meta> to guess. In other respects it is identical to
+#pod C<load_file()>.
+#pod
+#pod =cut
+
+sub load_string {
+ my ($class, $string, $options) = @_;
+ $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
+
+ my $self;
+ eval {
+ my $struct = Parse::CPAN::Meta->load_string( $string );
+ $self = $class->_new($struct, $options);
+ };
+ croak($@) if $@;
+ return $self;
+}
+
+#pod =method save
+#pod
+#pod $meta->save($distmeta_file, \%options);
+#pod
+#pod Serializes the object as JSON and writes it to the given file. The only valid
+#pod option is C<version>, which defaults to '2'. On Perl 5.8.1 or later, the file
+#pod is saved with UTF-8 encoding.
+#pod
+#pod For C<version> 2 (or higher), the filename should end in '.json'. L<JSON::PP>
+#pod is the default JSON backend. Using another JSON backend requires L<JSON> 2.5 or
+#pod later and you must set the C<$ENV{PERL_JSON_BACKEND}> to a supported alternate
+#pod backend like L<JSON::XS>.
+#pod
+#pod For C<version> less than 2, the filename should end in '.yml'.
+#pod L<CPAN::Meta::Converter> is used to generate an older metadata structure, which
+#pod is serialized to YAML. CPAN::Meta::YAML is the default YAML backend. You may
+#pod set the C<$ENV{PERL_YAML_BACKEND}> to a supported alternative backend, though
+#pod this is not recommended due to subtle incompatibilities between YAML parsers on
+#pod CPAN.
+#pod
+#pod =cut
+
+sub save {
+ my ($self, $file, $options) = @_;
+
+ my $version = $options->{version} || '2';
+ my $layer = $] ge '5.008001' ? ':utf8' : '';
+
+ if ( $version ge '2' ) {
+ carp "'$file' should end in '.json'"
+ unless $file =~ m{\.json$};
+ }
+ else {
+ carp "'$file' should end in '.yml'"
+ unless $file =~ m{\.yml$};
+ }
+
+ my $data = $self->as_string( $options );
+ open my $fh, ">$layer", $file
+ or die "Error opening '$file' for writing: $!\n";
+
+ print {$fh} $data;
+ close $fh
+ or die "Error closing '$file': $!\n";
+
+ return 1;
+}
+
+#pod =method meta_spec_version
+#pod
+#pod This method returns the version part of the C<meta_spec> entry in the distmeta
+#pod structure. It is equivalent to:
+#pod
+#pod $meta->meta_spec->{version};
+#pod
+#pod =cut
+
+sub meta_spec_version {
+ my ($self) = @_;
+ return $self->meta_spec->{version};
+}
+
+#pod =method effective_prereqs
+#pod
+#pod my $prereqs = $meta->effective_prereqs;
+#pod
+#pod my $prereqs = $meta->effective_prereqs( \@feature_identifiers );
+#pod
+#pod This method returns a L<CPAN::Meta::Prereqs> object describing all the
+#pod prereqs for the distribution. If an arrayref of feature identifiers is given,
+#pod the prereqs for the identified features are merged together with the
+#pod distribution's core prereqs before the CPAN::Meta::Prereqs object is returned.
+#pod
+#pod =cut
+
+sub effective_prereqs {
+ my ($self, $features) = @_;
+ $features ||= [];
+
+ my $prereq = CPAN::Meta::Prereqs->new($self->prereqs);
+
+ return $prereq unless @$features;
+
+ my @other = map {; $self->feature($_)->prereqs } @$features;
+
+ return $prereq->with_merged_prereqs(\@other);
+}
+
+#pod =method should_index_file
+#pod
+#pod ... if $meta->should_index_file( $filename );
+#pod
+#pod This method returns true if the given file should be indexed. It decides this
+#pod by checking the C<file> and C<directory> keys in the C<no_index> property of
+#pod the distmeta structure. Note that neither the version format nor
+#pod C<release_status> are considered.
+#pod
+#pod C<$filename> should be given in unix format.
+#pod
+#pod =cut
+
+sub should_index_file {
+ my ($self, $filename) = @_;
+
+ for my $no_index_file (@{ $self->no_index->{file} || [] }) {
+ return if $filename eq $no_index_file;
+ }
+
+ for my $no_index_dir (@{ $self->no_index->{directory} }) {
+ $no_index_dir =~ s{$}{/} unless $no_index_dir =~ m{/\z};
+ return if index($filename, $no_index_dir) == 0;
+ }
+
+ return 1;
+}
+
+#pod =method should_index_package
+#pod
+#pod ... if $meta->should_index_package( $package );
+#pod
+#pod This method returns true if the given package should be indexed. It decides
+#pod this by checking the C<package> and C<namespace> keys in the C<no_index>
+#pod property of the distmeta structure. Note that neither the version format nor
+#pod C<release_status> are considered.
+#pod
+#pod =cut
+
+sub should_index_package {
+ my ($self, $package) = @_;
+
+ for my $no_index_pkg (@{ $self->no_index->{package} || [] }) {
+ return if $package eq $no_index_pkg;
+ }
+
+ for my $no_index_ns (@{ $self->no_index->{namespace} }) {
+ return if index($package, "${no_index_ns}::") == 0;
+ }
+
+ return 1;
+}
+
+#pod =method features
+#pod
+#pod my @feature_objects = $meta->features;
+#pod
+#pod This method returns a list of L<CPAN::Meta::Feature> objects, one for each
+#pod optional feature described by the distribution's metadata.
+#pod
+#pod =cut
+
+sub features {
+ my ($self) = @_;
+
+ my $opt_f = $self->optional_features;
+ my @features = map {; CPAN::Meta::Feature->new($_ => $opt_f->{ $_ }) }
+ keys %$opt_f;
+
+ return @features;
+}
+
+#pod =method feature
+#pod
+#pod my $feature_object = $meta->feature( $identifier );
+#pod
+#pod This method returns a L<CPAN::Meta::Feature> object for the optional feature
+#pod with the given identifier. If no feature with that identifier exists, an
+#pod exception will be raised.
+#pod
+#pod =cut
+
+sub feature {
+ my ($self, $ident) = @_;
+
+ croak "no feature named $ident"
+ unless my $f = $self->optional_features->{ $ident };
+
+ return CPAN::Meta::Feature->new($ident, $f);
+}
+
+#pod =method as_struct
+#pod
+#pod my $copy = $meta->as_struct( \%options );
+#pod
+#pod This method returns a deep copy of the object's metadata as an unblessed hash
+#pod reference. It takes an optional hashref of options. If the hashref contains
+#pod a C<version> argument, the copied metadata will be converted to the version
+#pod of the specification and returned. For example:
+#pod
+#pod my $old_spec = $meta->as_struct( {version => "1.4"} );
+#pod
+#pod =cut
+
+sub as_struct {
+ my ($self, $options) = @_;
+ my $struct = _dclone($self);
+ if ( $options->{version} ) {
+ my $cmc = CPAN::Meta::Converter->new( $struct );
+ $struct = $cmc->convert( version => $options->{version} );
+ }
+ return $struct;
+}
+
+#pod =method as_string
+#pod
+#pod my $string = $meta->as_string( \%options );
+#pod
+#pod This method returns a serialized copy of the object's metadata as a character
+#pod string. (The strings are B<not> UTF-8 encoded.) It takes an optional hashref
+#pod of options. If the hashref contains a C<version> argument, the copied metadata
+#pod will be converted to the version of the specification and returned. For
+#pod example:
+#pod
+#pod my $string = $meta->as_string( {version => "1.4"} );
+#pod
+#pod For C<version> greater than or equal to 2, the string will be serialized as
+#pod JSON. For C<version> less than 2, the string will be serialized as YAML. In
+#pod both cases, the same rules are followed as in the C<save()> method for choosing
+#pod a serialization backend.
+#pod
+#pod The serialized structure will include a C<x_serialization_backend> entry giving
+#pod the package and version used to serialize. Any existing key in the given
+#pod C<$meta> object will be clobbered.
+#pod
+#pod =cut
+
+sub as_string {
+ my ($self, $options) = @_;
+
+ my $version = $options->{version} || '2';
+
+ my $struct;
+ if ( $self->meta_spec_version ne $version ) {
+ my $cmc = CPAN::Meta::Converter->new( $self->as_struct );
+ $struct = $cmc->convert( version => $version );
+ }
+ else {
+ $struct = $self->as_struct;
+ }
+
+ my ($data, $backend);
+ if ( $version ge '2' ) {
+ $backend = Parse::CPAN::Meta->json_backend();
+ local $struct->{x_serialization_backend} = sprintf '%s version %s',
+ $backend, $backend->VERSION;
+ $data = $backend->new->pretty->canonical->encode($struct);
+ }
+ else {
+ $backend = Parse::CPAN::Meta->yaml_backend();
+ local $struct->{x_serialization_backend} = sprintf '%s version %s',
+ $backend, $backend->VERSION;
+ $data = eval { no strict 'refs'; &{"$backend\::Dump"}($struct) };
+ if ( $@ ) {
+ croak $backend->can('errstr') ? $backend->errstr : $@
+ }
+ }
+
+ return $data;
+}
+
+# Used by JSON::PP, etc. for "convert_blessed"
+sub TO_JSON {
+ return { %{ $_[0] } };
+}
+
+1;
+
+# ABSTRACT: the distribution metadata for a CPAN dist
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+CPAN::Meta - the distribution metadata for a CPAN dist
+
+=head1 VERSION
+
+version 2.150010
+
+=head1 SYNOPSIS
+
+ use v5.10;
+ use strict;
+ use warnings;
+ use CPAN::Meta;
+ use Module::Load;
+
+ my $meta = CPAN::Meta->load_file('META.json');
+
+ printf "testing requirements for %s version %s\n",
+ $meta->name,
+ $meta->version;
+
+ my $prereqs = $meta->effective_prereqs;
+
+ for my $phase ( qw/configure runtime build test/ ) {
+ say "Requirements for $phase:";
+ my $reqs = $prereqs->requirements_for($phase, "requires");
+ for my $module ( sort $reqs->required_modules ) {
+ my $status;
+ if ( eval { load $module unless $module eq 'perl'; 1 } ) {
+ my $version = $module eq 'perl' ? $] : $module->VERSION;
+ $status = $reqs->accepts_module($module, $version)
+ ? "$version ok" : "$version not ok";
+ } else {
+ $status = "missing"
+ };
+ say " $module ($status)";
+ }
+ }
+
+=head1 DESCRIPTION
+
+Software distributions released to the CPAN include a F<META.json> or, for
+older distributions, F<META.yml>, which describes the distribution, its
+contents, and the requirements for building and installing the distribution.
+The data structure stored in the F<META.json> file is described in
+L<CPAN::Meta::Spec>.
+
+CPAN::Meta provides a simple class to represent this distribution metadata (or
+I<distmeta>), along with some helpful methods for interrogating that data.
+
+The documentation below is only for the methods of the CPAN::Meta object. For
+information on the meaning of individual fields, consult the spec.
+
+=head1 METHODS
+
+=head2 new
+
+ my $meta = CPAN::Meta->new($distmeta_struct, \%options);
+
+Returns a valid CPAN::Meta object or dies if the supplied metadata hash
+reference fails to validate. Older-format metadata will be up-converted to
+version 2 if they validate against the original stated specification.
+
+It takes an optional hashref of options. Valid options include:
+
+=over
+
+=item *
+
+lazy_validation -- if true, new will attempt to convert the given metadata
+to version 2 before attempting to validate it. This means than any
+fixable errors will be handled by CPAN::Meta::Converter before validation.
+(Note that this might result in invalid optional data being silently
+dropped.) The default is false.
+
+=back
+
+=head2 create
+
+ my $meta = CPAN::Meta->create($distmeta_struct, \%options);
+
+This is same as C<new()>, except that C<generated_by> and C<meta-spec> fields
+will be generated if not provided. This means the metadata structure is
+assumed to otherwise follow the latest L<CPAN::Meta::Spec>.
+
+=head2 load_file
+
+ my $meta = CPAN::Meta->load_file($distmeta_file, \%options);
+
+Given a pathname to a file containing metadata, this deserializes the file
+according to its file suffix and constructs a new C<CPAN::Meta> object, just
+like C<new()>. It will die if the deserialized version fails to validate
+against its stated specification version.
+
+It takes the same options as C<new()> but C<lazy_validation> defaults to
+true.
+
+=head2 load_yaml_string
+
+ my $meta = CPAN::Meta->load_yaml_string($yaml, \%options);
+
+This method returns a new CPAN::Meta object using the first document in the
+given YAML string. In other respects it is identical to C<load_file()>.
+
+=head2 load_json_string
+
+ my $meta = CPAN::Meta->load_json_string($json, \%options);
+
+This method returns a new CPAN::Meta object using the structure represented by
+the given JSON string. In other respects it is identical to C<load_file()>.
+
+=head2 load_string
+
+ my $meta = CPAN::Meta->load_string($string, \%options);
+
+If you don't know if a string contains YAML or JSON, this method will use
+L<Parse::CPAN::Meta> to guess. In other respects it is identical to
+C<load_file()>.
+
+=head2 save
+
+ $meta->save($distmeta_file, \%options);
+
+Serializes the object as JSON and writes it to the given file. The only valid
+option is C<version>, which defaults to '2'. On Perl 5.8.1 or later, the file
+is saved with UTF-8 encoding.
+
+For C<version> 2 (or higher), the filename should end in '.json'. L<JSON::PP>
+is the default JSON backend. Using another JSON backend requires L<JSON> 2.5 or
+later and you must set the C<$ENV{PERL_JSON_BACKEND}> to a supported alternate
+backend like L<JSON::XS>.
+
+For C<version> less than 2, the filename should end in '.yml'.
+L<CPAN::Meta::Converter> is used to generate an older metadata structure, which
+is serialized to YAML. CPAN::Meta::YAML is the default YAML backend. You may
+set the C<$ENV{PERL_YAML_BACKEND}> to a supported alternative backend, though
+this is not recommended due to subtle incompatibilities between YAML parsers on
+CPAN.
+
+=head2 meta_spec_version
+
+This method returns the version part of the C<meta_spec> entry in the distmeta
+structure. It is equivalent to:
+
+ $meta->meta_spec->{version};
+
+=head2 effective_prereqs
+
+ my $prereqs = $meta->effective_prereqs;
+
+ my $prereqs = $meta->effective_prereqs( \@feature_identifiers );
+
+This method returns a L<CPAN::Meta::Prereqs> object describing all the
+prereqs for the distribution. If an arrayref of feature identifiers is given,
+the prereqs for the identified features are merged together with the
+distribution's core prereqs before the CPAN::Meta::Prereqs object is returned.
+
+=head2 should_index_file
+
+ ... if $meta->should_index_file( $filename );
+
+This method returns true if the given file should be indexed. It decides this
+by checking the C<file> and C<directory> keys in the C<no_index> property of
+the distmeta structure. Note that neither the version format nor
+C<release_status> are considered.
+
+C<$filename> should be given in unix format.
+
+=head2 should_index_package
+
+ ... if $meta->should_index_package( $package );
+
+This method returns true if the given package should be indexed. It decides
+this by checking the C<package> and C<namespace> keys in the C<no_index>
+property of the distmeta structure. Note that neither the version format nor
+C<release_status> are considered.
+
+=head2 features
+
+ my @feature_objects = $meta->features;
+
+This method returns a list of L<CPAN::Meta::Feature> objects, one for each
+optional feature described by the distribution's metadata.
+
+=head2 feature
+
+ my $feature_object = $meta->feature( $identifier );
+
+This method returns a L<CPAN::Meta::Feature> object for the optional feature
+with the given identifier. If no feature with that identifier exists, an
+exception will be raised.
+
+=head2 as_struct
+
+ my $copy = $meta->as_struct( \%options );
+
+This method returns a deep copy of the object's metadata as an unblessed hash
+reference. It takes an optional hashref of options. If the hashref contains
+a C<version> argument, the copied metadata will be converted to the version
+of the specification and returned. For example:
+
+ my $old_spec = $meta->as_struct( {version => "1.4"} );
+
+=head2 as_string
+
+ my $string = $meta->as_string( \%options );
+
+This method returns a serialized copy of the object's metadata as a character
+string. (The strings are B<not> UTF-8 encoded.) It takes an optional hashref
+of options. If the hashref contains a C<version> argument, the copied metadata
+will be converted to the version of the specification and returned. For
+example:
+
+ my $string = $meta->as_string( {version => "1.4"} );
+
+For C<version> greater than or equal to 2, the string will be serialized as
+JSON. For C<version> less than 2, the string will be serialized as YAML. In
+both cases, the same rules are followed as in the C<save()> method for choosing
+a serialization backend.
+
+The serialized structure will include a C<x_serialization_backend> entry giving
+the package and version used to serialize. Any existing key in the given
+C<$meta> object will be clobbered.
+
+=head1 STRING DATA
+
+The following methods return a single value, which is the value for the
+corresponding entry in the distmeta structure. Values should be either undef
+or strings.
+
+=over 4
+
+=item *
+
+abstract
+
+=item *
+
+description
+
+=item *
+
+dynamic_config
+
+=item *
+
+generated_by
+
+=item *
+
+name
+
+=item *
+
+release_status
+
+=item *
+
+version
+
+=back
+
+=head1 LIST DATA
+
+These methods return lists of string values, which might be represented in the
+distmeta structure as arrayrefs or scalars:
+
+=over 4
+
+=item *
+
+authors
+
+=item *
+
+keywords
+
+=item *
+
+licenses
+
+=back
+
+The C<authors> and C<licenses> methods may also be called as C<author> and
+C<license>, respectively, to match the field name in the distmeta structure.
+
+=head1 MAP DATA
+
+These readers return hashrefs of arbitrary unblessed data structures, each
+described more fully in the specification:
+
+=over 4
+
+=item *
+
+meta_spec
+
+=item *
+
+resources
+
+=item *
+
+provides
+
+=item *
+
+no_index
+
+=item *
+
+prereqs
+
+=item *
+
+optional_features
+
+=back
+
+=head1 CUSTOM DATA
+
+A list of custom keys are available from the C<custom_keys> method and
+particular keys may be retrieved with the C<custom> method.
+
+ say $meta->custom($_) for $meta->custom_keys;
+
+If a custom key refers to a data structure, a deep clone is returned.
+
+=for Pod::Coverage TO_JSON abstract author authors custom custom_keys description dynamic_config
+generated_by keywords license licenses meta_spec name no_index
+optional_features prereqs provides release_status resources version
+
+=head1 BUGS
+
+Please report any bugs or feature using the CPAN Request Tracker.
+Bugs can be submitted through the web interface at
+L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
+
+When submitting a bug or request, please include a test-file or a patch to an
+existing test-file that illustrates the bug or desired feature.
+
+=head1 SEE ALSO
+
+=over 4
+
+=item *
+
+L<CPAN::Meta::Converter>
+
+=item *
+
+L<CPAN::Meta::Validator>
+
+=back
+
+=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
+
+=head1 SUPPORT
+
+=head2 Bugs / Feature Requests
+
+Please report any bugs or feature requests through the issue tracker
+at L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta/issues>.
+You will be notified automatically of any progress on your issue.
+
+=head2 Source Code
+
+This is open source software. The code repository is available for
+public review and contribution under the terms of the license.
+
+L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta>
+
+ git clone https://github.com/Perl-Toolchain-Gang/CPAN-Meta.git
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+David Golden <dagolden@cpan.org>
+
+=item *
+
+Ricardo Signes <rjbs@cpan.org>
+
+=item *
+
+Adam Kennedy <adamk@cpan.org>
+
+=back
+
+=head1 CONTRIBUTORS
+
+=for stopwords Ansgar Burchardt Avar Arnfjord Bjarmason Benjamin Noggle Christopher J. Madsen Chuck Adams Cory G Watson Damyan Ivanov David Golden Eric Wilhelm Graham Knop Gregor Hermann Karen Etheridge Kenichi Ishigaki Kent Fredric Ken Williams Lars Dieckow Leon Timmermans majensen Mark Fowler Matt S Trout Michael G. Schwern Mohammad Anwar mohawk2 moznion Niko Tyni Olaf Alders Olivier Mengué Randy Sims Tomohiro Hosaka
+
+=over 4
+
+=item *
+
+Ansgar Burchardt <ansgar@cpan.org>
+
+=item *
+
+Avar Arnfjord Bjarmason <avar@cpan.org>
+
+=item *
+
+Benjamin Noggle <agwind@users.noreply.github.com>
+
+=item *
+
+Christopher J. Madsen <cjm@cpan.org>
+
+=item *
+
+Chuck Adams <cja987@gmail.com>
+
+=item *
+
+Cory G Watson <gphat@cpan.org>
+
+=item *
+
+Damyan Ivanov <dam@cpan.org>
+
+=item *
+
+David Golden <xdg@xdg.me>
+
+=item *
+
+Eric Wilhelm <ewilhelm@cpan.org>
+
+=item *
+
+Graham Knop <haarg@haarg.org>
+
+=item *
+
+Gregor Hermann <gregoa@debian.org>
+
+=item *
+
+Karen Etheridge <ether@cpan.org>
+
+=item *
+
+Kenichi Ishigaki <ishigaki@cpan.org>
+
+=item *
+
+Kent Fredric <kentfredric@gmail.com>
+
+=item *
+
+Ken Williams <kwilliams@cpan.org>
+
+=item *
+
+Lars Dieckow <daxim@cpan.org>
+
+=item *
+
+Leon Timmermans <leont@cpan.org>
+
+=item *
+
+majensen <maj@fortinbras.us>
+
+=item *
+
+Mark Fowler <markf@cpan.org>
+
+=item *
+
+Matt S Trout <mst@shadowcat.co.uk>
+
+=item *
+
+Michael G. Schwern <mschwern@cpan.org>
+
+=item *
+
+Mohammad S Anwar <mohammad.anwar@yahoo.com>
+
+=item *
+
+mohawk2 <mohawk2@users.noreply.github.com>
+
+=item *
+
+moznion <moznion@gmail.com>
+
+=item *
+
+Niko Tyni <ntyni@debian.org>
+
+=item *
+
+Olaf Alders <olaf@wundersolutions.com>
+
+=item *
+
+Olivier Mengué <dolmen@cpan.org>
+
+=item *
+
+Randy Sims <randys@thepierianspring.org>
+
+=item *
+
+Tomohiro Hosaka <bokutin@bokut.in>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
+
+__END__
+
+
+# vim: ts=2 sts=2 sw=2 et :
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Converter.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Converter.pm
new file mode 100644
index 0000000000..0a52dcc2e6
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Converter.pm
@@ -0,0 +1,1657 @@
+use 5.006;
+use strict;
+use warnings;
+package CPAN::Meta::Converter;
+
+our $VERSION = '2.150010';
+
+#pod =head1 SYNOPSIS
+#pod
+#pod my $struct = decode_json_file('META.json');
+#pod
+#pod my $cmc = CPAN::Meta::Converter->new( $struct );
+#pod
+#pod my $new_struct = $cmc->convert( version => "2" );
+#pod
+#pod =head1 DESCRIPTION
+#pod
+#pod This module converts CPAN Meta structures from one form to another. The
+#pod primary use is to convert older structures to the most modern version of
+#pod the specification, but other transformations may be implemented in the
+#pod future as needed. (E.g. stripping all custom fields or stripping all
+#pod optional fields.)
+#pod
+#pod =cut
+
+use CPAN::Meta::Validator;
+use CPAN::Meta::Requirements;
+use Parse::CPAN::Meta 1.4400 ();
+
+# To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls
+# before 5.10, we fall back to the EUMM bundled compatibility version module if
+# that's the only thing available. This shouldn't ever happen in a normal CPAN
+# install of CPAN::Meta::Requirements, as version.pm will be picked up from
+# prereqs and be available at runtime.
+
+BEGIN {
+ eval "use version ()"; ## no critic
+ if ( my $err = $@ ) {
+ eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic
+ }
+}
+
+# Perl 5.10.0 didn't have "is_qv" in version.pm
+*_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} };
+
+# We limit cloning to a maximum depth to bail out on circular data
+# structures. While actual cycle detection might be technically better,
+# we expect circularity in META data structures to be rare and generally
+# the result of user error. Therefore, a depth counter is lower overhead.
+our $DCLONE_MAXDEPTH = 1024;
+our $_CLONE_DEPTH;
+
+sub _dclone {
+ my ( $ref ) = @_;
+ return $ref unless my $reftype = ref $ref;
+
+ local $_CLONE_DEPTH = defined $_CLONE_DEPTH ? $_CLONE_DEPTH - 1 : $DCLONE_MAXDEPTH;
+ die "Depth Limit $DCLONE_MAXDEPTH Exceeded" if $_CLONE_DEPTH == 0;
+
+ return [ map { _dclone( $_ ) } @{$ref} ] if 'ARRAY' eq $reftype;
+ return { map { $_ => _dclone( $ref->{$_} ) } keys %{$ref} } if 'HASH' eq $reftype;
+
+ if ( 'SCALAR' eq $reftype ) {
+ my $new = _dclone(${$ref});
+ return \$new;
+ }
+
+ # We can't know if TO_JSON gives us cloned data, so refs must recurse
+ if ( eval { $ref->can('TO_JSON') } ) {
+ my $data = $ref->TO_JSON;
+ return ref $data ? _dclone( $data ) : $data;
+ }
+
+ # Just stringify everything else
+ return "$ref";
+}
+
+my %known_specs = (
+ '2' => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
+ '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
+ '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html',
+ '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
+ '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html',
+ '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html'
+);
+
+my @spec_list = sort { $a <=> $b } keys %known_specs;
+my ($LOWEST, $HIGHEST) = @spec_list[0,-1];
+
+#--------------------------------------------------------------------------#
+# converters
+#
+# called as $converter->($element, $field_name, $full_meta, $to_version)
+#
+# defined return value used for field
+# undef return value means field is skipped
+#--------------------------------------------------------------------------#
+
+sub _keep { $_[0] }
+
+sub _keep_or_one { defined($_[0]) ? $_[0] : 1 }
+
+sub _keep_or_zero { defined($_[0]) ? $_[0] : 0 }
+
+sub _keep_or_unknown { defined($_[0]) && length($_[0]) ? $_[0] : "unknown" }
+
+sub _generated_by {
+ my $gen = shift;
+ my $sig = __PACKAGE__ . " version " . (__PACKAGE__->VERSION || "<dev>");
+
+ return $sig unless defined $gen and length $gen;
+ return $gen if $gen =~ /\Q$sig/;
+ return "$gen, $sig";
+}
+
+sub _listify { ! defined $_[0] ? undef : ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]] }
+
+sub _prefix_custom {
+ my $key = shift;
+ $key =~ s/^(?!x_) # Unless it already starts with x_
+ (?:x-?)? # Remove leading x- or x (if present)
+ /x_/ix; # and prepend x_
+ return $key;
+}
+
+sub _ucfirst_custom {
+ my $key = shift;
+ $key = ucfirst $key unless $key =~ /[A-Z]/;
+ return $key;
+}
+
+sub _no_prefix_ucfirst_custom {
+ my $key = shift;
+ $key =~ s/^x_//;
+ return _ucfirst_custom($key);
+}
+
+sub _change_meta_spec {
+ my ($element, undef, undef, $version) = @_;
+ return {
+ version => $version,
+ url => $known_specs{$version},
+ };
+}
+
+my @open_source = (
+ 'perl',
+ 'gpl',
+ 'apache',
+ 'artistic',
+ 'artistic_2',
+ 'lgpl',
+ 'bsd',
+ 'gpl',
+ 'mit',
+ 'mozilla',
+ 'open_source',
+);
+
+my %is_open_source = map {; $_ => 1 } @open_source;
+
+my @valid_licenses_1 = (
+ @open_source,
+ 'unrestricted',
+ 'restrictive',
+ 'unknown',
+);
+
+my %license_map_1 = (
+ ( map { $_ => $_ } @valid_licenses_1 ),
+ artistic2 => 'artistic_2',
+);
+
+sub _license_1 {
+ my ($element) = @_;
+ return 'unknown' unless defined $element;
+ if ( $license_map_1{lc $element} ) {
+ return $license_map_1{lc $element};
+ }
+ else {
+ return 'unknown';
+ }
+}
+
+my @valid_licenses_2 = qw(
+ agpl_3
+ apache_1_1
+ apache_2_0
+ artistic_1
+ artistic_2
+ bsd
+ freebsd
+ gfdl_1_2
+ gfdl_1_3
+ gpl_1
+ gpl_2
+ gpl_3
+ lgpl_2_1
+ lgpl_3_0
+ mit
+ mozilla_1_0
+ mozilla_1_1
+ openssl
+ perl_5
+ qpl_1_0
+ ssleay
+ sun
+ zlib
+ open_source
+ restricted
+ unrestricted
+ unknown
+);
+
+# The "old" values were defined by Module::Build, and were often vague. I have
+# made the decisions below based on reading Module::Build::API and how clearly
+# it specifies the version of the license.
+my %license_map_2 = (
+ (map { $_ => $_ } @valid_licenses_2),
+ apache => 'apache_2_0', # clearly stated as 2.0
+ artistic => 'artistic_1', # clearly stated as 1
+ artistic2 => 'artistic_2', # clearly stated as 2
+ gpl => 'open_source', # we don't know which GPL; punt
+ lgpl => 'open_source', # we don't know which LGPL; punt
+ mozilla => 'open_source', # we don't know which MPL; punt
+ perl => 'perl_5', # clearly Perl 5
+ restrictive => 'restricted',
+);
+
+sub _license_2 {
+ my ($element) = @_;
+ return [ 'unknown' ] unless defined $element;
+ $element = [ $element ] unless ref $element eq 'ARRAY';
+ my @new_list;
+ for my $lic ( @$element ) {
+ next unless defined $lic;
+ if ( my $new = $license_map_2{lc $lic} ) {
+ push @new_list, $new;
+ }
+ }
+ return @new_list ? \@new_list : [ 'unknown' ];
+}
+
+my %license_downgrade_map = qw(
+ agpl_3 open_source
+ apache_1_1 apache
+ apache_2_0 apache
+ artistic_1 artistic
+ artistic_2 artistic_2
+ bsd bsd
+ freebsd open_source
+ gfdl_1_2 open_source
+ gfdl_1_3 open_source
+ gpl_1 gpl
+ gpl_2 gpl
+ gpl_3 gpl
+ lgpl_2_1 lgpl
+ lgpl_3_0 lgpl
+ mit mit
+ mozilla_1_0 mozilla
+ mozilla_1_1 mozilla
+ openssl open_source
+ perl_5 perl
+ qpl_1_0 open_source
+ ssleay open_source
+ sun open_source
+ zlib open_source
+ open_source open_source
+ restricted restrictive
+ unrestricted unrestricted
+ unknown unknown
+);
+
+sub _downgrade_license {
+ my ($element) = @_;
+ if ( ! defined $element ) {
+ return "unknown";
+ }
+ elsif( ref $element eq 'ARRAY' ) {
+ if ( @$element > 1) {
+ if (grep { !$is_open_source{ $license_downgrade_map{lc $_} || 'unknown' } } @$element) {
+ return 'unknown';
+ }
+ else {
+ return 'open_source';
+ }
+ }
+ elsif ( @$element == 1 ) {
+ return $license_downgrade_map{lc $element->[0]} || "unknown";
+ }
+ }
+ elsif ( ! ref $element ) {
+ return $license_downgrade_map{lc $element} || "unknown";
+ }
+ return "unknown";
+}
+
+my $no_index_spec_1_2 = {
+ 'file' => \&_listify,
+ 'dir' => \&_listify,
+ 'package' => \&_listify,
+ 'namespace' => \&_listify,
+};
+
+my $no_index_spec_1_3 = {
+ 'file' => \&_listify,
+ 'directory' => \&_listify,
+ 'package' => \&_listify,
+ 'namespace' => \&_listify,
+};
+
+my $no_index_spec_2 = {
+ 'file' => \&_listify,
+ 'directory' => \&_listify,
+ 'package' => \&_listify,
+ 'namespace' => \&_listify,
+ ':custom' => \&_prefix_custom,
+};
+
+sub _no_index_1_2 {
+ my (undef, undef, $meta) = @_;
+ my $no_index = $meta->{no_index} || $meta->{private};
+ return unless $no_index;
+
+ # cleanup wrong format
+ if ( ! ref $no_index ) {
+ my $item = $no_index;
+ $no_index = { dir => [ $item ], file => [ $item ] };
+ }
+ elsif ( ref $no_index eq 'ARRAY' ) {
+ my $list = $no_index;
+ $no_index = { dir => [ @$list ], file => [ @$list ] };
+ }
+
+ # common mistake: files -> file
+ if ( exists $no_index->{files} ) {
+ $no_index->{file} = delete $no_index->{files};
+ }
+ # common mistake: modules -> module
+ if ( exists $no_index->{modules} ) {
+ $no_index->{module} = delete $no_index->{modules};
+ }
+ return _convert($no_index, $no_index_spec_1_2);
+}
+
+sub _no_index_directory {
+ my ($element, $key, $meta, $version) = @_;
+ return unless $element;
+
+ # clean up wrong format
+ if ( ! ref $element ) {
+ my $item = $element;
+ $element = { directory => [ $item ], file => [ $item ] };
+ }
+ elsif ( ref $element eq 'ARRAY' ) {
+ my $list = $element;
+ $element = { directory => [ @$list ], file => [ @$list ] };
+ }
+
+ if ( exists $element->{dir} ) {
+ $element->{directory} = delete $element->{dir};
+ }
+ # common mistake: files -> file
+ if ( exists $element->{files} ) {
+ $element->{file} = delete $element->{files};
+ }
+ # common mistake: modules -> module
+ if ( exists $element->{modules} ) {
+ $element->{module} = delete $element->{modules};
+ }
+ my $spec = $version == 2 ? $no_index_spec_2 : $no_index_spec_1_3;
+ return _convert($element, $spec);
+}
+
+sub _is_module_name {
+ my $mod = shift;
+ return unless defined $mod && length $mod;
+ return $mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$};
+}
+
+sub _clean_version {
+ my ($element) = @_;
+ return 0 if ! defined $element;
+
+ $element =~ s{^\s*}{};
+ $element =~ s{\s*$}{};
+ $element =~ s{^\.}{0.};
+
+ return 0 if ! length $element;
+ return 0 if ( $element eq 'undef' || $element eq '<undef>' );
+
+ my $v = eval { version->new($element) };
+ # XXX check defined $v and not just $v because version objects leak memory
+ # in boolean context -- dagolden, 2012-02-03
+ if ( defined $v ) {
+ return _is_qv($v) ? $v->normal : $element;
+ }
+ else {
+ return 0;
+ }
+}
+
+sub _bad_version_hook {
+ my ($v) = @_;
+ $v =~ s{^\s*}{};
+ $v =~ s{\s*$}{};
+ $v =~ s{[a-z]+$}{}; # strip trailing alphabetics
+ my $vobj = eval { version->new($v) };
+ return defined($vobj) ? $vobj : version->new(0); # or give up
+}
+
+sub _version_map {
+ my ($element) = @_;
+ return unless defined $element;
+ if ( ref $element eq 'HASH' ) {
+ # XXX turn this into CPAN::Meta::Requirements with bad version hook
+ # and then turn it back into a hash
+ my $new_map = CPAN::Meta::Requirements->new(
+ { bad_version_hook => \&_bad_version_hook } # punt
+ );
+ while ( my ($k,$v) = each %$element ) {
+ next unless _is_module_name($k);
+ if ( !defined($v) || !length($v) || $v eq 'undef' || $v eq '<undef>' ) {
+ $v = 0;
+ }
+ # some weird, old META have bad yml with module => module
+ # so check if value is like a module name and not like a version
+ if ( _is_module_name($v) && ! version::is_lax($v) ) {
+ $new_map->add_minimum($k => 0);
+ $new_map->add_minimum($v => 0);
+ }
+ $new_map->add_string_requirement($k => $v);
+ }
+ return $new_map->as_string_hash;
+ }
+ elsif ( ref $element eq 'ARRAY' ) {
+ my $hashref = { map { $_ => 0 } @$element };
+ return _version_map($hashref); # clean up any weird stuff
+ }
+ elsif ( ref $element eq '' && length $element ) {
+ return { $element => 0 }
+ }
+ return;
+}
+
+sub _prereqs_from_1 {
+ my (undef, undef, $meta) = @_;
+ my $prereqs = {};
+ for my $phase ( qw/build configure/ ) {
+ my $key = "${phase}_requires";
+ $prereqs->{$phase}{requires} = _version_map($meta->{$key})
+ if $meta->{$key};
+ }
+ for my $rel ( qw/requires recommends conflicts/ ) {
+ $prereqs->{runtime}{$rel} = _version_map($meta->{$rel})
+ if $meta->{$rel};
+ }
+ return $prereqs;
+}
+
+my $prereqs_spec = {
+ configure => \&_prereqs_rel,
+ build => \&_prereqs_rel,
+ test => \&_prereqs_rel,
+ runtime => \&_prereqs_rel,
+ develop => \&_prereqs_rel,
+ ':custom' => \&_prefix_custom,
+};
+
+my $relation_spec = {
+ requires => \&_version_map,
+ recommends => \&_version_map,
+ suggests => \&_version_map,
+ conflicts => \&_version_map,
+ ':custom' => \&_prefix_custom,
+};
+
+sub _cleanup_prereqs {
+ my ($prereqs, $key, $meta, $to_version) = @_;
+ return unless $prereqs && ref $prereqs eq 'HASH';
+ return _convert( $prereqs, $prereqs_spec, $to_version );
+}
+
+sub _prereqs_rel {
+ my ($relation, $key, $meta, $to_version) = @_;
+ return unless $relation && ref $relation eq 'HASH';
+ return _convert( $relation, $relation_spec, $to_version );
+}
+
+
+BEGIN {
+ my @old_prereqs = qw(
+ requires
+ configure_requires
+ recommends
+ conflicts
+ );
+
+ for ( @old_prereqs ) {
+ my $sub = "_get_$_";
+ my ($phase,$type) = split qr/_/, $_;
+ if ( ! defined $type ) {
+ $type = $phase;
+ $phase = 'runtime';
+ }
+ no strict 'refs';
+ *{$sub} = sub { _extract_prereqs($_[2]->{prereqs},$phase,$type) };
+ }
+}
+
+sub _get_build_requires {
+ my ($data, $key, $meta) = @_;
+
+ my $test_h = _extract_prereqs($_[2]->{prereqs}, qw(test requires)) || {};
+ my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {};
+
+ my $test_req = CPAN::Meta::Requirements->from_string_hash($test_h);
+ my $build_req = CPAN::Meta::Requirements->from_string_hash($build_h);
+
+ $test_req->add_requirements($build_req)->as_string_hash;
+}
+
+sub _extract_prereqs {
+ my ($prereqs, $phase, $type) = @_;
+ return unless ref $prereqs eq 'HASH';
+ return scalar _version_map($prereqs->{$phase}{$type});
+}
+
+sub _downgrade_optional_features {
+ my (undef, undef, $meta) = @_;
+ return unless exists $meta->{optional_features};
+ my $origin = $meta->{optional_features};
+ my $features = {};
+ for my $name ( keys %$origin ) {
+ $features->{$name} = {
+ description => $origin->{$name}{description},
+ requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','requires'),
+ configure_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'),
+ build_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'),
+ recommends => _extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'),
+ conflicts => _extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'),
+ };
+ for my $k (keys %{$features->{$name}} ) {
+ delete $features->{$name}{$k} unless defined $features->{$name}{$k};
+ }
+ }
+ return $features;
+}
+
+sub _upgrade_optional_features {
+ my (undef, undef, $meta) = @_;
+ return unless exists $meta->{optional_features};
+ my $origin = $meta->{optional_features};
+ my $features = {};
+ for my $name ( keys %$origin ) {
+ $features->{$name} = {
+ description => $origin->{$name}{description},
+ prereqs => _prereqs_from_1(undef, undef, $origin->{$name}),
+ };
+ delete $features->{$name}{prereqs}{configure};
+ }
+ return $features;
+}
+
+my $optional_features_2_spec = {
+ description => \&_keep,
+ prereqs => \&_cleanup_prereqs,
+ ':custom' => \&_prefix_custom,
+};
+
+sub _feature_2 {
+ my ($element, $key, $meta, $to_version) = @_;
+ return unless $element && ref $element eq 'HASH';
+ _convert( $element, $optional_features_2_spec, $to_version );
+}
+
+sub _cleanup_optional_features_2 {
+ my ($element, $key, $meta, $to_version) = @_;
+ return unless $element && ref $element eq 'HASH';
+ my $new_data = {};
+ for my $k ( keys %$element ) {
+ $new_data->{$k} = _feature_2( $element->{$k}, $k, $meta, $to_version );
+ }
+ return unless keys %$new_data;
+ return $new_data;
+}
+
+sub _optional_features_1_4 {
+ my ($element) = @_;
+ return unless $element;
+ $element = _optional_features_as_map($element);
+ for my $name ( keys %$element ) {
+ for my $drop ( qw/requires_packages requires_os excluded_os/ ) {
+ delete $element->{$name}{$drop};
+ }
+ }
+ return $element;
+}
+
+sub _optional_features_as_map {
+ my ($element) = @_;
+ return unless $element;
+ if ( ref $element eq 'ARRAY' ) {
+ my %map;
+ for my $feature ( @$element ) {
+ my (@parts) = %$feature;
+ $map{$parts[0]} = $parts[1];
+ }
+ $element = \%map;
+ }
+ return $element;
+}
+
+sub _is_urlish { defined $_[0] && $_[0] =~ m{\A[-+.a-z0-9]+:.+}i }
+
+sub _url_or_drop {
+ my ($element) = @_;
+ return $element if _is_urlish($element);
+ return;
+}
+
+sub _url_list {
+ my ($element) = @_;
+ return unless $element;
+ $element = _listify( $element );
+ $element = [ grep { _is_urlish($_) } @$element ];
+ return unless @$element;
+ return $element;
+}
+
+sub _author_list {
+ my ($element) = @_;
+ return [ 'unknown' ] unless $element;
+ $element = _listify( $element );
+ $element = [ map { defined $_ && length $_ ? $_ : 'unknown' } @$element ];
+ return [ 'unknown' ] unless @$element;
+ return $element;
+}
+
+my $resource2_upgrade = {
+ license => sub { return _is_urlish($_[0]) ? _listify( $_[0] ) : undef },
+ homepage => \&_url_or_drop,
+ bugtracker => sub {
+ my ($item) = @_;
+ return unless $item;
+ if ( $item =~ m{^mailto:(.*)$} ) { return { mailto => $1 } }
+ elsif( _is_urlish($item) ) { return { web => $item } }
+ else { return }
+ },
+ repository => sub { return _is_urlish($_[0]) ? { url => $_[0] } : undef },
+ ':custom' => \&_prefix_custom,
+};
+
+sub _upgrade_resources_2 {
+ my (undef, undef, $meta, $version) = @_;
+ return unless exists $meta->{resources};
+ return _convert($meta->{resources}, $resource2_upgrade);
+}
+
+my $bugtracker2_spec = {
+ web => \&_url_or_drop,
+ mailto => \&_keep,
+ ':custom' => \&_prefix_custom,
+};
+
+sub _repo_type {
+ my ($element, $key, $meta, $to_version) = @_;
+ return $element if defined $element;
+ return unless exists $meta->{url};
+ my $repo_url = $meta->{url};
+ for my $type ( qw/git svn/ ) {
+ return $type if $repo_url =~ m{\A$type};
+ }
+ return;
+}
+
+my $repository2_spec = {
+ web => \&_url_or_drop,
+ url => \&_url_or_drop,
+ type => \&_repo_type,
+ ':custom' => \&_prefix_custom,
+};
+
+my $resources2_cleanup = {
+ license => \&_url_list,
+ homepage => \&_url_or_drop,
+ bugtracker => sub { ref $_[0] ? _convert( $_[0], $bugtracker2_spec ) : undef },
+ repository => sub { my $data = shift; ref $data ? _convert( $data, $repository2_spec ) : undef },
+ ':custom' => \&_prefix_custom,
+};
+
+sub _cleanup_resources_2 {
+ my ($resources, $key, $meta, $to_version) = @_;
+ return unless $resources && ref $resources eq 'HASH';
+ return _convert($resources, $resources2_cleanup, $to_version);
+}
+
+my $resource1_spec = {
+ license => \&_url_or_drop,
+ homepage => \&_url_or_drop,
+ bugtracker => \&_url_or_drop,
+ repository => \&_url_or_drop,
+ ':custom' => \&_keep,
+};
+
+sub _resources_1_3 {
+ my (undef, undef, $meta, $version) = @_;
+ return unless exists $meta->{resources};
+ return _convert($meta->{resources}, $resource1_spec);
+}
+
+*_resources_1_4 = *_resources_1_3;
+
+sub _resources_1_2 {
+ my (undef, undef, $meta) = @_;
+ my $resources = $meta->{resources} || {};
+ if ( $meta->{license_url} && ! $resources->{license} ) {
+ $resources->{license} = $meta->{license_url}
+ if _is_urlish($meta->{license_url});
+ }
+ return unless keys %$resources;
+ return _convert($resources, $resource1_spec);
+}
+
+my $resource_downgrade_spec = {
+ license => sub { return ref $_[0] ? $_[0]->[0] : $_[0] },
+ homepage => \&_url_or_drop,
+ bugtracker => sub { return $_[0]->{web} },
+ repository => sub { return $_[0]->{url} || $_[0]->{web} },
+ ':custom' => \&_no_prefix_ucfirst_custom,
+};
+
+sub _downgrade_resources {
+ my (undef, undef, $meta, $version) = @_;
+ return unless exists $meta->{resources};
+ return _convert($meta->{resources}, $resource_downgrade_spec);
+}
+
+sub _release_status {
+ my ($element, undef, $meta) = @_;
+ return $element if $element && $element =~ m{\A(?:stable|testing|unstable)\z};
+ return _release_status_from_version(undef, undef, $meta);
+}
+
+sub _release_status_from_version {
+ my (undef, undef, $meta) = @_;
+ my $version = $meta->{version} || '';
+ return ( $version =~ /_/ ) ? 'testing' : 'stable';
+}
+
+my $provides_spec = {
+ file => \&_keep,
+ version => \&_keep,
+};
+
+my $provides_spec_2 = {
+ file => \&_keep,
+ version => \&_keep,
+ ':custom' => \&_prefix_custom,
+};
+
+sub _provides {
+ my ($element, $key, $meta, $to_version) = @_;
+ return unless defined $element && ref $element eq 'HASH';
+ my $spec = $to_version == 2 ? $provides_spec_2 : $provides_spec;
+ my $new_data = {};
+ for my $k ( keys %$element ) {
+ $new_data->{$k} = _convert($element->{$k}, $spec, $to_version);
+ $new_data->{$k}{version} = _clean_version($element->{$k}{version})
+ if exists $element->{$k}{version};
+ }
+ return $new_data;
+}
+
+sub _convert {
+ my ($data, $spec, $to_version, $is_fragment) = @_;
+
+ my $new_data = {};
+ for my $key ( keys %$spec ) {
+ next if $key eq ':custom' || $key eq ':drop';
+ next unless my $fcn = $spec->{$key};
+ if ( $is_fragment && $key eq 'generated_by' ) {
+ $fcn = \&_keep;
+ }
+ die "spec for '$key' is not a coderef"
+ unless ref $fcn && ref $fcn eq 'CODE';
+ my $new_value = $fcn->($data->{$key}, $key, $data, $to_version);
+ $new_data->{$key} = $new_value if defined $new_value;
+ }
+
+ my $drop_list = $spec->{':drop'};
+ my $customizer = $spec->{':custom'} || \&_keep;
+
+ for my $key ( keys %$data ) {
+ next if $drop_list && grep { $key eq $_ } @$drop_list;
+ next if exists $spec->{$key}; # we handled it
+ $new_data->{ $customizer->($key) } = $data->{$key};
+ }
+
+ return $new_data;
+}
+
+#--------------------------------------------------------------------------#
+# define converters for each conversion
+#--------------------------------------------------------------------------#
+
+# each converts from prior version
+# special ":custom" field is used for keys not recognized in spec
+my %up_convert = (
+ '2-from-1.4' => {
+ # PRIOR MANDATORY
+ 'abstract' => \&_keep_or_unknown,
+ 'author' => \&_author_list,
+ 'generated_by' => \&_generated_by,
+ 'license' => \&_license_2,
+ 'meta-spec' => \&_change_meta_spec,
+ 'name' => \&_keep,
+ 'version' => \&_keep,
+ # CHANGED TO MANDATORY
+ 'dynamic_config' => \&_keep_or_one,
+ # ADDED MANDATORY
+ 'release_status' => \&_release_status,
+ # PRIOR OPTIONAL
+ 'keywords' => \&_keep,
+ 'no_index' => \&_no_index_directory,
+ 'optional_features' => \&_upgrade_optional_features,
+ 'provides' => \&_provides,
+ 'resources' => \&_upgrade_resources_2,
+ # ADDED OPTIONAL
+ 'description' => \&_keep,
+ 'prereqs' => \&_prereqs_from_1,
+
+ # drop these deprecated fields, but only after we convert
+ ':drop' => [ qw(
+ build_requires
+ configure_requires
+ conflicts
+ distribution_type
+ license_url
+ private
+ recommends
+ requires
+ ) ],
+
+ # other random keys need x_ prefixing
+ ':custom' => \&_prefix_custom,
+ },
+ '1.4-from-1.3' => {
+ # PRIOR MANDATORY
+ 'abstract' => \&_keep_or_unknown,
+ 'author' => \&_author_list,
+ 'generated_by' => \&_generated_by,
+ 'license' => \&_license_1,
+ 'meta-spec' => \&_change_meta_spec,
+ 'name' => \&_keep,
+ 'version' => \&_keep,
+ # PRIOR OPTIONAL
+ 'build_requires' => \&_version_map,
+ 'conflicts' => \&_version_map,
+ 'distribution_type' => \&_keep,
+ 'dynamic_config' => \&_keep_or_one,
+ 'keywords' => \&_keep,
+ 'no_index' => \&_no_index_directory,
+ 'optional_features' => \&_optional_features_1_4,
+ 'provides' => \&_provides,
+ 'recommends' => \&_version_map,
+ 'requires' => \&_version_map,
+ 'resources' => \&_resources_1_4,
+ # ADDED OPTIONAL
+ 'configure_requires' => \&_keep,
+
+ # drop these deprecated fields, but only after we convert
+ ':drop' => [ qw(
+ license_url
+ private
+ )],
+
+ # other random keys are OK if already valid
+ ':custom' => \&_keep
+ },
+ '1.3-from-1.2' => {
+ # PRIOR MANDATORY
+ 'abstract' => \&_keep_or_unknown,
+ 'author' => \&_author_list,
+ 'generated_by' => \&_generated_by,
+ 'license' => \&_license_1,
+ 'meta-spec' => \&_change_meta_spec,
+ 'name' => \&_keep,
+ 'version' => \&_keep,
+ # PRIOR OPTIONAL
+ 'build_requires' => \&_version_map,
+ 'conflicts' => \&_version_map,
+ 'distribution_type' => \&_keep,
+ 'dynamic_config' => \&_keep_or_one,
+ 'keywords' => \&_keep,
+ 'no_index' => \&_no_index_directory,
+ 'optional_features' => \&_optional_features_as_map,
+ 'provides' => \&_provides,
+ 'recommends' => \&_version_map,
+ 'requires' => \&_version_map,
+ 'resources' => \&_resources_1_3,
+
+ # drop these deprecated fields, but only after we convert
+ ':drop' => [ qw(
+ license_url
+ private
+ )],
+
+ # other random keys are OK if already valid
+ ':custom' => \&_keep
+ },
+ '1.2-from-1.1' => {
+ # PRIOR MANDATORY
+ 'version' => \&_keep,
+ # CHANGED TO MANDATORY
+ 'license' => \&_license_1,
+ 'name' => \&_keep,
+ 'generated_by' => \&_generated_by,
+ # ADDED MANDATORY
+ 'abstract' => \&_keep_or_unknown,
+ 'author' => \&_author_list,
+ 'meta-spec' => \&_change_meta_spec,
+ # PRIOR OPTIONAL
+ 'build_requires' => \&_version_map,
+ 'conflicts' => \&_version_map,
+ 'distribution_type' => \&_keep,
+ 'dynamic_config' => \&_keep_or_one,
+ 'recommends' => \&_version_map,
+ 'requires' => \&_version_map,
+ # ADDED OPTIONAL
+ 'keywords' => \&_keep,
+ 'no_index' => \&_no_index_1_2,
+ 'optional_features' => \&_optional_features_as_map,
+ 'provides' => \&_provides,
+ 'resources' => \&_resources_1_2,
+
+ # drop these deprecated fields, but only after we convert
+ ':drop' => [ qw(
+ license_url
+ private
+ )],
+
+ # other random keys are OK if already valid
+ ':custom' => \&_keep
+ },
+ '1.1-from-1.0' => {
+ # CHANGED TO MANDATORY
+ 'version' => \&_keep,
+ # IMPLIED MANDATORY
+ 'name' => \&_keep,
+ # PRIOR OPTIONAL
+ 'build_requires' => \&_version_map,
+ 'conflicts' => \&_version_map,
+ 'distribution_type' => \&_keep,
+ 'dynamic_config' => \&_keep_or_one,
+ 'generated_by' => \&_generated_by,
+ 'license' => \&_license_1,
+ 'recommends' => \&_version_map,
+ 'requires' => \&_version_map,
+ # ADDED OPTIONAL
+ 'license_url' => \&_url_or_drop,
+ 'private' => \&_keep,
+
+ # other random keys are OK if already valid
+ ':custom' => \&_keep
+ },
+);
+
+my %down_convert = (
+ '1.4-from-2' => {
+ # MANDATORY
+ 'abstract' => \&_keep_or_unknown,
+ 'author' => \&_author_list,
+ 'generated_by' => \&_generated_by,
+ 'license' => \&_downgrade_license,
+ 'meta-spec' => \&_change_meta_spec,
+ 'name' => \&_keep,
+ 'version' => \&_keep,
+ # OPTIONAL
+ 'build_requires' => \&_get_build_requires,
+ 'configure_requires' => \&_get_configure_requires,
+ 'conflicts' => \&_get_conflicts,
+ 'distribution_type' => \&_keep,
+ 'dynamic_config' => \&_keep_or_one,
+ 'keywords' => \&_keep,
+ 'no_index' => \&_no_index_directory,
+ 'optional_features' => \&_downgrade_optional_features,
+ 'provides' => \&_provides,
+ 'recommends' => \&_get_recommends,
+ 'requires' => \&_get_requires,
+ 'resources' => \&_downgrade_resources,
+
+ # drop these unsupported fields (after conversion)
+ ':drop' => [ qw(
+ description
+ prereqs
+ release_status
+ )],
+
+ # custom keys will be left unchanged
+ ':custom' => \&_keep
+ },
+ '1.3-from-1.4' => {
+ # MANDATORY
+ 'abstract' => \&_keep_or_unknown,
+ 'author' => \&_author_list,
+ 'generated_by' => \&_generated_by,
+ 'license' => \&_license_1,
+ 'meta-spec' => \&_change_meta_spec,
+ 'name' => \&_keep,
+ 'version' => \&_keep,
+ # OPTIONAL
+ 'build_requires' => \&_version_map,
+ 'conflicts' => \&_version_map,
+ 'distribution_type' => \&_keep,
+ 'dynamic_config' => \&_keep_or_one,
+ 'keywords' => \&_keep,
+ 'no_index' => \&_no_index_directory,
+ 'optional_features' => \&_optional_features_as_map,
+ 'provides' => \&_provides,
+ 'recommends' => \&_version_map,
+ 'requires' => \&_version_map,
+ 'resources' => \&_resources_1_3,
+
+ # drop these unsupported fields, but only after we convert
+ ':drop' => [ qw(
+ configure_requires
+ )],
+
+ # other random keys are OK if already valid
+ ':custom' => \&_keep,
+ },
+ '1.2-from-1.3' => {
+ # MANDATORY
+ 'abstract' => \&_keep_or_unknown,
+ 'author' => \&_author_list,
+ 'generated_by' => \&_generated_by,
+ 'license' => \&_license_1,
+ 'meta-spec' => \&_change_meta_spec,
+ 'name' => \&_keep,
+ 'version' => \&_keep,
+ # OPTIONAL
+ 'build_requires' => \&_version_map,
+ 'conflicts' => \&_version_map,
+ 'distribution_type' => \&_keep,
+ 'dynamic_config' => \&_keep_or_one,
+ 'keywords' => \&_keep,
+ 'no_index' => \&_no_index_1_2,
+ 'optional_features' => \&_optional_features_as_map,
+ 'provides' => \&_provides,
+ 'recommends' => \&_version_map,
+ 'requires' => \&_version_map,
+ 'resources' => \&_resources_1_3,
+
+ # other random keys are OK if already valid
+ ':custom' => \&_keep,
+ },
+ '1.1-from-1.2' => {
+ # MANDATORY
+ 'version' => \&_keep,
+ # IMPLIED MANDATORY
+ 'name' => \&_keep,
+ 'meta-spec' => \&_change_meta_spec,
+ # OPTIONAL
+ 'build_requires' => \&_version_map,
+ 'conflicts' => \&_version_map,
+ 'distribution_type' => \&_keep,
+ 'dynamic_config' => \&_keep_or_one,
+ 'generated_by' => \&_generated_by,
+ 'license' => \&_license_1,
+ 'private' => \&_keep,
+ 'recommends' => \&_version_map,
+ 'requires' => \&_version_map,
+
+ # drop unsupported fields
+ ':drop' => [ qw(
+ abstract
+ author
+ provides
+ no_index
+ keywords
+ resources
+ )],
+
+ # other random keys are OK if already valid
+ ':custom' => \&_keep,
+ },
+ '1.0-from-1.1' => {
+ # IMPLIED MANDATORY
+ 'name' => \&_keep,
+ 'meta-spec' => \&_change_meta_spec,
+ 'version' => \&_keep,
+ # PRIOR OPTIONAL
+ 'build_requires' => \&_version_map,
+ 'conflicts' => \&_version_map,
+ 'distribution_type' => \&_keep,
+ 'dynamic_config' => \&_keep_or_one,
+ 'generated_by' => \&_generated_by,
+ 'license' => \&_license_1,
+ 'recommends' => \&_version_map,
+ 'requires' => \&_version_map,
+
+ # other random keys are OK if already valid
+ ':custom' => \&_keep,
+ },
+);
+
+my %cleanup = (
+ '2' => {
+ # PRIOR MANDATORY
+ 'abstract' => \&_keep_or_unknown,
+ 'author' => \&_author_list,
+ 'generated_by' => \&_generated_by,
+ 'license' => \&_license_2,
+ 'meta-spec' => \&_change_meta_spec,
+ 'name' => \&_keep,
+ 'version' => \&_keep,
+ # CHANGED TO MANDATORY
+ 'dynamic_config' => \&_keep_or_one,
+ # ADDED MANDATORY
+ 'release_status' => \&_release_status,
+ # PRIOR OPTIONAL
+ 'keywords' => \&_keep,
+ 'no_index' => \&_no_index_directory,
+ 'optional_features' => \&_cleanup_optional_features_2,
+ 'provides' => \&_provides,
+ 'resources' => \&_cleanup_resources_2,
+ # ADDED OPTIONAL
+ 'description' => \&_keep,
+ 'prereqs' => \&_cleanup_prereqs,
+
+ # drop these deprecated fields, but only after we convert
+ ':drop' => [ qw(
+ build_requires
+ configure_requires
+ conflicts
+ distribution_type
+ license_url
+ private
+ recommends
+ requires
+ ) ],
+
+ # other random keys need x_ prefixing
+ ':custom' => \&_prefix_custom,
+ },
+ '1.4' => {
+ # PRIOR MANDATORY
+ 'abstract' => \&_keep_or_unknown,
+ 'author' => \&_author_list,
+ 'generated_by' => \&_generated_by,
+ 'license' => \&_license_1,
+ 'meta-spec' => \&_change_meta_spec,
+ 'name' => \&_keep,
+ 'version' => \&_keep,
+ # PRIOR OPTIONAL
+ 'build_requires' => \&_version_map,
+ 'conflicts' => \&_version_map,
+ 'distribution_type' => \&_keep,
+ 'dynamic_config' => \&_keep_or_one,
+ 'keywords' => \&_keep,
+ 'no_index' => \&_no_index_directory,
+ 'optional_features' => \&_optional_features_1_4,
+ 'provides' => \&_provides,
+ 'recommends' => \&_version_map,
+ 'requires' => \&_version_map,
+ 'resources' => \&_resources_1_4,
+ # ADDED OPTIONAL
+ 'configure_requires' => \&_keep,
+
+ # other random keys are OK if already valid
+ ':custom' => \&_keep
+ },
+ '1.3' => {
+ # PRIOR MANDATORY
+ 'abstract' => \&_keep_or_unknown,
+ 'author' => \&_author_list,
+ 'generated_by' => \&_generated_by,
+ 'license' => \&_license_1,
+ 'meta-spec' => \&_change_meta_spec,
+ 'name' => \&_keep,
+ 'version' => \&_keep,
+ # PRIOR OPTIONAL
+ 'build_requires' => \&_version_map,
+ 'conflicts' => \&_version_map,
+ 'distribution_type' => \&_keep,
+ 'dynamic_config' => \&_keep_or_one,
+ 'keywords' => \&_keep,
+ 'no_index' => \&_no_index_directory,
+ 'optional_features' => \&_optional_features_as_map,
+ 'provides' => \&_provides,
+ 'recommends' => \&_version_map,
+ 'requires' => \&_version_map,
+ 'resources' => \&_resources_1_3,
+
+ # other random keys are OK if already valid
+ ':custom' => \&_keep
+ },
+ '1.2' => {
+ # PRIOR MANDATORY
+ 'version' => \&_keep,
+ # CHANGED TO MANDATORY
+ 'license' => \&_license_1,
+ 'name' => \&_keep,
+ 'generated_by' => \&_generated_by,
+ # ADDED MANDATORY
+ 'abstract' => \&_keep_or_unknown,
+ 'author' => \&_author_list,
+ 'meta-spec' => \&_change_meta_spec,
+ # PRIOR OPTIONAL
+ 'build_requires' => \&_version_map,
+ 'conflicts' => \&_version_map,
+ 'distribution_type' => \&_keep,
+ 'dynamic_config' => \&_keep_or_one,
+ 'recommends' => \&_version_map,
+ 'requires' => \&_version_map,
+ # ADDED OPTIONAL
+ 'keywords' => \&_keep,
+ 'no_index' => \&_no_index_1_2,
+ 'optional_features' => \&_optional_features_as_map,
+ 'provides' => \&_provides,
+ 'resources' => \&_resources_1_2,
+
+ # other random keys are OK if already valid
+ ':custom' => \&_keep
+ },
+ '1.1' => {
+ # CHANGED TO MANDATORY
+ 'version' => \&_keep,
+ # IMPLIED MANDATORY
+ 'name' => \&_keep,
+ 'meta-spec' => \&_change_meta_spec,
+ # PRIOR OPTIONAL
+ 'build_requires' => \&_version_map,
+ 'conflicts' => \&_version_map,
+ 'distribution_type' => \&_keep,
+ 'dynamic_config' => \&_keep_or_one,
+ 'generated_by' => \&_generated_by,
+ 'license' => \&_license_1,
+ 'recommends' => \&_version_map,
+ 'requires' => \&_version_map,
+ # ADDED OPTIONAL
+ 'license_url' => \&_url_or_drop,
+ 'private' => \&_keep,
+
+ # other random keys are OK if already valid
+ ':custom' => \&_keep
+ },
+ '1.0' => {
+ # IMPLIED MANDATORY
+ 'name' => \&_keep,
+ 'meta-spec' => \&_change_meta_spec,
+ 'version' => \&_keep,
+ # IMPLIED OPTIONAL
+ 'build_requires' => \&_version_map,
+ 'conflicts' => \&_version_map,
+ 'distribution_type' => \&_keep,
+ 'dynamic_config' => \&_keep_or_one,
+ 'generated_by' => \&_generated_by,
+ 'license' => \&_license_1,
+ 'recommends' => \&_version_map,
+ 'requires' => \&_version_map,
+
+ # other random keys are OK if already valid
+ ':custom' => \&_keep,
+ },
+);
+
+# for a given field in a spec version, what fields will it feed
+# into in the *latest* spec (i.e. v2); meta-spec omitted because
+# we always expect a meta-spec to be generated
+my %fragments_generate = (
+ '2' => {
+ 'abstract' => 'abstract',
+ 'author' => 'author',
+ 'generated_by' => 'generated_by',
+ 'license' => 'license',
+ 'name' => 'name',
+ 'version' => 'version',
+ 'dynamic_config' => 'dynamic_config',
+ 'release_status' => 'release_status',
+ 'keywords' => 'keywords',
+ 'no_index' => 'no_index',
+ 'optional_features' => 'optional_features',
+ 'provides' => 'provides',
+ 'resources' => 'resources',
+ 'description' => 'description',
+ 'prereqs' => 'prereqs',
+ },
+ '1.4' => {
+ 'abstract' => 'abstract',
+ 'author' => 'author',
+ 'generated_by' => 'generated_by',
+ 'license' => 'license',
+ 'name' => 'name',
+ 'version' => 'version',
+ 'build_requires' => 'prereqs',
+ 'conflicts' => 'prereqs',
+ 'distribution_type' => 'distribution_type',
+ 'dynamic_config' => 'dynamic_config',
+ 'keywords' => 'keywords',
+ 'no_index' => 'no_index',
+ 'optional_features' => 'optional_features',
+ 'provides' => 'provides',
+ 'recommends' => 'prereqs',
+ 'requires' => 'prereqs',
+ 'resources' => 'resources',
+ 'configure_requires' => 'prereqs',
+ },
+);
+# this is not quite true but will work well enough
+# as 1.4 is a superset of earlier ones
+$fragments_generate{$_} = $fragments_generate{'1.4'} for qw/1.3 1.2 1.1 1.0/;
+
+#--------------------------------------------------------------------------#
+# Code
+#--------------------------------------------------------------------------#
+
+#pod =method new
+#pod
+#pod my $cmc = CPAN::Meta::Converter->new( $struct );
+#pod
+#pod The constructor should be passed a valid metadata structure but invalid
+#pod structures are accepted. If no meta-spec version is provided, version 1.0 will
+#pod be assumed.
+#pod
+#pod Optionally, you can provide a C<default_version> argument after C<$struct>:
+#pod
+#pod my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" );
+#pod
+#pod This is only needed when converting a metadata fragment that does not include a
+#pod C<meta-spec> field.
+#pod
+#pod =cut
+
+sub new {
+ my ($class,$data,%args) = @_;
+
+ # create an attributes hash
+ my $self = {
+ 'data' => $data,
+ 'spec' => _extract_spec_version($data, $args{default_version}),
+ };
+
+ # create the object
+ return bless $self, $class;
+}
+
+sub _extract_spec_version {
+ my ($data, $default) = @_;
+ my $spec = $data->{'meta-spec'};
+
+ # is meta-spec there and valid?
+ return( $default || "1.0" ) unless defined $spec && ref $spec eq 'HASH'; # before meta-spec?
+
+ # does the version key look like a valid version?
+ my $v = $spec->{version};
+ if ( defined $v && $v =~ /^\d+(?:\.\d+)?$/ ) {
+ return $v if defined $v && grep { $v eq $_ } keys %known_specs; # known spec
+ return $v+0 if defined $v && grep { $v == $_ } keys %known_specs; # 2.0 => 2
+ }
+
+ # otherwise, use heuristics: look for 1.x vs 2.0 fields
+ return "2" if exists $data->{prereqs};
+ return "1.4" if exists $data->{configure_requires};
+ return( $default || "1.2" ); # when meta-spec was first defined
+}
+
+#pod =method convert
+#pod
+#pod my $new_struct = $cmc->convert( version => "2" );
+#pod
+#pod Returns a new hash reference with the metadata converted to a different form.
+#pod C<convert> will die if any conversion/standardization still results in an
+#pod invalid structure.
+#pod
+#pod Valid parameters include:
+#pod
+#pod =over
+#pod
+#pod =item *
+#pod
+#pod C<version> -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2").
+#pod Defaults to the latest version of the CPAN Meta Spec.
+#pod
+#pod =back
+#pod
+#pod Conversion proceeds through each version in turn. For example, a version 1.2
+#pod structure might be converted to 1.3 then 1.4 then finally to version 2. The
+#pod conversion process attempts to clean-up simple errors and standardize data.
+#pod For example, if C<author> is given as a scalar, it will converted to an array
+#pod reference containing the item. (Converting a structure to its own version will
+#pod also clean-up and standardize.)
+#pod
+#pod When data are cleaned and standardized, missing or invalid fields will be
+#pod replaced with sensible defaults when possible. This may be lossy or imprecise.
+#pod For example, some badly structured META.yml files on CPAN have prerequisite
+#pod modules listed as both keys and values:
+#pod
+#pod requires => { 'Foo::Bar' => 'Bam::Baz' }
+#pod
+#pod These would be split and each converted to a prerequisite with a minimum
+#pod version of zero.
+#pod
+#pod When some mandatory fields are missing or invalid, the conversion will attempt
+#pod to provide a sensible default or will fill them with a value of 'unknown'. For
+#pod example a missing or unrecognized C<license> field will result in a C<license>
+#pod field of 'unknown'. Fields that may get an 'unknown' include:
+#pod
+#pod =for :list
+#pod * abstract
+#pod * author
+#pod * license
+#pod
+#pod =cut
+
+sub convert {
+ my ($self, %args) = @_;
+ my $args = { %args };
+
+ my $new_version = $args->{version} || $HIGHEST;
+ my $is_fragment = $args->{is_fragment};
+
+ my ($old_version) = $self->{spec};
+ my $converted = _dclone($self->{data});
+
+ if ( $old_version == $new_version ) {
+ $converted = _convert( $converted, $cleanup{$old_version}, $old_version, $is_fragment );
+ unless ( $args->{is_fragment} ) {
+ my $cmv = CPAN::Meta::Validator->new( $converted );
+ unless ( $cmv->is_valid ) {
+ my $errs = join("\n", $cmv->errors);
+ die "Failed to clean-up $old_version metadata. Errors:\n$errs\n";
+ }
+ }
+ return $converted;
+ }
+ elsif ( $old_version > $new_version ) {
+ my @vers = sort { $b <=> $a } keys %known_specs;
+ for my $i ( 0 .. $#vers-1 ) {
+ next if $vers[$i] > $old_version;
+ last if $vers[$i+1] < $new_version;
+ my $spec_string = "$vers[$i+1]-from-$vers[$i]";
+ $converted = _convert( $converted, $down_convert{$spec_string}, $vers[$i+1], $is_fragment );
+ unless ( $args->{is_fragment} ) {
+ my $cmv = CPAN::Meta::Validator->new( $converted );
+ unless ( $cmv->is_valid ) {
+ my $errs = join("\n", $cmv->errors);
+ die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
+ }
+ }
+ }
+ return $converted;
+ }
+ else {
+ my @vers = sort { $a <=> $b } keys %known_specs;
+ for my $i ( 0 .. $#vers-1 ) {
+ next if $vers[$i] < $old_version;
+ last if $vers[$i+1] > $new_version;
+ my $spec_string = "$vers[$i+1]-from-$vers[$i]";
+ $converted = _convert( $converted, $up_convert{$spec_string}, $vers[$i+1], $is_fragment );
+ unless ( $args->{is_fragment} ) {
+ my $cmv = CPAN::Meta::Validator->new( $converted );
+ unless ( $cmv->is_valid ) {
+ my $errs = join("\n", $cmv->errors);
+ die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
+ }
+ }
+ }
+ return $converted;
+ }
+}
+
+#pod =method upgrade_fragment
+#pod
+#pod my $new_struct = $cmc->upgrade_fragment;
+#pod
+#pod Returns a new hash reference with the metadata converted to the latest version
+#pod of the CPAN Meta Spec. No validation is done on the result -- you must
+#pod validate after merging fragments into a complete metadata document.
+#pod
+#pod Available since version 2.141170.
+#pod
+#pod =cut
+
+sub upgrade_fragment {
+ my ($self) = @_;
+ my ($old_version) = $self->{spec};
+ my %expected =
+ map {; $_ => 1 }
+ grep { defined }
+ map { $fragments_generate{$old_version}{$_} }
+ keys %{ $self->{data} };
+ my $converted = $self->convert( version => $HIGHEST, is_fragment => 1 );
+ for my $key ( keys %$converted ) {
+ next if $key =~ /^x_/i || $key eq 'meta-spec';
+ delete $converted->{$key} unless $expected{$key};
+ }
+ return $converted;
+}
+
+1;
+
+# ABSTRACT: Convert CPAN distribution metadata structures
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+CPAN::Meta::Converter - Convert CPAN distribution metadata structures
+
+=head1 VERSION
+
+version 2.150010
+
+=head1 SYNOPSIS
+
+ my $struct = decode_json_file('META.json');
+
+ my $cmc = CPAN::Meta::Converter->new( $struct );
+
+ my $new_struct = $cmc->convert( version => "2" );
+
+=head1 DESCRIPTION
+
+This module converts CPAN Meta structures from one form to another. The
+primary use is to convert older structures to the most modern version of
+the specification, but other transformations may be implemented in the
+future as needed. (E.g. stripping all custom fields or stripping all
+optional fields.)
+
+=head1 METHODS
+
+=head2 new
+
+ my $cmc = CPAN::Meta::Converter->new( $struct );
+
+The constructor should be passed a valid metadata structure but invalid
+structures are accepted. If no meta-spec version is provided, version 1.0 will
+be assumed.
+
+Optionally, you can provide a C<default_version> argument after C<$struct>:
+
+ my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" );
+
+This is only needed when converting a metadata fragment that does not include a
+C<meta-spec> field.
+
+=head2 convert
+
+ my $new_struct = $cmc->convert( version => "2" );
+
+Returns a new hash reference with the metadata converted to a different form.
+C<convert> will die if any conversion/standardization still results in an
+invalid structure.
+
+Valid parameters include:
+
+=over
+
+=item *
+
+C<version> -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2").
+Defaults to the latest version of the CPAN Meta Spec.
+
+=back
+
+Conversion proceeds through each version in turn. For example, a version 1.2
+structure might be converted to 1.3 then 1.4 then finally to version 2. The
+conversion process attempts to clean-up simple errors and standardize data.
+For example, if C<author> is given as a scalar, it will converted to an array
+reference containing the item. (Converting a structure to its own version will
+also clean-up and standardize.)
+
+When data are cleaned and standardized, missing or invalid fields will be
+replaced with sensible defaults when possible. This may be lossy or imprecise.
+For example, some badly structured META.yml files on CPAN have prerequisite
+modules listed as both keys and values:
+
+ requires => { 'Foo::Bar' => 'Bam::Baz' }
+
+These would be split and each converted to a prerequisite with a minimum
+version of zero.
+
+When some mandatory fields are missing or invalid, the conversion will attempt
+to provide a sensible default or will fill them with a value of 'unknown'. For
+example a missing or unrecognized C<license> field will result in a C<license>
+field of 'unknown'. Fields that may get an 'unknown' include:
+
+=over 4
+
+=item *
+
+abstract
+
+=item *
+
+author
+
+=item *
+
+license
+
+=back
+
+=head2 upgrade_fragment
+
+ my $new_struct = $cmc->upgrade_fragment;
+
+Returns a new hash reference with the metadata converted to the latest version
+of the CPAN Meta Spec. No validation is done on the result -- you must
+validate after merging fragments into a complete metadata document.
+
+Available since version 2.141170.
+
+=head1 BUGS
+
+Please report any bugs or feature using the CPAN Request Tracker.
+Bugs can be submitted through the web interface at
+L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
+
+When submitting a bug or request, please include a test-file or a patch to an
+existing test-file that illustrates the bug or desired feature.
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+David Golden <dagolden@cpan.org>
+
+=item *
+
+Ricardo Signes <rjbs@cpan.org>
+
+=item *
+
+Adam Kennedy <adamk@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
+
+__END__
+
+
+# vim: ts=2 sts=2 sw=2 et :
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Feature.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Feature.pm
new file mode 100644
index 0000000000..f6103495c7
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Feature.pm
@@ -0,0 +1,153 @@
+use 5.006;
+use strict;
+use warnings;
+package CPAN::Meta::Feature;
+
+our $VERSION = '2.150010';
+
+use CPAN::Meta::Prereqs;
+
+#pod =head1 DESCRIPTION
+#pod
+#pod A CPAN::Meta::Feature object describes an optional feature offered by a CPAN
+#pod distribution and specified in the distribution's F<META.json> (or F<META.yml>)
+#pod file.
+#pod
+#pod For the most part, this class will only be used when operating on the result of
+#pod the C<feature> or C<features> methods on a L<CPAN::Meta> object.
+#pod
+#pod =method new
+#pod
+#pod my $feature = CPAN::Meta::Feature->new( $identifier => \%spec );
+#pod
+#pod This returns a new Feature object. The C<%spec> argument to the constructor
+#pod should be the same as the value of the C<optional_feature> entry in the
+#pod distmeta. It must contain entries for C<description> and C<prereqs>.
+#pod
+#pod =cut
+
+sub new {
+ my ($class, $identifier, $spec) = @_;
+
+ my %guts = (
+ identifier => $identifier,
+ description => $spec->{description},
+ prereqs => CPAN::Meta::Prereqs->new($spec->{prereqs}),
+ );
+
+ bless \%guts => $class;
+}
+
+#pod =method identifier
+#pod
+#pod This method returns the feature's identifier.
+#pod
+#pod =cut
+
+sub identifier { $_[0]{identifier} }
+
+#pod =method description
+#pod
+#pod This method returns the feature's long description.
+#pod
+#pod =cut
+
+sub description { $_[0]{description} }
+
+#pod =method prereqs
+#pod
+#pod This method returns the feature's prerequisites as a L<CPAN::Meta::Prereqs>
+#pod object.
+#pod
+#pod =cut
+
+sub prereqs { $_[0]{prereqs} }
+
+1;
+
+# ABSTRACT: an optional feature provided by a CPAN distribution
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+CPAN::Meta::Feature - an optional feature provided by a CPAN distribution
+
+=head1 VERSION
+
+version 2.150010
+
+=head1 DESCRIPTION
+
+A CPAN::Meta::Feature object describes an optional feature offered by a CPAN
+distribution and specified in the distribution's F<META.json> (or F<META.yml>)
+file.
+
+For the most part, this class will only be used when operating on the result of
+the C<feature> or C<features> methods on a L<CPAN::Meta> object.
+
+=head1 METHODS
+
+=head2 new
+
+ my $feature = CPAN::Meta::Feature->new( $identifier => \%spec );
+
+This returns a new Feature object. The C<%spec> argument to the constructor
+should be the same as the value of the C<optional_feature> entry in the
+distmeta. It must contain entries for C<description> and C<prereqs>.
+
+=head2 identifier
+
+This method returns the feature's identifier.
+
+=head2 description
+
+This method returns the feature's long description.
+
+=head2 prereqs
+
+This method returns the feature's prerequisites as a L<CPAN::Meta::Prereqs>
+object.
+
+=head1 BUGS
+
+Please report any bugs or feature using the CPAN Request Tracker.
+Bugs can be submitted through the web interface at
+L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
+
+When submitting a bug or request, please include a test-file or a patch to an
+existing test-file that illustrates the bug or desired feature.
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+David Golden <dagolden@cpan.org>
+
+=item *
+
+Ricardo Signes <rjbs@cpan.org>
+
+=item *
+
+Adam Kennedy <adamk@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
+
+__END__
+
+
+# vim: ts=2 sts=2 sw=2 et :
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History.pm
new file mode 100644
index 0000000000..aeeade94a3
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History.pm
@@ -0,0 +1,320 @@
+# vi:tw=72
+use 5.006;
+use strict;
+use warnings;
+package CPAN::Meta::History;
+
+our $VERSION = '2.150010';
+
+1;
+
+# ABSTRACT: history of CPAN Meta Spec changes
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+CPAN::Meta::History - history of CPAN Meta Spec changes
+
+=head1 VERSION
+
+version 2.150010
+
+=head1 DESCRIPTION
+
+The CPAN Meta Spec has gone through several iterations. It was
+originally written in HTML and later revised into POD (though published
+in HTML generated from the POD). Fields were added, removed or changed,
+sometimes by design and sometimes to reflect real-world usage after the
+fact.
+
+This document reconstructs the history of the CPAN Meta Spec based on
+change logs, repository commit messages and the published HTML files.
+In some cases, particularly prior to version 1.2, the exact version
+when certain fields were introduced or changed is inconsistent between
+sources. When in doubt, the published HTML files for versions 1.0 to
+1.4 as they existed when version 2 was developed are used as the
+definitive source.
+
+Starting with version 2, the specification document is part of the
+CPAN-Meta distribution and will be published on CPAN as
+L<CPAN::Meta::Spec>.
+
+Going forward, specification version numbers will be integers and
+decimal portions will correspond to a release date for the CPAN::Meta
+library.
+
+=head1 HISTORY
+
+=head2 Version 2
+
+April 2010
+
+=over
+
+=item *
+
+Revised spec examples as perl data structures rather than YAML
+
+=item *
+
+Switched to JSON serialization from YAML
+
+=item *
+
+Specified allowed version number formats
+
+=item *
+
+Replaced 'requires', 'build_requires', 'configure_requires',
+'recommends' and 'conflicts' with new 'prereqs' data structure divided
+by I<phase> (configure, build, test, runtime, etc.) and I<relationship>
+(requires, recommends, suggests, conflicts)
+
+=item *
+
+Added support for 'develop' phase for requirements for maintaining
+a list of authoring tools
+
+=item *
+
+Changed 'license' to a list and revised the set of valid licenses
+
+=item *
+
+Made 'dynamic_config' mandatory to reduce confusion
+
+=item *
+
+Changed 'resources' subkey 'repository' to a hash that clarifies
+repository type, url for browsing and url for checkout
+
+=item *
+
+Changed 'resources' subkey 'bugtracker' to a hash for either web
+or mailto resource
+
+=item *
+
+Changed specification of 'optional_features':
+
+=over
+
+=item *
+
+Added formal specification and usage guide instead of just example
+
+=item *
+
+Changed to use new prereqs data structure instead of individual keys
+
+=back
+
+=item *
+
+Clarified intended use of 'author' as generalized contact list
+
+=item *
+
+Added 'release_status' field to indicate stable, testing or unstable
+status to provide hints to indexers
+
+=item *
+
+Added 'description' field for a longer description of the distribution
+
+=item *
+
+Formalized use of "x_" or "X_" for all custom keys not listed in the
+official spec
+
+=back
+
+=head2 Version 1.4
+
+June 2008
+
+=over
+
+=item *
+
+Noted explicit support for 'perl' in prerequisites
+
+=item *
+
+Added 'configure_requires' prerequisite type
+
+=item *
+
+Changed 'optional_features'
+
+=over
+
+=item *
+
+Example corrected to show map of maps instead of list of maps
+(though descriptive text said 'map' even in v1.3)
+
+=item *
+
+Removed 'requires_packages', 'requires_os' and 'excluded_os'
+as valid subkeys
+
+=back
+
+=back
+
+=head2 Version 1.3
+
+November 2006
+
+=over
+
+=item *
+
+Added 'no_index' subkey 'directory' and removed 'dir' to match actual
+usage in the wild
+
+=item *
+
+Added a 'repository' subkey to 'resources'
+
+=back
+
+=head2 Version 1.2
+
+August 2005
+
+=over
+
+=item *
+
+Re-wrote and restructured spec in POD syntax
+
+=item *
+
+Changed 'name' to be mandatory
+
+=item *
+
+Changed 'generated_by' to be mandatory
+
+=item *
+
+Changed 'license' to be mandatory
+
+=item *
+
+Added version range specifications for prerequisites
+
+=item *
+
+Added required 'abstract' field
+
+=item *
+
+Added required 'author' field
+
+=item *
+
+Added required 'meta-spec' field to define 'version' (and 'url') of the
+CPAN Meta Spec used for metadata
+
+=item *
+
+Added 'provides' field
+
+=item *
+
+Added 'no_index' field and deprecated 'private' field. 'no_index'
+subkeys include 'file', 'dir', 'package' and 'namespace'
+
+=item *
+
+Added 'keywords' field
+
+=item *
+
+Added 'resources' field with subkeys 'homepage', 'license', and
+'bugtracker'
+
+=item *
+
+Added 'optional_features' field as an alternate under 'recommends'.
+Includes 'description', 'requires', 'build_requires', 'conflicts',
+'requires_packages', 'requires_os' and 'excluded_os' as valid subkeys
+
+=item *
+
+Removed 'license_uri' field
+
+=back
+
+=head2 Version 1.1
+
+May 2003
+
+=over
+
+=item *
+
+Changed 'version' to be mandatory
+
+=item *
+
+Added 'private' field
+
+=item *
+
+Added 'license_uri' field
+
+=back
+
+=head2 Version 1.0
+
+March 2003
+
+=over
+
+=item *
+
+Original release (in HTML format only)
+
+=item *
+
+Included 'name', 'version', 'license', 'distribution_type', 'requires',
+'recommends', 'build_requires', 'conflicts', 'dynamic_config',
+'generated_by'
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+David Golden <dagolden@cpan.org>
+
+=item *
+
+Ricardo Signes <rjbs@cpan.org>
+
+=item *
+
+Adam Kennedy <adamk@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_0.pod b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_0.pod
new file mode 100644
index 0000000000..5932f5a6e7
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_0.pod
@@ -0,0 +1,247 @@
+=for :stopwords DOAP RDF
+
+=head1 NAME
+
+CPAN::Meta::History::Meta_1_0 - Version 1.0 metadata specification for META.yml
+
+=head1 PREFACE
+
+This is a historical copy of the version 1.0 specification for F<META.yml>
+files, copyright by Ken Williams and licensed under the same terms as Perl
+itself.
+
+Modifications from the original:
+
+=over
+
+=item *
+
+Conversion from the original HTML to POD format
+
+=item *
+
+Include list of valid licenses from L<Module::Build> 0.17 rather than
+linking to the module, with minor updates to text and links to reflect
+versions at the time of publication.
+
+=item *
+
+Fixed some dead links to point to active resources.
+
+=back
+
+=head1 DESCRIPTION
+
+This document describes version 1.0 of the F<META.yml> specification.
+
+The META.yml file describes important properties of contributed Perl
+distributions such as the ones found on L<CPAN|http://www.cpan.org>. It is
+typically created by tools like L<Module::Build> and L<ExtUtils::MakeMaker>.
+
+The fields in the F<META.yml> file are meant to be helpful to people
+maintaining module collections (like CPAN), for people writing
+installation tools (like L<CPAN> or L<CPANPLUS>), or just people who want to
+know some stuff about a distribution before downloading it and starting to
+install it.
+
+=head1 Format
+
+F<META.yml> files are written in the L<YAML|http://www.yaml.org/> format. The
+reasons we chose YAML instead of, say, XML or Data::Dumper are discussed in
+L<this thread|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg406.html>
+on the MakeMaker mailing list.
+
+The first line of a F<META.yml> file should be a valid
+L<YAML document header|http://yaml.org/spec/history/2002-10-31.html#syntax-document>
+like C<"--- #YAML:1.0">
+
+=head1 Fields
+
+The rest of the META.yml file is one big YAML
+L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>,
+whose keys are described here.
+
+=over 4
+
+=item name
+
+Example: C<Module-Build>
+
+The name of the distribution. Often created by taking the "main
+module" in the distribution and changing "::" to "-". Sometimes it's
+completely different, however, as in the case of the
+L<libwww-perl|http://search.cpan.org/author/GAAS/libwww-perl/> distribution.
+
+=item version
+
+Example: C<0.16>
+
+The version of the distribution to which the META.yml file refers.
+
+=item license
+
+Example: C<perl>
+
+The license under which this distribution may be used and
+redistributed.
+
+Must be one of the following licenses:
+
+=over 4
+
+=item perl
+
+The distribution may be copied and redistributed under the same terms as perl
+itself (this is by far the most common licensing option for modules on CPAN).
+This is a dual license, in which the user may choose between either the GPL
+version 1 or the Artistic version 1 license.
+
+=item gpl
+
+The distribution is distributed under the terms of the GNU General Public
+License version 2 (L<http://opensource.org/licenses/GPL-2.0>).
+
+=item lgpl
+
+The distribution is distributed under the terms of the GNU Lesser General
+Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).
+
+=item artistic
+
+The distribution is licensed under the Artistic License version 1, as specified
+by the Artistic file in the standard perl distribution
+(L<http://opensource.org/licenses/Artistic-Perl-1.0>).
+
+=item bsd
+
+The distribution is licensed under the BSD 3-Clause License
+(L<http://opensource.org/licenses/BSD-3-Clause>).
+
+=item open_source
+
+The distribution is licensed under some other Open Source Initiative-approved
+license listed at L<http://www.opensource.org/licenses/>.
+
+=item unrestricted
+
+The distribution is licensed under a license that is B<not> approved by
+L<www.opensource.org|http://www.opensource.org/> but that allows distribution
+without restrictions.
+
+=item restrictive
+
+The distribution may not be redistributed without special permission from the
+author and/or copyright holder.
+
+=back
+
+=item distribution_type
+
+Example: C<module>
+
+What kind of stuff is contained in this distribution. Most things on
+CPAN are C<module>s (which can also mean a collection of
+modules), but some things are C<script>s.
+
+=item requires
+
+Example:
+
+ Data::Dumper: 0
+ File::Find: 1.03
+
+A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
+indicating the Perl modules this distribution requires for proper
+operation. The keys are the module names, and the values are version
+specifications as described in the
+L<documentation for Module::Build's "requires" parameter|Module::Build::API/requires>.
+
+I<Note: the exact nature of the fancy specifications like
+C<< ">= 1.2, != 1.5, < 2.0" >> is subject to
+change. Advance notice will be given here. The simple specifications
+like C<"1.2"> will not change in format.>
+
+=item recommends
+
+Example:
+
+ Data::Dumper: 0
+ File::Find: 1.03
+
+A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
+indicating the Perl modules this distribution recommends for enhanced
+operation.
+
+=item build_requires
+
+Example:
+
+ Data::Dumper: 0
+ File::Find: 1.03
+
+A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
+indicating the Perl modules required for building and/or testing of
+this distribution. These dependencies are not required after the
+module is installed.
+
+=item conflicts
+
+Example:
+
+ Data::Dumper: 0
+ File::Find: 1.03
+
+A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
+indicating the Perl modules that cannot be installed while this
+distribution is installed. This is a pretty uncommon situation.
+
+=item dynamic_config
+
+Example: C<0>
+
+A boolean flag indicating whether a F<Build.PL> or
+F<Makefile.PL> (or similar) must be executed, or whether this
+module can be built, tested and installed solely from consulting its
+metadata file. The main reason to set this to a true value if that
+your module performs some dynamic configuration (asking questions,
+sensing the environment, etc.) as part of its build/install process.
+
+Currently L<Module::Build> doesn't actually do anything with
+this flag - it's probably going to be up to higher-level tools like
+L<CPAN.pm|CPAN> to do something useful with it. It can potentially
+bring lots of security, packaging, and convenience improvements.
+
+=item generated_by
+
+Example: C<Module::Build version 0.16>
+
+Indicates the tool that was used to create this F<META.yml> file. It's
+good form to include both the name of the tool and its version, but
+this field is essentially opaque, at least for the moment.
+
+=back
+
+=head1 Related Projects
+
+=over 4
+
+=item DOAP
+
+An RDF vocabulary to describe software projects. L<http://usefulinc.com/doap>.
+
+=back
+
+=head1 History
+
+=over 4
+
+=item *
+
+B<March 14, 2003> (Pi day) - created version 1.0 of this document.
+
+=item *
+
+B<May 8, 2003> - added the "dynamic_config" field, which was missing from the
+initial version.
+
+=back
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_1.pod b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_1.pod
new file mode 100644
index 0000000000..e0428a5e83
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_1.pod
@@ -0,0 +1,309 @@
+=for :stopwords Ingy READMEs WTF licensure
+
+=head1 NAME
+
+CPAN::Meta::History::Meta_1_1 - Version 1.1 metadata specification for META.yml
+
+=head1 PREFACE
+
+This is a historical copy of the version 1.1 specification for F<META.yml>
+files, copyright by Ken Williams and licensed under the same terms as Perl
+itself.
+
+Modifications from the original:
+
+=over
+
+=item *
+
+Conversion from the original HTML to POD format
+
+=item *
+
+Include list of valid licenses from L<Module::Build> 0.18 rather than
+linking to the module, with minor updates to text and links to reflect
+versions at the time of publication.
+
+=item *
+
+Fixed some dead links to point to active resources.
+
+=back
+
+=head1 DESCRIPTION
+
+This document describes version 1.1 of the F<META.yml> specification.
+
+The F<META.yml> file describes important properties of contributed Perl
+distributions such as the ones found on L<CPAN|http://www.cpan.org>. It is
+typically created by tools like L<Module::Build> and L<ExtUtils::MakeMaker>.
+
+The fields in the F<META.yml> file are meant to be helpful to people
+maintaining module collections (like CPAN), for people writing
+installation tools (like L<CPAN> or L<CPANPLUS>), or just people who want to
+know some stuff about a distribution before downloading it and starting to
+install it.
+
+=head1 Format
+
+F<META.yml> files are written in the L<YAML|http://www.yaml.org/> format. The
+reasons we chose YAML instead of, say, XML or Data::Dumper are discussed in
+L<this thread|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg406.html>
+on the MakeMaker mailing list.
+
+The first line of a F<META.yml> file should be a valid
+L<YAML document header|http://yaml.org/spec/history/2002-10-31.html#syntax-document>
+like C<"--- #YAML:1.0">
+
+=head1 Fields
+
+The rest of the META.yml file is one big YAML
+L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>,
+whose keys are described here.
+
+=over 4
+
+=item name
+
+Example: C<Module-Build>
+
+The name of the distribution. Often created by taking the "main
+module" in the distribution and changing "::" to "-". Sometimes it's
+completely different, however, as in the case of the
+L<libwww-perl|http://search.cpan.org/author/GAAS/libwww-perl/> distribution.
+
+=item version
+
+Example: C<0.16>
+
+The version of the distribution to which the META.yml file refers.
+This is a mandatory field.
+
+The version is essentially an arbitrary string, but I<must> be
+only ASCII characters, and I<strongly should> be of the format
+integer-dot-digit-digit, i.e. C<25.57>, optionally followed by
+underscore-digit-digit, i.e. C<25.57_04>.
+
+The standard tools that deal with module distribution (PAUSE, CPAN,
+etc.) form an identifier for each distribution by joining the 'name'
+and 'version' attributes with a dash (C<->) character. Tools
+who are prepared to deal with distributions that have no version
+numbers generally omit the dash as well.
+
+=item license
+
+Example: C<perl>
+
+a descriptive term for the licenses ... not authoritative, but must
+be consistent with licensure statements in the READMEs, documentation, etc.
+
+The license under which this distribution may be used and
+redistributed.
+
+Must be one of the following licenses:
+
+=over 4
+
+=item perl
+
+The distribution may be copied and redistributed under the same terms as perl
+itself (this is by far the most common licensing option for modules on CPAN).
+This is a dual license, in which the user may choose between either the GPL
+version 1 or the Artistic version 1 license.
+
+=item gpl
+
+The distribution is distributed under the terms of the GNU General Public
+License version 2 (L<http://opensource.org/licenses/GPL-2.0>).
+
+=item lgpl
+
+The distribution is distributed under the terms of the GNU Lesser General
+Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).
+
+=item artistic
+
+The distribution is licensed under the Artistic License version 1, as specified
+by the Artistic file in the standard perl distribution
+(L<http://opensource.org/licenses/Artistic-Perl-1.0>).
+
+=item bsd
+
+The distribution is licensed under the BSD 3-Clause License
+(L<http://opensource.org/licenses/BSD-3-Clause>).
+
+=item open_source
+
+The distribution is licensed under some other Open Source Initiative-approved
+license listed at L<http://www.opensource.org/licenses/>.
+
+=item unrestricted
+
+The distribution is licensed under a license that is B<not> approved by
+L<www.opensource.org|http://www.opensource.org/> but that allows distribution
+without restrictions.
+
+=item restrictive
+
+The distribution may not be redistributed without special permission from the
+author and/or copyright holder.
+
+=back
+
+=item license_uri
+
+This should contain a URI where the exact terms of the license may be found.
+
+(change "unrestricted" to "redistributable"?)
+
+=item distribution_type
+
+Example: C<module>
+
+What kind of stuff is contained in this distribution. Most things on
+CPAN are C<module>s (which can also mean a collection of
+modules), but some things are C<script>s.
+
+This field is basically meaningless, and tools (like Module::Build or
+MakeMaker) will likely stop generating it in the future.
+
+=item private
+
+WTF is going on here?
+
+index_ignore: any application that indexes the contents of
+distributions (PAUSE, search.cpan.org) ought to ignore the items
+(packages, files, directories, namespace hierarchies).
+
+=item requires
+
+Example:
+
+ Data::Dumper: 0
+ File::Find: 1.03
+
+A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
+indicating the Perl modules this distribution requires for proper
+operation. The keys are the module names, and the values are version
+specifications as described in the
+L<documentation for Module::Build's "requires" parameter|Module::Build::API/requires>.
+
+I<Note: the exact nature of the fancy specifications like
+C<< ">= 1.2, != 1.5, < 2.0" >> is subject to
+change. Advance notice will be given here. The simple specifications
+like C<"1.2"> will not change in format.>
+
+=item recommends
+
+Example:
+
+ Data::Dumper: 0
+ File::Find: 1.03
+
+A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
+indicating the Perl modules this distribution recommends for enhanced
+operation.
+
+=item build_requires
+
+Example:
+
+ Data::Dumper: 0
+ File::Find: 1.03
+
+A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
+indicating the Perl modules required for building and/or testing of
+this distribution. These dependencies are not required after the
+module is installed.
+
+=item conflicts
+
+Example:
+
+ Data::Dumper: 0
+ File::Find: 1.03
+
+A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
+indicating the Perl modules that cannot be installed while this
+distribution is installed. This is a pretty uncommon situation.
+
+- possibly separate out test-time prereqs, complications include: can
+tests be meaningfully preserved for later running? are test-time
+prereqs in addition to build-time, or exclusive?
+
+- make official location for installed *distributions*, which can
+contain tests, etc.
+
+=item dynamic_config
+
+Example: C<0>
+
+A boolean flag indicating whether a F<Build.PL> or
+F<Makefile.PL> (or similar) must be executed, or whether this
+module can be built, tested and installed solely from consulting its
+metadata file. The main reason to set this to a true value if that
+your module performs some dynamic configuration (asking questions,
+sensing the environment, etc.) as part of its build/install process.
+
+Currently L<Module::Build> doesn't actually do anything with
+this flag - it's probably going to be up to higher-level tools like
+L<CPAN.pm|CPAN> to do something useful with it. It can potentially
+bring lots of security, packaging, and convenience improvements.
+
+=item generated_by
+
+Example: C<Module::Build version 0.16>
+
+Indicates the tool that was used to create this F<META.yml> file. It's
+good form to include both the name of the tool and its version, but
+this field is essentially opaque, at least for the moment.
+
+=back
+
+=head2 Ingy's suggestions
+
+=over 4
+
+=item short_description
+
+add as field, containing abstract, maximum 80 characters, suggested minimum 40 characters
+
+=item description
+
+long version of abstract, should add?
+
+=item maturity
+
+alpha, beta, gamma, mature, stable
+
+=item author_id, owner_id
+
+=item categorization, keyword, chapter_id
+
+=item URL for further information
+
+could default to search.cpan.org on PAUSE
+
+=item namespaces
+
+can be specified for single elements by prepending
+dotted-form, i.e. "com.example.my_application.my_property". Default
+namespace for META.yml is probably "org.cpan.meta_author" or
+something. Precedent for this is Apple's Carbon namespaces, I think.
+
+=back
+
+=head1 History
+
+=over 4
+
+=item *
+
+B<March 14, 2003> (Pi day) - created version 1.0 of this document.
+
+=item *
+
+B<May 8, 2003> - added the "dynamic_config" field, which was missing from the
+initial version.
+
+=back
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_2.pod b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_2.pod
new file mode 100644
index 0000000000..1cb471fd2f
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_2.pod
@@ -0,0 +1,712 @@
+=for :stopwords MailingList RWS subcontext
+
+=head1 NAME
+
+CPAN::Meta::History::Meta_1_2 - Version 1.2 metadata specification for META.yml
+
+=head1 PREFACE
+
+This is a historical copy of the version 1.2 specification for F<META.yml>
+files, copyright by Ken Williams and licensed under the same terms as Perl
+itself.
+
+Modifications from the original:
+
+=over
+
+=item *
+
+Various spelling corrections
+
+=item *
+
+Include list of valid licenses from L<Module::Build> 0.2611 rather than
+linking to the module, with minor updates to text and links to reflect
+versions at the time of publication.
+
+=item *
+
+Fixed some dead links to point to active resources.
+
+=back
+
+=head1 SYNOPSIS
+
+ --- #YAML:1.0
+ name: Module-Build
+ abstract: Build and install Perl modules
+ version: 0.20
+ author:
+ - Ken Williams <kwilliams@cpan.org>
+ license: perl
+ distribution_type: module
+ requires:
+ Config: 0
+ Cwd: 0
+ Data::Dumper: 0
+ ExtUtils::Install: 0
+ File::Basename: 0
+ File::Compare: 0
+ File::Copy: 0
+ File::Find: 0
+ File::Path: 0
+ File::Spec: 0
+ IO::File: 0
+ perl: 5.005_03
+ recommends:
+ Archive::Tar: 1.00
+ ExtUtils::Install: 0.3
+ ExtUtils::ParseXS: 2.02
+ Pod::Text: 0
+ YAML: 0.35
+ build_requires:
+ Test: 0
+ urls:
+ license: http://dev.perl.org/licenses/
+ meta-spec:
+ version: 1.2
+ url: http://module-build.sourceforge.net/META-spec-v1.2.html
+ generated_by: Module::Build version 0.20
+
+=head1 DESCRIPTION
+
+This document describes version 1.2 of the F<META.yml> specification.
+
+The F<META.yml> file describes important properties of contributed
+Perl distributions such as the ones found on CPAN. It is typically
+created by tools like Module::Build, Module::Install, and
+ExtUtils::MakeMaker.
+
+The fields in the F<META.yml> file are meant to be helpful for people
+maintaining module collections (like CPAN), for people writing
+installation tools (like CPAN.pm or CPANPLUS), or just for people who
+want to know some stuff about a distribution before downloading it and
+starting to install it.
+
+I<Note: The latest stable version of this specification can always be
+found at L<http://module-build.sourceforge.net/META-spec-current.html>,
+and the latest development version (which may include things that
+won't make it into the stable version can always be found at
+L<http://module-build.sourceforge.net/META-spec-blead.html>.>
+
+=head1 FORMAT
+
+F<META.yml> files are written in the YAML format (see
+L<http://www.yaml.org/>).
+
+See the following links to learn why we chose YAML instead of, say,
+XML or Data::Dumper:
+
+=over 4
+
+=item *
+
+L<Module::Build design plans|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg407.html>
+
+=item *
+
+L<Not keen on YAML|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1353.html>
+
+=item *
+
+L<META Concerns|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1385.html>
+
+=back
+
+=head1 TERMINOLOGY
+
+=over 4
+
+=item distribution
+
+This is the primary object described by the F<META.yml>
+specification. In the context of this document it usually refers to a
+collection of modules, scripts, and/or documents that are distributed
+for other developers to use.
+
+=item module
+
+This refers to a reusable library of code typically contained in a
+single file. Currently, we primarily talk of perl modules, but this
+specification should be open enough to apply to other languages as
+well (ex. python, ruby).
+
+=back
+
+=head1 VERSION SPECIFICATIONS
+
+Some fields require a version specification (ex. L</requires>,
+L</recommends>, L</build_requires>, etc.). This section details the
+version specifications that are currently supported.
+
+If a single version is listed, then that version is considered to be
+the minimum version supported.
+
+If 0 is given as the version number, then any version is supported.
+
+Additionally, for more complicated requirements, the specification
+supports a list of versions, each of which may be optionally preceded
+by a relational operator.
+
+Supported operators include E<lt> (less than), E<lt>= (less than or
+equal), E<gt> (greater than), E<gt>= (greater than or equal), == (equal), and !=
+(not equal).
+
+If a list is given then it is evaluated from left to right so that any
+specifications in the list that conflict with a previous specification
+are overridden by the later.
+
+Examples:
+
+ >= 1.2, != 1.5, < 2.0
+
+Any version from version 1.2 onward, except version 1.5, that also
+precedes version 2.0.
+
+=head1 HEADER
+
+The first line of a F<META.yml> file should be a valid YAML document
+header like C<"--- #YAML:1.0">.
+
+=head1 FIELDS
+
+The rest of the F<META.yml> file is one big YAML mapping whose keys
+are described here.
+
+=head2 meta-spec
+
+Example:
+
+ meta-spec:
+ version: 1.2
+ url: http://module-build.sourceforge.net/META-spec-v1.2.html
+
+(Spec 1.1) [required] {URL} This field indicates the location of the
+version of the META.yml specification used.
+
+=head2 name
+
+Example:
+
+ name: Module-Build
+
+(Spec 1.0) [required] {string} The name of the distribution which is often
+created by taking the "main module" in the distribution and changing
+"::" to "-". Sometimes it's completely different, however, as in the
+case of the libwww-perl distribution (see
+L<http://search.cpan.org/author/GAAS/libwww-perl/>).
+
+=head2 version
+
+Example:
+
+ version: 0.20
+
+(Spec 1.0) [required] {version} The version of the distribution to which the
+F<META.yml> file refers.
+
+=head2 abstract
+
+Example:
+
+ abstract: Build and install Perl modules.
+
+(Spec 1.1) [required] {string} A short description of the purpose of the
+distribution.
+
+=head2 author
+
+Example:
+
+ author:
+ - Ken Williams <kwilliams@cpan.org>
+
+(Spec 1.1) [required] {list of strings} A YAML sequence indicating the author(s) of the
+distribution. The preferred form is author-name <email-address>.
+
+=head2 license
+
+Example:
+
+ license: perl
+
+(Spec 1.0) [required] {string} The license under which this distribution may be
+used and redistributed.
+
+Must be one of the following licenses:
+
+=over 4
+
+=item perl
+
+The distribution may be copied and redistributed under the same terms as perl
+itself (this is by far the most common licensing option for modules on CPAN).
+This is a dual license, in which the user may choose between either the GPL
+version 1 or the Artistic version 1 license.
+
+=item gpl
+
+The distribution is distributed under the terms of the GNU General Public
+License version 2 (L<http://opensource.org/licenses/GPL-2.0>).
+
+=item lgpl
+
+The distribution is distributed under the terms of the GNU Lesser General
+Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).
+
+=item artistic
+
+The distribution is licensed under the Artistic License version 1, as specified
+by the Artistic file in the standard perl distribution
+(L<http://opensource.org/licenses/Artistic-Perl-1.0>).
+
+=item bsd
+
+The distribution is licensed under the BSD 3-Clause License
+(L<http://opensource.org/licenses/BSD-3-Clause>).
+
+=item open_source
+
+The distribution is licensed under some other Open Source Initiative-approved
+license listed at L<http://www.opensource.org/licenses/>.
+
+=item unrestricted
+
+The distribution is licensed under a license that is B<not> approved by
+L<www.opensource.org|http://www.opensource.org/> but that allows distribution
+without restrictions.
+
+=item restrictive
+
+The distribution may not be redistributed without special permission from the
+author and/or copyright holder.
+
+=back
+
+=head2 distribution_type
+
+Example:
+
+ distribution_type: module
+
+(Spec 1.0) [optional] {string} What kind of stuff is contained in this
+distribution. Most things on CPAN are C<module>s (which can also mean
+a collection of modules), but some things are C<script>s.
+
+Unfortunately this field is basically meaningless, since many
+distributions are hybrids of several kinds of things, or some new
+thing, or subjectively different in focus depending on who's using
+them. Tools like Module::Build and MakeMaker will likely stop
+generating this field.
+
+=head2 requires
+
+Example:
+
+ requires:
+ Data::Dumper: 0
+ File::Find: 1.03
+
+(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules this
+distribution requires for proper operation. The keys are the module
+names, and the values are version specifications as described in
+L<Module::Build> for the "requires" parameter.
+
+=head2 recommends
+
+Example:
+
+ recommends:
+ Data::Dumper: 0
+ File::Find: 1.03
+
+(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules this
+distribution recommends for enhanced operation.
+
+I<ALTERNATIVE: It may be desirable to present to the user which
+features depend on which modules so they can make an informed
+decision about which recommended modules to install.>
+
+Example:
+
+ optional_features:
+ - foo:
+ description: Provides the ability to blah.
+ requires:
+ Data::Dumper: 0
+ File::Find: 1.03
+ - bar:
+ description: This feature is not available on this platform.
+ excludes_os: MSWin32
+
+I<(Spec 1.1) [optional] {map} A YAML sequence of names for optional features
+which are made available when its requirements are met. For each
+feature a description is provided along with any of L</requires>,
+L</build_requires>, L</conflicts>, C<requires_packages>,
+C<requires_os>, and C<excludes_os> which have the same meaning in
+this subcontext as described elsewhere in this document.>
+
+=head2 build_requires
+
+Example:
+
+ build_requires:
+ Data::Dumper: 0
+ File::Find: 1.03
+
+(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules
+required for building and/or testing of this distribution. These
+dependencies are not required after the module is installed.
+
+=head2 conflicts
+
+Example:
+
+ conflicts:
+ Data::Dumper: 0
+ File::Find: 1.03
+
+(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules that
+cannot be installed while this distribution is installed. This is a
+pretty uncommon situation.
+
+=head2 dynamic_config
+
+Example:
+
+ dynamic_config: 0
+
+(Spec 1.0) [optional] {boolean} A boolean flag indicating whether a F<Build.PL>
+or F<Makefile.PL> (or similar) must be executed when building this
+distribution, or whether it can be built, tested and installed solely
+from consulting its
+metadata file. The main reason to set this to a true value if that
+your module performs some dynamic configuration (asking questions,
+sensing the environment, etc.) as part of its build/install process.
+
+Currently Module::Build doesn't actually do anything with this flag
+- it's probably going to be up to higher-level tools like CPAN
+to do something useful with it. It can potentially bring lots of
+security, packaging, and convenience improvements.
+
+If this field is omitted, it defaults to 1 (true).
+
+=head2 private
+
+I<(Deprecated)> (Spec 1.0) [optional] {map} This field has been renamed to
+L</no_index>. See below.
+
+=head2 provides
+
+Example:
+
+ provides:
+ Foo::Bar:
+ file: lib/Foo/Bar.pm
+ version: 0.27_02
+ Foo::Bar::Blah:
+ file: lib/Foo/Bar/Blah.pm
+ Foo::Bar::Baz:
+ file: lib/Foo/Bar/Baz.pm
+ version: 0.3
+
+(Spec 1.1) [optional] {map} A YAML mapping that describes all packages
+provided by this distribution. This information can be (and, in some
+cases, is) used by distribution and automation mechanisms like PAUSE,
+CPAN, and search.cpan.org to build indexes saying in which
+distribution various packages can be found.
+
+When using tools like L<Module::Build> that can generate the
+C<provides> mapping for your distribution automatically, make sure you
+examine what it generates to make sure it makes sense - indexers will
+usually trust the C<provides> field if it's present, rather than
+scanning through the distribution files themselves to figure out
+packages and versions. This is a good thing, because it means you can
+use the C<provides> field to tell the indexers precisely what you want
+indexed about your distribution, rather than relying on them to
+essentially guess what you want indexed.
+
+=head2 no_index
+
+Example:
+
+ no_index:
+ file:
+ - My/Module.pm
+ dir:
+ - My/Private
+ package:
+ - My::Module::Stuff
+ namespace:
+ - My::Module::Stuff
+
+(Spec 1.1) [optional] {map} A YAML mapping that describes any files,
+directories, packages, and namespaces that are private
+(i.e. implementation artifacts) that are not of interest to searching
+and indexing tools. This is useful when no C<provides> field is
+present.
+
+I<(Note: I'm not actually sure who looks at this field, or exactly
+what they do with it. This spec could be off in some way from actual
+usage.)>
+
+=head3 file
+
+(Spec 1.1) [optional] Exclude any listed file(s).
+
+=head3 dir
+
+(Spec 1.1) [optional] Exclude anything below the listed
+directory(ies).
+
+=head3 package
+
+(Spec 1.1) [optional] Exclude the listed package(s).
+
+=head3 namespace
+
+(Spec 1.1) [optional] Excludes anything below the listed namespace(s),
+but I<not> the listed namespace(s) its self.
+
+=head2 keywords
+
+Example:
+
+ keywords:
+ - make
+ - build
+ - install
+
+(Spec 1.1) [optional] {list} A sequence of keywords/phrases that describe
+this distribution.
+
+=head2 resources
+
+Example:
+
+ resources:
+ license: http://dev.perl.org/licenses/
+ homepage: http://sourceforge.net/projects/module-build
+ bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Module-Build
+ MailingList: http://lists.sourceforge.net/lists/listinfo/module-build-general
+
+(Spec 1.1) [optional] {map} A mapping of any URL resources related to
+this distribution. All-lower-case keys, such as C<homepage>,
+C<license>, and C<bugtracker>, are reserved by this specification, as
+they have "official" meanings defined here in this specification. If
+you'd like to add your own "special" entries (like the "MailingList"
+entry above), use at least one upper-case letter.
+
+The current set of official keys is:
+
+=over 2
+
+=item homepage
+
+The official home of this project on the web.
+
+=item license
+
+An URL for an official statement of this distribution's license.
+
+=item bugtracker
+
+An URL for a bug tracker (e.g. Bugzilla or RT queue) for this project.
+
+=back
+
+
+=head2 generated_by
+
+Example:
+
+ generated_by: Module::Build version 0.20
+
+(Spec 1.0) [required] {string} Indicates the tool that was used to create this
+F<META.yml> file. It's good form to include both the name of the tool
+and its version, but this field is essentially opaque, at least for
+the moment. If F<META.yml> was generated by hand, it is suggested that
+the author be specified here.
+
+[Note: My F<meta_stats.pl> script which I use to gather statistics
+regarding F<META.yml> usage prefers the form listed above, i.e. it
+splits on /\s+version\s+/ taking the first field as the name of the
+tool that generated the file and the second field as version of that
+tool. RWS]
+
+=head1 SEE ALSO
+
+L<CPAN|http://www.cpan.org/>
+
+L<CPAN.pm|CPAN>
+
+L<CPANPLUS>
+
+L<Data::Dumper>
+
+L<ExtUtils::MakeMaker>
+
+L<Module::Build>
+
+L<Module::Install>
+
+L<XML|http://www.w3.org/XML/>
+
+L<YAML|http://www.yaml.org/>
+
+=head1 HISTORY
+
+=over 4
+
+=item March 14, 2003 (Pi day)
+
+=over 2
+
+=item *
+
+Created version 1.0 of this document.
+
+=back
+
+=item May 8, 2003
+
+=over 2
+
+=item *
+
+Added the L</dynamic_config> field, which was missing from the initial
+version.
+
+=back
+
+=item November 13, 2003
+
+=over 2
+
+=item *
+
+Added more YAML rationale articles.
+
+=item *
+
+Fixed existing link to YAML discussion thread to point to new
+L<http://nntp.x.perl.org/group/> site.
+
+=item *
+
+Added and deprecated the L</private> field.
+
+=item *
+
+Added L</abstract>, C<configure>, C<requires_packages>,
+C<requires_os>, C<excludes_os>, and L</no_index> fields.
+
+=item *
+
+Bumped version.
+
+=back
+
+=item November 16, 2003
+
+=over 2
+
+=item *
+
+Added C<generation>, C<authored_by> fields.
+
+=item *
+
+Add alternative proposal to the L</recommends> field.
+
+=item *
+
+Add proposal for a C<requires_build_tools> field.
+
+=back
+
+=item December 9, 2003
+
+=over 2
+
+=item *
+
+Added link to latest version of this specification on CPAN.
+
+=item *
+
+Added section L</"VERSION SPECIFICATIONS">.
+
+=item *
+
+Chang name from Module::Build::META-spec to CPAN::META::Specification.
+
+=item *
+
+Add proposal for C<auto_regenerate> field.
+
+=back
+
+=item December 15, 2003
+
+=over 2
+
+=item *
+
+Add C<index> field as a compliment to L</no_index>
+
+=item *
+
+Add L</keywords> field as a means to aid searching distributions.
+
+=item *
+
+Add L</TERMINOLOGY> section to explain certain terms that may be
+ambiguous.
+
+=back
+
+=item July 26, 2005
+
+=over 2
+
+=item *
+
+Removed a bunch of items (generation, requires_build_tools,
+requires_packages, configure, requires_os, excludes_os,
+auto_regenerate) that have never actually been supported, but were
+more like records of brainstorming.
+
+=item *
+
+Changed C<authored_by> to L</author>, since that's always been what
+it's actually called in actual F<META.yml> files.
+
+=item *
+
+Added the "==" operator to the list of supported version-checking
+operators.
+
+=item *
+
+Noted that the L</distribution_type> field is basically meaningless,
+and shouldn't really be used.
+
+=item *
+
+Clarified L</dynamic_config> a bit.
+
+=back
+
+=item August 23, 2005
+
+=over 2
+
+=item *
+
+Removed the name C<CPAN::META::Specification>, since that implies a
+module that doesn't actually exist.
+
+=back
+
+=back
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_3.pod b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_3.pod
new file mode 100644
index 0000000000..9e889cd597
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_3.pod
@@ -0,0 +1,741 @@
+=for :stopwords MailingList PODs RWS subcontext
+
+=head1 NAME
+
+CPAN::Meta::History::Meta_1_3 - Version 1.3 metadata specification for META.yml
+
+=head1 PREFACE
+
+This is a historical copy of the version 1.3 specification for F<META.yml>
+files, copyright by Ken Williams and licensed under the same terms as Perl
+itself.
+
+Modifications from the original:
+
+=over
+
+=item *
+
+Various spelling corrections
+
+=item *
+
+Include list of valid licenses from L<Module::Build> 0.2805 rather than
+linking to the module, with minor updates to text and links to reflect
+versions at the time of publication.
+
+=item *
+
+Fixed some dead links to point to active resources.
+
+=back
+
+=head1 SYNOPSIS
+
+ --- #YAML:1.0
+ name: Module-Build
+ abstract: Build and install Perl modules
+ version: 0.20
+ author:
+ - Ken Williams <kwilliams@cpan.org>
+ license: perl
+ distribution_type: module
+ requires:
+ Config: 0
+ Cwd: 0
+ Data::Dumper: 0
+ ExtUtils::Install: 0
+ File::Basename: 0
+ File::Compare: 0
+ File::Copy: 0
+ File::Find: 0
+ File::Path: 0
+ File::Spec: 0
+ IO::File: 0
+ perl: 5.005_03
+ recommends:
+ Archive::Tar: 1.00
+ ExtUtils::Install: 0.3
+ ExtUtils::ParseXS: 2.02
+ Pod::Text: 0
+ YAML: 0.35
+ build_requires:
+ Test: 0
+ urls:
+ license: http://dev.perl.org/licenses/
+ meta-spec:
+ version: 1.3
+ url: http://module-build.sourceforge.net/META-spec-v1.3.html
+ generated_by: Module::Build version 0.20
+
+=head1 DESCRIPTION
+
+This document describes version 1.3 of the F<META.yml> specification.
+
+The F<META.yml> file describes important properties of contributed
+Perl distributions such as the ones found on CPAN. It is typically
+created by tools like Module::Build, Module::Install, and
+ExtUtils::MakeMaker.
+
+The fields in the F<META.yml> file are meant to be helpful for people
+maintaining module collections (like CPAN), for people writing
+installation tools (like CPAN.pm or CPANPLUS), or just for people who
+want to know some stuff about a distribution before downloading it and
+starting to install it.
+
+I<Note: The latest stable version of this specification can always be
+found at L<http://module-build.sourceforge.net/META-spec-current.html>,
+and the latest development version (which may include things that
+won't make it into the stable version) can always be found at
+L<http://module-build.sourceforge.net/META-spec-blead.html>.>
+
+=head1 FORMAT
+
+F<META.yml> files are written in the YAML format (see
+L<http://www.yaml.org/>).
+
+See the following links to learn why we chose YAML instead of, say,
+XML or Data::Dumper:
+
+=over 4
+
+=item *
+
+L<Module::Build design plans|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg407.html>
+
+=item *
+
+L<Not keen on YAML|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1353.html>
+
+=item *
+
+L<META Concerns|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1385.html>
+
+=back
+
+=head1 TERMINOLOGY
+
+=over 4
+
+=item distribution
+
+This is the primary object described by the F<META.yml>
+specification. In the context of this document it usually refers to a
+collection of modules, scripts, and/or documents that are distributed
+together for other developers to use. Examples of distributions are
+C<Class-Container>, C<libwww-perl>, or C<DBI>.
+
+=item module
+
+This refers to a reusable library of code typically contained in a
+single file. Currently, we primarily talk of perl modules, but this
+specification should be open enough to apply to other languages as
+well (ex. python, ruby). Examples of modules are C<Class::Container>,
+C<LWP::Simple>, or C<DBD::File>.
+
+=back
+
+=head1 HEADER
+
+The first line of a F<META.yml> file should be a valid YAML document
+header like C<"--- #YAML:1.0">.
+
+=head1 FIELDS
+
+The rest of the F<META.yml> file is one big YAML mapping whose keys
+are described here.
+
+=head2 meta-spec
+
+Example:
+
+ meta-spec:
+ version: 1.3
+ url: http://module-build.sourceforge.net/META-spec-v1.3.html
+
+(Spec 1.1) [required] {URL} This field indicates the location of the
+version of the META.yml specification used.
+
+=head2 name
+
+Example:
+
+ name: Module-Build
+
+(Spec 1.0) [required] {string} The name of the distribution which is often
+created by taking the "main module" in the distribution and changing
+"::" to "-". Sometimes it's completely different, however, as in the
+case of the libwww-perl distribution (see
+L<http://search.cpan.org/dist/libwww-perl/>).
+
+=head2 version
+
+Example:
+
+ version: 0.20
+
+(Spec 1.0) [required] {version} The version of the distribution to which the
+F<META.yml> file refers.
+
+=head2 abstract
+
+Example:
+
+ abstract: Build and install Perl modules.
+
+(Spec 1.1) [required] {string} A short description of the purpose of the
+distribution.
+
+=head2 author
+
+Example:
+
+ author:
+ - Ken Williams <kwilliams@cpan.org>
+
+(Spec 1.1) [required] {list of strings} A YAML sequence indicating the author(s) of the
+distribution. The preferred form is author-name <email-address>.
+
+=head2 license
+
+Example:
+
+ license: perl
+
+(Spec 1.0) [required] {string} The license under which this distribution may be
+used and redistributed.
+
+Must be one of the following licenses:
+
+=over 4
+
+=item apache
+
+The distribution is licensed under the Apache Software License version 1.1
+(L<http://opensource.org/licenses/Apache-1.1>).
+
+=item artistic
+
+The distribution is licensed under the Artistic License version 1, as specified
+by the Artistic file in the standard perl distribution
+(L<http://opensource.org/licenses/Artistic-Perl-1.0>).
+
+=item bsd
+
+The distribution is licensed under the BSD 3-Clause License
+(L<http://opensource.org/licenses/BSD-3-Clause>).
+
+=item gpl
+
+The distribution is distributed under the terms of the GNU General Public
+License version 2 (L<http://opensource.org/licenses/GPL-2.0>).
+
+=item lgpl
+
+The distribution is distributed under the terms of the GNU Lesser General
+Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).
+
+=item mit
+
+The distribution is licensed under the MIT License
+(L<http://opensource.org/licenses/MIT>).
+
+=item mozilla
+
+The distribution is licensed under the Mozilla Public License.
+(L<http://opensource.org/licenses/MPL-1.0> or
+L<http://opensource.org/licenses/MPL-1.1>)
+
+=item open_source
+
+The distribution is licensed under some other Open Source Initiative-approved
+license listed at L<http://www.opensource.org/licenses/>.
+
+=item perl
+
+The distribution may be copied and redistributed under the same terms as perl
+itself (this is by far the most common licensing option for modules on CPAN).
+This is a dual license, in which the user may choose between either the GPL
+version 1 or the Artistic version 1 license.
+
+=item restrictive
+
+The distribution may not be redistributed without special permission from the
+author and/or copyright holder.
+
+=item unrestricted
+
+The distribution is licensed under a license that is not approved by
+L<www.opensource.org|http://www.opensource.org/> but that allows distribution
+without restrictions.
+
+=back
+
+=head2 distribution_type
+
+Example:
+
+ distribution_type: module
+
+(Spec 1.0) [optional] {string} What kind of stuff is contained in this
+distribution. Most things on CPAN are C<module>s (which can also mean
+a collection of modules), but some things are C<script>s.
+
+Unfortunately this field is basically meaningless, since many
+distributions are hybrids of several kinds of things, or some new
+thing, or subjectively different in focus depending on who's using
+them. Tools like Module::Build and MakeMaker will likely stop
+generating this field.
+
+=head2 requires
+
+Example:
+
+ requires:
+ Data::Dumper: 0
+ File::Find: 1.03
+
+(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules this
+distribution requires for proper operation. The keys are the module
+names, and the values are version specifications as described in
+L</"VERSION SPECIFICATIONS">.
+
+=head2 recommends
+
+Example:
+
+ recommends:
+ Data::Dumper: 0
+ File::Find: 1.03
+
+(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules
+this distribution recommends for enhanced operation. The keys are the
+module names, and the values are version specifications as described
+in L</"VERSION SPECIFICATIONS">.
+
+
+
+I<ALTERNATIVE: It may be desirable to present to the user which
+features depend on which modules so they can make an informed decision
+about which recommended modules to install.>
+
+Example:
+
+ optional_features:
+ - foo:
+ description: Provides the ability to blah.
+ requires:
+ Data::Dumper: 0
+ File::Find: 1.03
+ - bar:
+ description: This feature is not available on this platform.
+ excludes_os: MSWin32
+
+I<(Spec 1.1) [optional] {map} A YAML sequence of names for optional features
+which are made available when its requirements are met. For each
+feature a description is provided along with any of L</requires>,
+L</build_requires>, L</conflicts>, C<requires_packages>,
+C<requires_os>, and C<excludes_os> which have the same meaning in
+this subcontext as described elsewhere in this document.>
+
+=head2 build_requires
+
+Example:
+
+ build_requires:
+ Data::Dumper: 0
+ File::Find: 1.03
+
+(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules
+required for building and/or testing of this distribution. The keys
+are the module names, and the values are version specifications as
+described in L</"VERSION SPECIFICATIONS">. These dependencies are not
+required after the module is installed.
+
+=head2 conflicts
+
+Example:
+
+ conflicts:
+ Data::Dumper: 0
+ File::Find: 1.03
+
+(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules that
+cannot be installed while this distribution is installed. This is a
+pretty uncommon situation. The keys for C<conflicts> are the module
+names, and the values are version specifications as described in
+L</"VERSION SPECIFICATIONS">.
+
+
+=head2 dynamic_config
+
+Example:
+
+ dynamic_config: 0
+
+(Spec 1.0) [optional] {boolean} A boolean flag indicating whether a F<Build.PL>
+or F<Makefile.PL> (or similar) must be executed when building this
+distribution, or whether it can be built, tested and installed solely
+from consulting its
+metadata file. The main reason to set this to a true value is that
+your module performs some dynamic configuration (asking questions,
+sensing the environment, etc.) as part of its build/install process.
+
+Currently Module::Build doesn't actually do anything with this flag
+- it's probably going to be up to higher-level tools like CPAN
+to do something useful with it. It can potentially bring lots of
+security, packaging, and convenience improvements.
+
+If this field is omitted, it defaults to 1 (true).
+
+=head2 private
+
+I<(Deprecated)> (Spec 1.0) [optional] {map} This field has been renamed to
+L</no_index>. See below.
+
+=head2 provides
+
+Example:
+
+ provides:
+ Foo::Bar:
+ file: lib/Foo/Bar.pm
+ version: 0.27_02
+ Foo::Bar::Blah:
+ file: lib/Foo/Bar/Blah.pm
+ Foo::Bar::Baz:
+ file: lib/Foo/Bar/Baz.pm
+ version: 0.3
+
+(Spec 1.1) [optional] {map} A YAML mapping that describes all packages
+provided by this distribution. This information can be (and, in some
+cases, is) used by distribution and automation mechanisms like PAUSE,
+CPAN, and search.cpan.org to build indexes saying in which
+distribution various packages can be found.
+
+When using tools like L<Module::Build> that can generate the
+C<provides> mapping for your distribution automatically, make sure you
+examine what it generates to make sure it makes sense - indexers will
+usually trust the C<provides> field if it's present, rather than
+scanning through the distribution files themselves to figure out
+packages and versions. This is a good thing, because it means you can
+use the C<provides> field to tell the indexers precisely what you want
+indexed about your distribution, rather than relying on them to
+essentially guess what you want indexed.
+
+=head2 no_index
+
+Example:
+
+ no_index:
+ file:
+ - My/Module.pm
+ directory:
+ - My/Private
+ package:
+ - My::Module::Stuff
+ namespace:
+ - My::Module::Stuff
+
+(Spec 1.1) [optional] {map} A YAML mapping that describes any files,
+directories, packages, and namespaces that are private
+(i.e. implementation artifacts) that are not of interest to searching
+and indexing tools. This is useful when no C<provides> field is
+present.
+
+For example, L<http://search.cpan.org/> excludes items listed in C<no_index>
+when searching for POD, meaning files in these directories will not
+converted to HTML and made public - which is useful if you have
+example or test PODs that you don't want the search engine to go
+through.
+
+=head3 file
+
+(Spec 1.1) [optional] Exclude any listed file(s).
+
+=head3 directory
+
+(Spec 1.1) [optional] Exclude anything below the listed
+directory(ies).
+
+[Note: previous editions of the spec had C<dir> instead of
+C<directory>, but I think MakeMaker and various users started using
+C<directory>, so in deference we switched to that.]
+
+=head3 package
+
+(Spec 1.1) [optional] Exclude the listed package(s).
+
+=head3 namespace
+
+(Spec 1.1) [optional] Excludes anything below the listed namespace(s),
+but I<not> the listed namespace(s) its self.
+
+=head2 keywords
+
+Example:
+
+ keywords:
+ - make
+ - build
+ - install
+
+(Spec 1.1) [optional] {list} A sequence of keywords/phrases that describe
+this distribution.
+
+=head2 resources
+
+Example:
+
+ resources:
+ license: http://dev.perl.org/licenses/
+ homepage: http://sourceforge.net/projects/module-build
+ bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Module-Build
+ repository: http://sourceforge.net/cvs/?group_id=45731
+ MailingList: http://lists.sourceforge.net/lists/listinfo/module-build-general
+
+(Spec 1.1) [optional] {map} A mapping of any URL resources related to
+this distribution. All-lower-case keys, such as C<homepage>,
+C<license>, and C<bugtracker>, are reserved by this specification, as
+they have "official" meanings defined here in this specification. If
+you'd like to add your own "special" entries (like the "MailingList"
+entry above), use at least one upper-case letter.
+
+The current set of official keys is:
+
+=over 2
+
+=item homepage
+
+The official home of this project on the web.
+
+=item license
+
+An URL for an official statement of this distribution's license.
+
+=item bugtracker
+
+An URL for a bug tracker (e.g. Bugzilla or RT queue) for this project.
+
+=back
+
+
+=head2 generated_by
+
+Example:
+
+ generated_by: Module::Build version 0.20
+
+(Spec 1.0) [required] {string} Indicates the tool that was used to create this
+F<META.yml> file. It's good form to include both the name of the tool
+and its version, but this field is essentially opaque, at least for
+the moment. If F<META.yml> was generated by hand, it is suggested that
+the author be specified here.
+
+[Note: My F<meta_stats.pl> script which I use to gather statistics
+regarding F<META.yml> usage prefers the form listed above, i.e. it
+splits on /\s+version\s+/ taking the first field as the name of the
+tool that generated the file and the second field as version of that
+tool. RWS]
+
+=head1 VERSION SPECIFICATIONS
+
+Some fields require a version specification (ex. L</requires>,
+L</recommends>, L</build_requires>, etc.) to indicate the particular
+versionZ<>(s) of some other module that may be required as a
+prerequisite. This section details the version specification formats
+that are currently supported.
+
+The simplest format for a version specification is just the version
+number itself, e.g. C<2.4>. This means that B<at least> version 2.4
+must be present. To indicate that B<any> version of a prerequisite is
+okay, even if the prerequisite doesn't define a version at all, use
+the version C<0>.
+
+You may also use the operators E<lt> (less than), E<lt>= (less than or
+equal), E<gt> (greater than), E<gt>= (greater than or equal), ==
+(equal), and != (not equal). For example, the specification C<E<lt>
+2.0> means that any version of the prerequisite less than 2.0 is
+suitable.
+
+For more complicated situations, version specifications may be AND-ed
+together using commas. The specification C<E<gt>= 1.2, != 1.5, E<lt>
+2.0> indicates a version that must be B<at least> 1.2, B<less than>
+2.0, and B<not equal to> 1.5.
+
+=head1 SEE ALSO
+
+L<CPAN|http://www.cpan.org/>
+
+L<CPAN.pm|CPAN>
+
+L<CPANPLUS>
+
+L<Data::Dumper>
+
+L<ExtUtils::MakeMaker>
+
+L<Module::Build>
+
+L<Module::Install>
+
+L<XML|http://www.w3.org/XML/>
+
+L<YAML|http://www.yaml.org/>
+
+=head1 HISTORY
+
+=over 4
+
+=item March 14, 2003 (Pi day)
+
+=over 2
+
+=item *
+
+Created version 1.0 of this document.
+
+=back
+
+=item May 8, 2003
+
+=over 2
+
+=item *
+
+Added the L</dynamic_config> field, which was missing from the initial
+version.
+
+=back
+
+=item November 13, 2003
+
+=over 2
+
+=item *
+
+Added more YAML rationale articles.
+
+=item *
+
+Fixed existing link to YAML discussion thread to point to new
+L<http://nntp.x.perl.org/group/> site.
+
+=item *
+
+Added and deprecated the L</private> field.
+
+=item *
+
+Added L</abstract>, C<configure>, C<requires_packages>,
+C<requires_os>, C<excludes_os>, and L</no_index> fields.
+
+=item *
+
+Bumped version.
+
+=back
+
+=item November 16, 2003
+
+=over 2
+
+=item *
+
+Added C<generation>, C<authored_by> fields.
+
+=item *
+
+Add alternative proposal to the L</recommends> field.
+
+=item *
+
+Add proposal for a C<requires_build_tools> field.
+
+=back
+
+=item December 9, 2003
+
+=over 2
+
+=item *
+
+Added link to latest version of this specification on CPAN.
+
+=item *
+
+Added section L</"VERSION SPECIFICATIONS">.
+
+=item *
+
+Chang name from Module::Build::META-spec to CPAN::META::Specification.
+
+=item *
+
+Add proposal for C<auto_regenerate> field.
+
+=back
+
+=item December 15, 2003
+
+=over 2
+
+=item *
+
+Add C<index> field as a compliment to L</no_index>
+
+=item *
+
+Add L</keywords> field as a means to aid searching distributions.
+
+=item *
+
+Add L</TERMINOLOGY> section to explain certain terms that may be
+ambiguous.
+
+=back
+
+=item July 26, 2005
+
+=over 2
+
+=item *
+
+Removed a bunch of items (generation, requires_build_tools,
+requires_packages, configure, requires_os, excludes_os,
+auto_regenerate) that have never actually been supported, but were
+more like records of brainstorming.
+
+=item *
+
+Changed C<authored_by> to L</author>, since that's always been what
+it's actually called in actual F<META.yml> files.
+
+=item *
+
+Added the "==" operator to the list of supported version-checking
+operators.
+
+=item *
+
+Noted that the L</distribution_type> field is basically meaningless,
+and shouldn't really be used.
+
+=item *
+
+Clarified L</dynamic_config> a bit.
+
+=back
+
+=item August 23, 2005
+
+=over 2
+
+=item *
+
+Removed the name C<CPAN::META::Specification>, since that implies a
+module that doesn't actually exist.
+
+=back
+
+=back
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_4.pod b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_4.pod
new file mode 100644
index 0000000000..932f1ed94b
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_4.pod
@@ -0,0 +1,765 @@
+=for :stopwords MailingList PODs RWS subcontext
+
+=head1 NAME
+
+CPAN::Meta::History::Meta_1_4 - Version 1.4 metadata specification for META.yml
+
+=head1 PREFACE
+
+This is a historical copy of the version 1.4 specification for F<META.yml>
+files, copyright by Ken Williams and licensed under the same terms as Perl
+itself.
+
+Modifications from the original:
+
+=over
+
+=item *
+
+Various spelling corrections
+
+=item *
+
+Include list of valid licenses from L<Module::Build> 0.2807 rather than
+linking to the module, with minor updates to text and links to reflect
+versions at the time of publication.
+
+=item *
+
+Fixed some dead links to point to active resources.
+
+=back
+
+=head1 SYNOPSIS
+
+ --- #YAML:1.0
+ name: Module-Build
+ abstract: Build and install Perl modules
+ version: 0.20
+ author:
+ - Ken Williams <kwilliams@cpan.org>
+ license: perl
+ distribution_type: module
+ requires:
+ Config: 0
+ Cwd: 0
+ Data::Dumper: 0
+ ExtUtils::Install: 0
+ File::Basename: 0
+ File::Compare: 0
+ File::Copy: 0
+ File::Find: 0
+ File::Path: 0
+ File::Spec: 0
+ IO::File: 0
+ perl: 5.005_03
+ recommends:
+ Archive::Tar: 1.00
+ ExtUtils::Install: 0.3
+ ExtUtils::ParseXS: 2.02
+ Pod::Text: 0
+ YAML: 0.35
+ build_requires:
+ Test: 0
+ resources:
+ license: http://dev.perl.org/licenses/
+ meta-spec:
+ version: 1.4
+ url: http://module-build.sourceforge.net/META-spec-v1.3.html
+ generated_by: Module::Build version 0.20
+
+=head1 DESCRIPTION
+
+This document describes version 1.4 of the F<META.yml> specification.
+
+The F<META.yml> file describes important properties of contributed
+Perl distributions such as the ones found on CPAN. It is typically
+created by tools like Module::Build, Module::Install, and
+ExtUtils::MakeMaker.
+
+The fields in the F<META.yml> file are meant to be helpful for people
+maintaining module collections (like CPAN), for people writing
+installation tools (like CPAN.pm or CPANPLUS), or just for people who
+want to know some stuff about a distribution before downloading it and
+starting to install it.
+
+I<Note: The latest stable version of this specification can always be
+found at L<http://module-build.sourceforge.net/META-spec-current.html>,
+and the latest development version (which may include things that
+won't make it into the stable version) can always be found at
+L<http://module-build.sourceforge.net/META-spec-blead.html>.>
+
+=head1 FORMAT
+
+F<META.yml> files are written in the YAML format (see
+L<http://www.yaml.org/>).
+
+See the following links to learn why we chose YAML instead of, say,
+XML or Data::Dumper:
+
+=over 4
+
+=item *
+
+L<Module::Build design plans|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg407.html>
+
+=item *
+
+L<Not keen on YAML|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1353.html>
+
+=item *
+
+L<META Concerns|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1385.html>
+
+=back
+
+=head1 TERMINOLOGY
+
+=over 4
+
+=item distribution
+
+This is the primary object described by the F<META.yml>
+specification. In the context of this document it usually refers to a
+collection of modules, scripts, and/or documents that are distributed
+together for other developers to use. Examples of distributions are
+C<Class-Container>, C<libwww-perl>, or C<DBI>.
+
+=item module
+
+This refers to a reusable library of code typically contained in a
+single file. Currently, we primarily talk of perl modules, but this
+specification should be open enough to apply to other languages as
+well (ex. python, ruby). Examples of modules are C<Class::Container>,
+C<LWP::Simple>, or C<DBD::File>.
+
+=back
+
+=head1 HEADER
+
+The first line of a F<META.yml> file should be a valid YAML document
+header like C<"--- #YAML:1.0">.
+
+=head1 FIELDS
+
+The rest of the F<META.yml> file is one big YAML mapping whose keys
+are described here.
+
+=head2 meta-spec
+
+Example:
+
+ meta-spec:
+ version: 1.4
+ url: http://module-build.sourceforge.net/META-spec-v1.3.html
+
+(Spec 1.1) [required] {URL} This field indicates the location of the
+version of the META.yml specification used.
+
+=head2 name
+
+Example:
+
+ name: Module-Build
+
+(Spec 1.0) [required] {string} The name of the distribution which is often
+created by taking the "main module" in the distribution and changing
+"::" to "-". Sometimes it's completely different, however, as in the
+case of the libwww-perl distribution (see
+L<http://search.cpan.org/dist/libwww-perl/>).
+
+=head2 version
+
+Example:
+
+ version: 0.20
+
+(Spec 1.0) [required] {version} The version of the distribution to which the
+F<META.yml> file refers.
+
+=head2 abstract
+
+Example:
+
+ abstract: Build and install Perl modules.
+
+(Spec 1.1) [required] {string} A short description of the purpose of the
+distribution.
+
+=head2 author
+
+Example:
+
+ author:
+ - Ken Williams <kwilliams@cpan.org>
+
+(Spec 1.1) [required] {list of strings} A YAML sequence indicating the author(s) of the
+distribution. The preferred form is author-name <email-address>.
+
+=head2 license
+
+Example:
+
+ license: perl
+
+(Spec 1.0) [required] {string} The license under which this
+distribution may be used and redistributed.
+
+Must be one of the following licenses:
+
+=over 4
+
+=item apache
+
+The distribution is licensed under the Apache Software License version 1.1
+(L<http://opensource.org/licenses/Apache-1.1>).
+
+=item artistic
+
+The distribution is licensed under the Artistic License version 1, as specified
+by the Artistic file in the standard perl distribution
+(L<http://opensource.org/licenses/Artistic-Perl-1.0>).
+
+=item bsd
+
+The distribution is licensed under the BSD 3-Clause License
+(L<http://opensource.org/licenses/BSD-3-Clause>).
+
+=item gpl
+
+The distribution is distributed under the terms of the GNU General Public
+License version 2 (L<http://opensource.org/licenses/GPL-2.0>).
+
+=item lgpl
+
+The distribution is distributed under the terms of the GNU Lesser General
+Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).
+
+=item mit
+
+The distribution is licensed under the MIT License
+(L<http://opensource.org/licenses/MIT>).
+
+=item mozilla
+
+The distribution is licensed under the Mozilla Public License.
+(L<http://opensource.org/licenses/MPL-1.0> or
+L<http://opensource.org/licenses/MPL-1.1>)
+
+=item open_source
+
+The distribution is licensed under some other Open Source Initiative-approved
+license listed at L<http://www.opensource.org/licenses/>.
+
+=item perl
+
+The distribution may be copied and redistributed under the same terms as perl
+itself (this is by far the most common licensing option for modules on CPAN).
+This is a dual license, in which the user may choose between either the GPL or
+the Artistic license.
+
+=item restrictive
+
+The distribution may not be redistributed without special permission from the
+author and/or copyright holder.
+
+=item unrestricted
+
+The distribution is licensed under a license that is not approved by
+L<www.opensource.org|http://www.opensource.org/> but that allows distribution
+without restrictions.
+
+=back
+
+=head2 distribution_type
+
+Example:
+
+ distribution_type: module
+
+(Spec 1.0) [optional] {string} What kind of stuff is contained in this
+distribution. Most things on CPAN are C<module>s (which can also mean
+a collection of modules), but some things are C<script>s.
+
+Unfortunately this field is basically meaningless, since many
+distributions are hybrids of several kinds of things, or some new
+thing, or subjectively different in focus depending on who's using
+them. Tools like Module::Build and MakeMaker will likely stop
+generating this field.
+
+=head2 requires
+
+Example:
+
+ requires:
+ Data::Dumper: 0
+ File::Find: 1.03
+
+(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl
+prerequisites this distribution requires for proper operation. The
+keys are the names of the prerequisites (module names or 'perl'), and
+the values are version specifications as described in L<VERSION
+SPECIFICATIONS>.
+
+=head2 recommends
+
+Example:
+
+ recommends:
+ Data::Dumper: 0
+ File::Find: 1.03
+
+(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl
+prerequisites this distribution recommends for enhanced operation.
+The keys are the names of the prerequisites (module names or 'perl'),
+and the values are version specifications as described in L<VERSION
+SPECIFICATIONS>.
+
+
+
+I<ALTERNATIVE: It may be desirable to present to the user which
+features depend on which modules so they can make an informed decision
+about which recommended modules to install.>
+
+Example:
+
+ optional_features:
+ foo:
+ description: Provides the ability to blah.
+ requires:
+ Data::Dumper: 0
+ File::Find: 1.03
+
+I<(Spec 1.1) [optional] {map} A YAML mapping of names for optional features
+which are made available when its requirements are met. For each
+feature a description is provided along with any of L</requires>,
+L</build_requires>, and L</conflicts>, which have the same meaning in
+this subcontext as described elsewhere in this document.>
+
+=head2 build_requires
+
+Example:
+
+ build_requires:
+ Data::Dumper: 0
+ File::Find: 1.03
+
+(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl
+prerequisites required for building and/or testing of this
+distribution. The keys are the names of the prerequisites (module
+names or 'perl'), and the values are version specifications as
+described in L</"VERSION SPECIFICATIONS">. These dependencies are not
+required after the distribution is installed.
+
+=head2 configure_requires
+
+Example:
+
+ configure_requires:
+ Module::Build: 0.2809
+ Data::Dumper: 0
+ File::Find: 1.03
+
+(Spec 1.4) [optional] {map} A YAML mapping indicating the Perl prerequisites
+required before configuring this distribution. The keys are the
+names of the prerequisites (module names or 'perl'), and the values are version
+specifications as described in L</"VERSION SPECIFICATIONS">. These
+dependencies are not required after the distribution is installed.
+
+=head2 conflicts
+
+Example:
+
+ conflicts:
+ Data::Dumper: 0
+ File::Find: 1.03
+
+(Spec 1.0) [optional] {map} A YAML mapping indicating any items that
+cannot be installed while this distribution is installed. This is a
+pretty uncommon situation. The keys for C<conflicts> are the item
+names (module names or 'perl'), and the values are version
+specifications as described in L</"VERSION SPECIFICATIONS">.
+
+
+=head2 dynamic_config
+
+Example:
+
+ dynamic_config: 0
+
+(Spec 1.0) [optional] {boolean} A boolean flag indicating whether a F<Build.PL>
+or F<Makefile.PL> (or similar) must be executed when building this
+distribution, or whether it can be built, tested and installed solely
+from consulting its
+metadata file. The main reason to set this to a true value is that
+your module performs some dynamic configuration (asking questions,
+sensing the environment, etc.) as part of its build/install process.
+
+Currently Module::Build doesn't actually do anything with this flag
+- it's probably going to be up to higher-level tools like CPAN
+to do something useful with it. It can potentially bring lots of
+security, packaging, and convenience improvements.
+
+If this field is omitted, it defaults to 1 (true).
+
+=head2 private
+
+I<(Deprecated)> (Spec 1.0) [optional] {map} This field has been renamed to
+L</no_index>. See below.
+
+=head2 provides
+
+Example:
+
+ provides:
+ Foo::Bar:
+ file: lib/Foo/Bar.pm
+ version: 0.27_02
+ Foo::Bar::Blah:
+ file: lib/Foo/Bar/Blah.pm
+ Foo::Bar::Baz:
+ file: lib/Foo/Bar/Baz.pm
+ version: 0.3
+
+(Spec 1.1) [optional] {map} A YAML mapping that describes all packages
+provided by this distribution. This information can be (and, in some
+cases, is) used by distribution and automation mechanisms like PAUSE,
+CPAN, and search.cpan.org to build indexes saying in which
+distribution various packages can be found.
+
+When using tools like L<Module::Build> that can generate the
+C<provides> mapping for your distribution automatically, make sure you
+examine what it generates to make sure it makes sense - indexers will
+usually trust the C<provides> field if it's present, rather than
+scanning through the distribution files themselves to figure out
+packages and versions. This is a good thing, because it means you can
+use the C<provides> field to tell the indexers precisely what you want
+indexed about your distribution, rather than relying on them to
+essentially guess what you want indexed.
+
+=head2 no_index
+
+Example:
+
+ no_index:
+ file:
+ - My/Module.pm
+ directory:
+ - My/Private
+ package:
+ - My::Module::Stuff
+ namespace:
+ - My::Module::Stuff
+
+(Spec 1.1) [optional] {map} A YAML mapping that describes any files,
+directories, packages, and namespaces that are private
+(i.e. implementation artifacts) that are not of interest to searching
+and indexing tools. This is useful when no C<provides> field is
+present.
+
+For example, L<http://search.cpan.org/> excludes items listed in C<no_index>
+when searching for POD, meaning files in these directories will not
+converted to HTML and made public - which is useful if you have
+example or test PODs that you don't want the search engine to go
+through.
+
+=head3 file
+
+(Spec 1.1) [optional] Exclude any listed file(s).
+
+=head3 directory
+
+(Spec 1.1) [optional] Exclude anything below the listed
+directory(ies).
+
+[Note: previous editions of the spec had C<dir> instead of
+C<directory>, but I think MakeMaker and various users started using
+C<directory>, so in deference we switched to that.]
+
+=head3 package
+
+(Spec 1.1) [optional] Exclude the listed package(s).
+
+=head3 namespace
+
+(Spec 1.1) [optional] Excludes anything below the listed namespace(s),
+but I<not> the listed namespace(s) its self.
+
+=head2 keywords
+
+Example:
+
+ keywords:
+ - make
+ - build
+ - install
+
+(Spec 1.1) [optional] {list} A sequence of keywords/phrases that describe
+this distribution.
+
+=head2 resources
+
+Example:
+
+ resources:
+ license: http://dev.perl.org/licenses/
+ homepage: http://sourceforge.net/projects/module-build
+ bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Module-Build
+ repository: http://sourceforge.net/cvs/?group_id=45731
+ MailingList: http://lists.sourceforge.net/lists/listinfo/module-build-general
+
+(Spec 1.1) [optional] {map} A mapping of any URL resources related to
+this distribution. All-lower-case keys, such as C<homepage>,
+C<license>, and C<bugtracker>, are reserved by this specification, as
+they have "official" meanings defined here in this specification. If
+you'd like to add your own "special" entries (like the "MailingList"
+entry above), use at least one upper-case letter.
+
+The current set of official keys is:
+
+=over 2
+
+=item homepage
+
+The official home of this project on the web.
+
+=item license
+
+An URL for an official statement of this distribution's license.
+
+=item bugtracker
+
+An URL for a bug tracker (e.g. Bugzilla or RT queue) for this project.
+
+=back
+
+
+=head2 generated_by
+
+Example:
+
+ generated_by: Module::Build version 0.20
+
+(Spec 1.0) [required] {string} Indicates the tool that was used to create this
+F<META.yml> file. It's good form to include both the name of the tool
+and its version, but this field is essentially opaque, at least for
+the moment. If F<META.yml> was generated by hand, it is suggested that
+the author be specified here.
+
+[Note: My F<meta_stats.pl> script which I use to gather statistics
+regarding F<META.yml> usage prefers the form listed above, i.e. it
+splits on /\s+version\s+/ taking the first field as the name of the
+tool that generated the file and the second field as version of that
+tool. RWS]
+
+=head1 VERSION SPECIFICATIONS
+
+Some fields require a version specification (ex. L</requires>,
+L</recommends>, L</build_requires>, etc.) to indicate the particular
+versionZ<>(s) of some other module that may be required as a
+prerequisite. This section details the version specification formats
+that are currently supported.
+
+The simplest format for a version specification is just the version
+number itself, e.g. C<2.4>. This means that B<at least> version 2.4
+must be present. To indicate that B<any> version of a prerequisite is
+okay, even if the prerequisite doesn't define a version at all, use
+the version C<0>.
+
+You may also use the operators E<lt> (less than), E<lt>= (less than or
+equal), E<gt> (greater than), E<gt>= (greater than or equal), ==
+(equal), and != (not equal). For example, the specification C<E<lt>
+2.0> means that any version of the prerequisite less than 2.0 is
+suitable.
+
+For more complicated situations, version specifications may be AND-ed
+together using commas. The specification C<E<gt>= 1.2, != 1.5, E<lt>
+2.0> indicates a version that must be B<at least> 1.2, B<less than>
+2.0, and B<not equal to> 1.5.
+
+=head1 SEE ALSO
+
+L<CPAN|http://www.cpan.org/>
+
+L<CPAN.pm|CPAN>
+
+L<CPANPLUS>
+
+L<Data::Dumper>
+
+L<ExtUtils::MakeMaker>
+
+L<Module::Build>
+
+L<Module::Install>
+
+L<XML|http://www.w3.org/XML/>
+
+L<YAML|http://www.yaml.org/>
+
+=head1 HISTORY
+
+=over 4
+
+=item March 14, 2003 (Pi day)
+
+=over 2
+
+=item *
+
+Created version 1.0 of this document.
+
+=back
+
+=item May 8, 2003
+
+=over 2
+
+=item *
+
+Added the L</dynamic_config> field, which was missing from the initial
+version.
+
+=back
+
+=item November 13, 2003
+
+=over 2
+
+=item *
+
+Added more YAML rationale articles.
+
+=item *
+
+Fixed existing link to YAML discussion thread to point to new
+L<http://nntp.x.perl.org/group/> site.
+
+=item *
+
+Added and deprecated the L</private> field.
+
+=item *
+
+Added L</abstract>, C<configure>, C<requires_packages>,
+C<requires_os>, C<excludes_os>, and L</no_index> fields.
+
+=item *
+
+Bumped version.
+
+=back
+
+=item November 16, 2003
+
+=over 2
+
+=item *
+
+Added C<generation>, C<authored_by> fields.
+
+=item *
+
+Add alternative proposal to the L</recommends> field.
+
+=item *
+
+Add proposal for a C<requires_build_tools> field.
+
+=back
+
+=item December 9, 2003
+
+=over 2
+
+=item *
+
+Added link to latest version of this specification on CPAN.
+
+=item *
+
+Added section L</"VERSION SPECIFICATIONS">.
+
+=item *
+
+Chang name from Module::Build::META-spec to CPAN::META::Specification.
+
+=item *
+
+Add proposal for C<auto_regenerate> field.
+
+=back
+
+=item December 15, 2003
+
+=over 2
+
+=item *
+
+Add C<index> field as a compliment to L</no_index>
+
+=item *
+
+Add L</keywords> field as a means to aid searching distributions.
+
+=item *
+
+Add L</TERMINOLOGY> section to explain certain terms that may be
+ambiguous.
+
+=back
+
+=item July 26, 2005
+
+=over 2
+
+=item *
+
+Removed a bunch of items (generation, requires_build_tools,
+requires_packages, configure, requires_os, excludes_os,
+auto_regenerate) that have never actually been supported, but were
+more like records of brainstorming.
+
+=item *
+
+Changed C<authored_by> to L</author>, since that's always been what
+it's actually called in actual F<META.yml> files.
+
+=item *
+
+Added the "==" operator to the list of supported version-checking
+operators.
+
+=item *
+
+Noted that the L</distribution_type> field is basically meaningless,
+and shouldn't really be used.
+
+=item *
+
+Clarified L</dynamic_config> a bit.
+
+=back
+
+=item August 23, 2005
+
+=over 2
+
+=item *
+
+Removed the name C<CPAN::META::Specification>, since that implies a
+module that doesn't actually exist.
+
+=back
+
+=item June 12, 2007
+
+=over 2
+
+=item *
+
+Added L</configure_requires>.
+
+=back
+
+=back
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Merge.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Merge.pm
new file mode 100644
index 0000000000..3604eae402
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Merge.pm
@@ -0,0 +1,351 @@
+use strict;
+use warnings;
+
+package CPAN::Meta::Merge;
+
+our $VERSION = '2.150010';
+
+use Carp qw/croak/;
+use Scalar::Util qw/blessed/;
+use CPAN::Meta::Converter 2.141170;
+
+sub _is_identical {
+ my ($left, $right) = @_;
+ return
+ (not defined $left and not defined $right)
+ # if either of these are references, we compare the serialized value
+ || (defined $left and defined $right and $left eq $right);
+}
+
+sub _identical {
+ my ($left, $right, $path) = @_;
+ croak sprintf "Can't merge attribute %s: '%s' does not equal '%s'", join('.', @{$path}), $left, $right
+ unless _is_identical($left, $right);
+ return $left;
+}
+
+sub _merge {
+ my ($current, $next, $mergers, $path) = @_;
+ for my $key (keys %{$next}) {
+ if (not exists $current->{$key}) {
+ $current->{$key} = $next->{$key};
+ }
+ elsif (my $merger = $mergers->{$key}) {
+ $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
+ }
+ elsif ($merger = $mergers->{':default'}) {
+ $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
+ }
+ else {
+ croak sprintf "Can't merge unknown attribute '%s'", join '.', @{$path}, $key;
+ }
+ }
+ return $current;
+}
+
+sub _uniq {
+ my %seen = ();
+ return grep { not $seen{$_}++ } @_;
+}
+
+sub _set_addition {
+ my ($left, $right) = @_;
+ return [ +_uniq(@{$left}, @{$right}) ];
+}
+
+sub _uniq_map {
+ my ($left, $right, $path) = @_;
+ for my $key (keys %{$right}) {
+ if (not exists $left->{$key}) {
+ $left->{$key} = $right->{$key};
+ }
+ # identical strings or references are merged identically
+ elsif (_is_identical($left->{$key}, $right->{$key})) {
+ 1; # do nothing - keep left
+ }
+ elsif (ref $left->{$key} eq 'HASH' and ref $right->{$key} eq 'HASH') {
+ $left->{$key} = _uniq_map($left->{$key}, $right->{$key}, [ @{$path}, $key ]);
+ }
+ else {
+ croak 'Duplication of element ' . join '.', @{$path}, $key;
+ }
+ }
+ return $left;
+}
+
+sub _improvise {
+ my ($left, $right, $path) = @_;
+ my ($name) = reverse @{$path};
+ if ($name =~ /^x_/) {
+ if (ref($left) eq 'ARRAY') {
+ return _set_addition($left, $right, $path);
+ }
+ elsif (ref($left) eq 'HASH') {
+ return _uniq_map($left, $right, $path);
+ }
+ else {
+ return _identical($left, $right, $path);
+ }
+ }
+ croak sprintf "Can't merge '%s'", join '.', @{$path};
+}
+
+sub _optional_features {
+ my ($left, $right, $path) = @_;
+
+ for my $key (keys %{$right}) {
+ if (not exists $left->{$key}) {
+ $left->{$key} = $right->{$key};
+ }
+ else {
+ for my $subkey (keys %{ $right->{$key} }) {
+ next if $subkey eq 'prereqs';
+ if (not exists $left->{$key}{$subkey}) {
+ $left->{$key}{$subkey} = $right->{$key}{$subkey};
+ }
+ else {
+ Carp::croak "Cannot merge two optional_features named '$key' with different '$subkey' values"
+ if do { no warnings 'uninitialized'; $left->{$key}{$subkey} ne $right->{$key}{$subkey} };
+ }
+ }
+
+ require CPAN::Meta::Prereqs;
+ $left->{$key}{prereqs} =
+ CPAN::Meta::Prereqs->new($left->{$key}{prereqs})
+ ->with_merged_prereqs(CPAN::Meta::Prereqs->new($right->{$key}{prereqs}))
+ ->as_string_hash;
+ }
+ }
+ return $left;
+}
+
+
+my %default = (
+ abstract => \&_identical,
+ author => \&_set_addition,
+ dynamic_config => sub {
+ my ($left, $right) = @_;
+ return $left || $right;
+ },
+ generated_by => sub {
+ my ($left, $right) = @_;
+ return join ', ', _uniq(split(/, /, $left), split(/, /, $right));
+ },
+ license => \&_set_addition,
+ 'meta-spec' => {
+ version => \&_identical,
+ url => \&_identical
+ },
+ name => \&_identical,
+ release_status => \&_identical,
+ version => \&_identical,
+ description => \&_identical,
+ keywords => \&_set_addition,
+ no_index => { map { ($_ => \&_set_addition) } qw/file directory package namespace/ },
+ optional_features => \&_optional_features,
+ prereqs => sub {
+ require CPAN::Meta::Prereqs;
+ my ($left, $right) = map { CPAN::Meta::Prereqs->new($_) } @_[0,1];
+ return $left->with_merged_prereqs($right)->as_string_hash;
+ },
+ provides => \&_uniq_map,
+ resources => {
+ license => \&_set_addition,
+ homepage => \&_identical,
+ bugtracker => \&_uniq_map,
+ repository => \&_uniq_map,
+ ':default' => \&_improvise,
+ },
+ ':default' => \&_improvise,
+);
+
+sub new {
+ my ($class, %arguments) = @_;
+ croak 'default version required' if not exists $arguments{default_version};
+ my %mapping = %default;
+ my %extra = %{ $arguments{extra_mappings} || {} };
+ for my $key (keys %extra) {
+ if (ref($mapping{$key}) eq 'HASH') {
+ $mapping{$key} = { %{ $mapping{$key} }, %{ $extra{$key} } };
+ }
+ else {
+ $mapping{$key} = $extra{$key};
+ }
+ }
+ return bless {
+ default_version => $arguments{default_version},
+ mapping => _coerce_mapping(\%mapping, []),
+ }, $class;
+}
+
+my %coderef_for = (
+ set_addition => \&_set_addition,
+ uniq_map => \&_uniq_map,
+ identical => \&_identical,
+ improvise => \&_improvise,
+ improvize => \&_improvise, # [sic] for backwards compatibility
+);
+
+sub _coerce_mapping {
+ my ($orig, $map_path) = @_;
+ my %ret;
+ for my $key (keys %{$orig}) {
+ my $value = $orig->{$key};
+ if (ref($orig->{$key}) eq 'CODE') {
+ $ret{$key} = $value;
+ }
+ elsif (ref($value) eq 'HASH') {
+ my $mapping = _coerce_mapping($value, [ @{$map_path}, $key ]);
+ $ret{$key} = sub {
+ my ($left, $right, $path) = @_;
+ return _merge($left, $right, $mapping, [ @{$path} ]);
+ };
+ }
+ elsif ($coderef_for{$value}) {
+ $ret{$key} = $coderef_for{$value};
+ }
+ else {
+ croak "Don't know what to do with " . join '.', @{$map_path}, $key;
+ }
+ }
+ return \%ret;
+}
+
+sub merge {
+ my ($self, @items) = @_;
+ my $current = {};
+ for my $next (@items) {
+ if ( blessed($next) && $next->isa('CPAN::Meta') ) {
+ $next = $next->as_struct;
+ }
+ elsif ( ref($next) eq 'HASH' ) {
+ my $cmc = CPAN::Meta::Converter->new(
+ $next, default_version => $self->{default_version}
+ );
+ $next = $cmc->upgrade_fragment;
+ }
+ else {
+ croak "Don't know how to merge '$next'";
+ }
+ $current = _merge($current, $next, $self->{mapping}, []);
+ }
+ return $current;
+}
+
+1;
+
+# ABSTRACT: Merging CPAN Meta fragments
+
+
+# vim: ts=2 sts=2 sw=2 et :
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+CPAN::Meta::Merge - Merging CPAN Meta fragments
+
+=head1 VERSION
+
+version 2.150010
+
+=head1 SYNOPSIS
+
+ my $merger = CPAN::Meta::Merge->new(default_version => "2");
+ my $meta = $merger->merge($base, @additional);
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 new
+
+This creates a CPAN::Meta::Merge object. It takes one mandatory named
+argument, C<version>, declaring the version of the meta-spec that must be
+used for the merge. It can optionally take an C<extra_mappings> argument
+that allows one to add additional merging functions for specific elements.
+
+The C<extra_mappings> arguments takes a hash ref with the same type of
+structure as described in L<CPAN::Meta::Spec>, except with its values as
+one of the L<defined merge strategies|/"MERGE STRATEGIES"> or a code ref
+to a merging function.
+
+ my $merger = CPAN::Meta::Merge->new(
+ default_version => '2',
+ extra_mappings => {
+ 'optional_features' => \&custom_merge_function,
+ 'x_custom' => 'set_addition',
+ 'x_meta_meta' => {
+ name => 'identical',
+ tags => 'set_addition',
+ }
+ }
+ );
+
+=head2 merge(@fragments)
+
+Merge all C<@fragments> together. It will accept both CPAN::Meta objects and
+(possibly incomplete) hashrefs of metadata.
+
+=head1 MERGE STRATEGIES
+
+C<merge> uses various strategies to combine different elements of the CPAN::Meta objects. The following strategies can be used with the extra_mappings argument of C<new>:
+
+=over
+
+=item identical
+
+The elements must be identical
+
+=item set_addition
+
+The union of two array refs
+
+ [ a, b ] U [ a, c] = [ a, b, c ]
+
+=item uniq_map
+
+Key value pairs from the right hash are merged to the left hash. Key
+collisions are only allowed if their values are the same. This merge
+function will recurse into nested hash refs following the same merge
+rules.
+
+=item improvise
+
+This merge strategy will try to pick the appropriate predefined strategy
+based on what element type. Array refs will try to use the
+C<set_addition> strategy, Hash refs will try to use the C<uniq_map>
+strategy, and everything else will try the C<identical> strategy.
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+David Golden <dagolden@cpan.org>
+
+=item *
+
+Ricardo Signes <rjbs@cpan.org>
+
+=item *
+
+Adam Kennedy <adamk@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Prereqs.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Prereqs.pm
new file mode 100644
index 0000000000..d4e93fd8a5
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Prereqs.pm
@@ -0,0 +1,481 @@
+use 5.006;
+use strict;
+use warnings;
+package CPAN::Meta::Prereqs;
+
+our $VERSION = '2.150010';
+
+#pod =head1 DESCRIPTION
+#pod
+#pod A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN
+#pod distribution or one of its optional features. Each set of prereqs is
+#pod organized by phase and type, as described in L<CPAN::Meta::Prereqs>.
+#pod
+#pod =cut
+
+use Carp qw(confess);
+use Scalar::Util qw(blessed);
+use CPAN::Meta::Requirements 2.121;
+
+#pod =method new
+#pod
+#pod my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec );
+#pod
+#pod This method returns a new set of Prereqs. The input should look like the
+#pod contents of the C<prereqs> field described in L<CPAN::Meta::Spec>, meaning
+#pod something more or less like this:
+#pod
+#pod my $prereq = CPAN::Meta::Prereqs->new({
+#pod runtime => {
+#pod requires => {
+#pod 'Some::Module' => '1.234',
+#pod ...,
+#pod },
+#pod ...,
+#pod },
+#pod ...,
+#pod });
+#pod
+#pod You can also construct an empty set of prereqs with:
+#pod
+#pod my $prereqs = CPAN::Meta::Prereqs->new;
+#pod
+#pod This empty set of prereqs is useful for accumulating new prereqs before finally
+#pod dumping the whole set into a structure or string.
+#pod
+#pod =cut
+
+# note we also accept anything matching /\Ax_/i
+sub __legal_phases { qw(configure build test runtime develop) }
+sub __legal_types { qw(requires recommends suggests conflicts) }
+
+# expect a prereq spec from META.json -- rjbs, 2010-04-11
+sub new {
+ my ($class, $prereq_spec) = @_;
+ $prereq_spec ||= {};
+
+ my %is_legal_phase = map {; $_ => 1 } $class->__legal_phases;
+ my %is_legal_type = map {; $_ => 1 } $class->__legal_types;
+
+ my %guts;
+ PHASE: for my $phase (keys %$prereq_spec) {
+ next PHASE unless $phase =~ /\Ax_/i or $is_legal_phase{$phase};
+
+ my $phase_spec = $prereq_spec->{ $phase };
+ next PHASE unless keys %$phase_spec;
+
+ TYPE: for my $type (keys %$phase_spec) {
+ next TYPE unless $type =~ /\Ax_/i or $is_legal_type{$type};
+
+ my $spec = $phase_spec->{ $type };
+
+ next TYPE unless keys %$spec;
+
+ $guts{prereqs}{$phase}{$type} = CPAN::Meta::Requirements->from_string_hash(
+ $spec
+ );
+ }
+ }
+
+ return bless \%guts => $class;
+}
+
+#pod =method requirements_for
+#pod
+#pod my $requirements = $prereqs->requirements_for( $phase, $type );
+#pod
+#pod This method returns a L<CPAN::Meta::Requirements> object for the given
+#pod phase/type combination. If no prerequisites are registered for that
+#pod combination, a new CPAN::Meta::Requirements object will be returned, and it may
+#pod be added to as needed.
+#pod
+#pod If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will
+#pod be raised.
+#pod
+#pod =cut
+
+sub requirements_for {
+ my ($self, $phase, $type) = @_;
+
+ confess "requirements_for called without phase" unless defined $phase;
+ confess "requirements_for called without type" unless defined $type;
+
+ unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) {
+ confess "requested requirements for unknown phase: $phase";
+ }
+
+ unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) {
+ confess "requested requirements for unknown type: $type";
+ }
+
+ my $req = ($self->{prereqs}{$phase}{$type} ||= CPAN::Meta::Requirements->new);
+
+ $req->finalize if $self->is_finalized;
+
+ return $req;
+}
+
+#pod =method phases
+#pod
+#pod my @phases = $prereqs->phases;
+#pod
+#pod This method returns the list of all phases currently populated in the prereqs
+#pod object, suitable for iterating.
+#pod
+#pod =cut
+
+sub phases {
+ my ($self) = @_;
+
+ my %is_legal_phase = map {; $_ => 1 } $self->__legal_phases;
+ grep { /\Ax_/i or $is_legal_phase{$_} } keys %{ $self->{prereqs} };
+}
+
+#pod =method types_in
+#pod
+#pod my @runtime_types = $prereqs->types_in('runtime');
+#pod
+#pod This method returns the list of all types currently populated in the prereqs
+#pod object for the provided phase, suitable for iterating.
+#pod
+#pod =cut
+
+sub types_in {
+ my ($self, $phase) = @_;
+
+ return unless $phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases;
+
+ my %is_legal_type = map {; $_ => 1 } $self->__legal_types;
+ grep { /\Ax_/i or $is_legal_type{$_} } keys %{ $self->{prereqs}{$phase} };
+}
+
+#pod =method with_merged_prereqs
+#pod
+#pod my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs );
+#pod
+#pod my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs );
+#pod
+#pod This method returns a new CPAN::Meta::Prereqs objects in which all the
+#pod other prerequisites given are merged into the current set. This is primarily
+#pod provided for combining a distribution's core prereqs with the prereqs of one of
+#pod its optional features.
+#pod
+#pod The new prereqs object has no ties to the originals, and altering it further
+#pod will not alter them.
+#pod
+#pod =cut
+
+sub with_merged_prereqs {
+ my ($self, $other) = @_;
+
+ my @other = blessed($other) ? $other : @$other;
+
+ my @prereq_objs = ($self, @other);
+
+ my %new_arg;
+
+ for my $phase (__uniq(map { $_->phases } @prereq_objs)) {
+ for my $type (__uniq(map { $_->types_in($phase) } @prereq_objs)) {
+
+ my $req = CPAN::Meta::Requirements->new;
+
+ for my $prereq (@prereq_objs) {
+ my $this_req = $prereq->requirements_for($phase, $type);
+ next unless $this_req->required_modules;
+
+ $req->add_requirements($this_req);
+ }
+
+ next unless $req->required_modules;
+
+ $new_arg{ $phase }{ $type } = $req->as_string_hash;
+ }
+ }
+
+ return (ref $self)->new(\%new_arg);
+}
+
+#pod =method merged_requirements
+#pod
+#pod my $new_reqs = $prereqs->merged_requirements( \@phases, \@types );
+#pod my $new_reqs = $prereqs->merged_requirements( \@phases );
+#pod my $new_reqs = $prereqs->merged_requirements();
+#pod
+#pod This method joins together all requirements across a number of phases
+#pod and types into a new L<CPAN::Meta::Requirements> object. If arguments
+#pod are omitted, it defaults to "runtime", "build" and "test" for phases
+#pod and "requires" and "recommends" for types.
+#pod
+#pod =cut
+
+sub merged_requirements {
+ my ($self, $phases, $types) = @_;
+ $phases = [qw/runtime build test/] unless defined $phases;
+ $types = [qw/requires recommends/] unless defined $types;
+
+ confess "merged_requirements phases argument must be an arrayref"
+ unless ref $phases eq 'ARRAY';
+ confess "merged_requirements types argument must be an arrayref"
+ unless ref $types eq 'ARRAY';
+
+ my $req = CPAN::Meta::Requirements->new;
+
+ for my $phase ( @$phases ) {
+ unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) {
+ confess "requested requirements for unknown phase: $phase";
+ }
+ for my $type ( @$types ) {
+ unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) {
+ confess "requested requirements for unknown type: $type";
+ }
+ $req->add_requirements( $self->requirements_for($phase, $type) );
+ }
+ }
+
+ $req->finalize if $self->is_finalized;
+
+ return $req;
+}
+
+
+#pod =method as_string_hash
+#pod
+#pod This method returns a hashref containing structures suitable for dumping into a
+#pod distmeta data structure. It is made up of hashes and strings, only; there will
+#pod be no Prereqs, CPAN::Meta::Requirements, or C<version> objects inside it.
+#pod
+#pod =cut
+
+sub as_string_hash {
+ my ($self) = @_;
+
+ my %hash;
+
+ for my $phase ($self->phases) {
+ for my $type ($self->types_in($phase)) {
+ my $req = $self->requirements_for($phase, $type);
+ next unless $req->required_modules;
+
+ $hash{ $phase }{ $type } = $req->as_string_hash;
+ }
+ }
+
+ return \%hash;
+}
+
+#pod =method is_finalized
+#pod
+#pod This method returns true if the set of prereqs has been marked "finalized," and
+#pod cannot be altered.
+#pod
+#pod =cut
+
+sub is_finalized { $_[0]{finalized} }
+
+#pod =method finalize
+#pod
+#pod Calling C<finalize> on a Prereqs object will close it for further modification.
+#pod Attempting to make any changes that would actually alter the prereqs will
+#pod result in an exception being thrown.
+#pod
+#pod =cut
+
+sub finalize {
+ my ($self) = @_;
+
+ $self->{finalized} = 1;
+
+ for my $phase (keys %{ $self->{prereqs} }) {
+ $_->finalize for values %{ $self->{prereqs}{$phase} };
+ }
+}
+
+#pod =method clone
+#pod
+#pod my $cloned_prereqs = $prereqs->clone;
+#pod
+#pod This method returns a Prereqs object that is identical to the original object,
+#pod but can be altered without affecting the original object. Finalization does
+#pod not survive cloning, meaning that you may clone a finalized set of prereqs and
+#pod then modify the clone.
+#pod
+#pod =cut
+
+sub clone {
+ my ($self) = @_;
+
+ my $clone = (ref $self)->new( $self->as_string_hash );
+}
+
+sub __uniq {
+ my (%s, $u);
+ grep { defined($_) ? !$s{$_}++ : !$u++ } @_;
+}
+
+1;
+
+# ABSTRACT: a set of distribution prerequisites by phase and type
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+CPAN::Meta::Prereqs - a set of distribution prerequisites by phase and type
+
+=head1 VERSION
+
+version 2.150010
+
+=head1 DESCRIPTION
+
+A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN
+distribution or one of its optional features. Each set of prereqs is
+organized by phase and type, as described in L<CPAN::Meta::Prereqs>.
+
+=head1 METHODS
+
+=head2 new
+
+ my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec );
+
+This method returns a new set of Prereqs. The input should look like the
+contents of the C<prereqs> field described in L<CPAN::Meta::Spec>, meaning
+something more or less like this:
+
+ my $prereq = CPAN::Meta::Prereqs->new({
+ runtime => {
+ requires => {
+ 'Some::Module' => '1.234',
+ ...,
+ },
+ ...,
+ },
+ ...,
+ });
+
+You can also construct an empty set of prereqs with:
+
+ my $prereqs = CPAN::Meta::Prereqs->new;
+
+This empty set of prereqs is useful for accumulating new prereqs before finally
+dumping the whole set into a structure or string.
+
+=head2 requirements_for
+
+ my $requirements = $prereqs->requirements_for( $phase, $type );
+
+This method returns a L<CPAN::Meta::Requirements> object for the given
+phase/type combination. If no prerequisites are registered for that
+combination, a new CPAN::Meta::Requirements object will be returned, and it may
+be added to as needed.
+
+If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will
+be raised.
+
+=head2 phases
+
+ my @phases = $prereqs->phases;
+
+This method returns the list of all phases currently populated in the prereqs
+object, suitable for iterating.
+
+=head2 types_in
+
+ my @runtime_types = $prereqs->types_in('runtime');
+
+This method returns the list of all types currently populated in the prereqs
+object for the provided phase, suitable for iterating.
+
+=head2 with_merged_prereqs
+
+ my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs );
+
+ my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs );
+
+This method returns a new CPAN::Meta::Prereqs objects in which all the
+other prerequisites given are merged into the current set. This is primarily
+provided for combining a distribution's core prereqs with the prereqs of one of
+its optional features.
+
+The new prereqs object has no ties to the originals, and altering it further
+will not alter them.
+
+=head2 merged_requirements
+
+ my $new_reqs = $prereqs->merged_requirements( \@phases, \@types );
+ my $new_reqs = $prereqs->merged_requirements( \@phases );
+ my $new_reqs = $prereqs->merged_requirements();
+
+This method joins together all requirements across a number of phases
+and types into a new L<CPAN::Meta::Requirements> object. If arguments
+are omitted, it defaults to "runtime", "build" and "test" for phases
+and "requires" and "recommends" for types.
+
+=head2 as_string_hash
+
+This method returns a hashref containing structures suitable for dumping into a
+distmeta data structure. It is made up of hashes and strings, only; there will
+be no Prereqs, CPAN::Meta::Requirements, or C<version> objects inside it.
+
+=head2 is_finalized
+
+This method returns true if the set of prereqs has been marked "finalized," and
+cannot be altered.
+
+=head2 finalize
+
+Calling C<finalize> on a Prereqs object will close it for further modification.
+Attempting to make any changes that would actually alter the prereqs will
+result in an exception being thrown.
+
+=head2 clone
+
+ my $cloned_prereqs = $prereqs->clone;
+
+This method returns a Prereqs object that is identical to the original object,
+but can be altered without affecting the original object. Finalization does
+not survive cloning, meaning that you may clone a finalized set of prereqs and
+then modify the clone.
+
+=head1 BUGS
+
+Please report any bugs or feature using the CPAN Request Tracker.
+Bugs can be submitted through the web interface at
+L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
+
+When submitting a bug or request, please include a test-file or a patch to an
+existing test-file that illustrates the bug or desired feature.
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+David Golden <dagolden@cpan.org>
+
+=item *
+
+Ricardo Signes <rjbs@cpan.org>
+
+=item *
+
+Adam Kennedy <adamk@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
+
+__END__
+
+
+# vim: ts=2 sts=2 sw=2 et :
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Requirements.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Requirements.pm
new file mode 100644
index 0000000000..b0e83b0d2d
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Requirements.pm
@@ -0,0 +1,1194 @@
+use 5.006; # keep at v5.6 for CPAN.pm
+use strict;
+use warnings;
+package CPAN::Meta::Requirements;
+# ABSTRACT: a set of version requirements for a CPAN dist
+
+our $VERSION = '2.140';
+
+#pod =head1 SYNOPSIS
+#pod
+#pod use CPAN::Meta::Requirements;
+#pod
+#pod my $build_requires = CPAN::Meta::Requirements->new;
+#pod
+#pod $build_requires->add_minimum('Library::Foo' => 1.208);
+#pod
+#pod $build_requires->add_minimum('Library::Foo' => 2.602);
+#pod
+#pod $build_requires->add_minimum('Module::Bar' => 'v1.2.3');
+#pod
+#pod $METAyml->{build_requires} = $build_requires->as_string_hash;
+#pod
+#pod =head1 DESCRIPTION
+#pod
+#pod A CPAN::Meta::Requirements object models a set of version constraints like
+#pod those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
+#pod and as defined by L<CPAN::Meta::Spec>;
+#pod It can be built up by adding more and more constraints, and it will reduce them
+#pod to the simplest representation.
+#pod
+#pod Logically impossible constraints will be identified immediately by thrown
+#pod exceptions.
+#pod
+#pod =cut
+
+use Carp ();
+
+# To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls
+# before 5.10, we fall back to the EUMM bundled compatibility version module if
+# that's the only thing available. This shouldn't ever happen in a normal CPAN
+# install of CPAN::Meta::Requirements, as version.pm will be picked up from
+# prereqs and be available at runtime.
+
+BEGIN {
+ eval "use version ()"; ## no critic
+ if ( my $err = $@ ) {
+ eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic
+ }
+}
+
+# Perl 5.10.0 didn't have "is_qv" in version.pm
+*_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} };
+
+# construct once, reuse many times
+my $V0 = version->new(0);
+
+#pod =method new
+#pod
+#pod my $req = CPAN::Meta::Requirements->new;
+#pod
+#pod This returns a new CPAN::Meta::Requirements object. It takes an optional
+#pod hash reference argument. Currently, only one key is supported:
+#pod
+#pod =for :list
+#pod * C<bad_version_hook> -- if provided, when a version cannot be parsed into
+#pod a version object, this code reference will be called with the invalid
+#pod version string as first argument, and the module name as second
+#pod argument. It must return a valid version object.
+#pod
+#pod All other keys are ignored.
+#pod
+#pod =cut
+
+my @valid_options = qw( bad_version_hook );
+
+sub new {
+ my ($class, $options) = @_;
+ $options ||= {};
+ Carp::croak "Argument to $class\->new() must be a hash reference"
+ unless ref $options eq 'HASH';
+ my %self = map {; $_ => $options->{$_}} @valid_options;
+
+ return bless \%self => $class;
+}
+
+# from version::vpp
+sub _find_magic_vstring {
+ my $value = shift;
+ my $tvalue = '';
+ require B;
+ my $sv = B::svref_2object(\$value);
+ my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
+ while ( $magic ) {
+ if ( $magic->TYPE eq 'V' ) {
+ $tvalue = $magic->PTR;
+ $tvalue =~ s/^v?(.+)$/v$1/;
+ last;
+ }
+ else {
+ $magic = $magic->MOREMAGIC;
+ }
+ }
+ return $tvalue;
+}
+
+# safe if given an unblessed reference
+sub _isa_version {
+ UNIVERSAL::isa( $_[0], 'UNIVERSAL' ) && $_[0]->isa('version')
+}
+
+sub _version_object {
+ my ($self, $module, $version) = @_;
+
+ my ($vobj, $err);
+
+ if (not defined $version or (!ref($version) && $version eq '0')) {
+ return $V0;
+ }
+ elsif ( ref($version) eq 'version' || ( ref($version) && _isa_version($version) ) ) {
+ $vobj = $version;
+ }
+ else {
+ # hack around version::vpp not handling <3 character vstring literals
+ if ( $INC{'version/vpp.pm'} || $INC{'ExtUtils/MakeMaker/version/vpp.pm'} ) {
+ my $magic = _find_magic_vstring( $version );
+ $version = $magic if length $magic;
+ }
+ # pad to 3 characters if before 5.8.1 and appears to be a v-string
+ if ( $] < 5.008001 && $version !~ /\A[0-9]/ && substr($version,0,1) ne 'v' && length($version) < 3 ) {
+ $version .= "\0" x (3 - length($version));
+ }
+ eval {
+ local $SIG{__WARN__} = sub { die "Invalid version: $_[0]" };
+ # avoid specific segfault on some older version.pm versions
+ die "Invalid version: $version" if $version eq 'version';
+ $vobj = version->new($version);
+ };
+ if ( my $err = $@ ) {
+ my $hook = $self->{bad_version_hook};
+ $vobj = eval { $hook->($version, $module) }
+ if ref $hook eq 'CODE';
+ unless (eval { $vobj->isa("version") }) {
+ $err =~ s{ at .* line \d+.*$}{};
+ die "Can't convert '$version': $err";
+ }
+ }
+ }
+
+ # ensure no leading '.'
+ if ( $vobj =~ m{\A\.} ) {
+ $vobj = version->new("0$vobj");
+ }
+
+ # ensure normal v-string form
+ if ( _is_qv($vobj) ) {
+ $vobj = version->new($vobj->normal);
+ }
+
+ return $vobj;
+}
+
+#pod =method add_minimum
+#pod
+#pod $req->add_minimum( $module => $version );
+#pod
+#pod This adds a new minimum version requirement. If the new requirement is
+#pod redundant to the existing specification, this has no effect.
+#pod
+#pod Minimum requirements are inclusive. C<$version> is required, along with any
+#pod greater version number.
+#pod
+#pod This method returns the requirements object.
+#pod
+#pod =method add_maximum
+#pod
+#pod $req->add_maximum( $module => $version );
+#pod
+#pod This adds a new maximum version requirement. If the new requirement is
+#pod redundant to the existing specification, this has no effect.
+#pod
+#pod Maximum requirements are inclusive. No version strictly greater than the given
+#pod version is allowed.
+#pod
+#pod This method returns the requirements object.
+#pod
+#pod =method add_exclusion
+#pod
+#pod $req->add_exclusion( $module => $version );
+#pod
+#pod This adds a new excluded version. For example, you might use these three
+#pod method calls:
+#pod
+#pod $req->add_minimum( $module => '1.00' );
+#pod $req->add_maximum( $module => '1.82' );
+#pod
+#pod $req->add_exclusion( $module => '1.75' );
+#pod
+#pod Any version between 1.00 and 1.82 inclusive would be acceptable, except for
+#pod 1.75.
+#pod
+#pod This method returns the requirements object.
+#pod
+#pod =method exact_version
+#pod
+#pod $req->exact_version( $module => $version );
+#pod
+#pod This sets the version required for the given module to I<exactly> the given
+#pod version. No other version would be considered acceptable.
+#pod
+#pod This method returns the requirements object.
+#pod
+#pod =cut
+
+BEGIN {
+ for my $type (qw(maximum exclusion exact_version)) {
+ my $method = "with_$type";
+ my $to_add = $type eq 'exact_version' ? $type : "add_$type";
+
+ my $code = sub {
+ my ($self, $name, $version) = @_;
+
+ $version = $self->_version_object( $name, $version );
+
+ $self->__modify_entry_for($name, $method, $version);
+
+ return $self;
+ };
+
+ no strict 'refs';
+ *$to_add = $code;
+ }
+}
+
+# add_minimum is optimized compared to generated subs above because
+# it is called frequently and with "0" or equivalent input
+sub add_minimum {
+ my ($self, $name, $version) = @_;
+
+ # stringify $version so that version->new("0.00")->stringify ne "0"
+ # which preserves the user's choice of "0.00" as the requirement
+ if (not defined $version or "$version" eq '0') {
+ return $self if $self->__entry_for($name);
+ Carp::confess("can't add new requirements to finalized requirements")
+ if $self->is_finalized;
+
+ $self->{requirements}{ $name } =
+ CPAN::Meta::Requirements::_Range::Range->with_minimum($V0, $name);
+ }
+ else {
+ $version = $self->_version_object( $name, $version );
+
+ $self->__modify_entry_for($name, 'with_minimum', $version);
+ }
+ return $self;
+}
+
+#pod =method add_requirements
+#pod
+#pod $req->add_requirements( $another_req_object );
+#pod
+#pod This method adds all the requirements in the given CPAN::Meta::Requirements
+#pod object to the requirements object on which it was called. If there are any
+#pod conflicts, an exception is thrown.
+#pod
+#pod This method returns the requirements object.
+#pod
+#pod =cut
+
+sub add_requirements {
+ my ($self, $req) = @_;
+
+ for my $module ($req->required_modules) {
+ my $modifiers = $req->__entry_for($module)->as_modifiers;
+ for my $modifier (@$modifiers) {
+ my ($method, @args) = @$modifier;
+ $self->$method($module => @args);
+ };
+ }
+
+ return $self;
+}
+
+#pod =method accepts_module
+#pod
+#pod my $bool = $req->accepts_module($module => $version);
+#pod
+#pod Given an module and version, this method returns true if the version
+#pod specification for the module accepts the provided version. In other words,
+#pod given:
+#pod
+#pod Module => '>= 1.00, < 2.00'
+#pod
+#pod We will accept 1.00 and 1.75 but not 0.50 or 2.00.
+#pod
+#pod For modules that do not appear in the requirements, this method will return
+#pod true.
+#pod
+#pod =cut
+
+sub accepts_module {
+ my ($self, $module, $version) = @_;
+
+ $version = $self->_version_object( $module, $version );
+
+ return 1 unless my $range = $self->__entry_for($module);
+ return $range->_accepts($version);
+}
+
+#pod =method clear_requirement
+#pod
+#pod $req->clear_requirement( $module );
+#pod
+#pod This removes the requirement for a given module from the object.
+#pod
+#pod This method returns the requirements object.
+#pod
+#pod =cut
+
+sub clear_requirement {
+ my ($self, $module) = @_;
+
+ return $self unless $self->__entry_for($module);
+
+ Carp::confess("can't clear requirements on finalized requirements")
+ if $self->is_finalized;
+
+ delete $self->{requirements}{ $module };
+
+ return $self;
+}
+
+#pod =method requirements_for_module
+#pod
+#pod $req->requirements_for_module( $module );
+#pod
+#pod This returns a string containing the version requirements for a given module in
+#pod the format described in L<CPAN::Meta::Spec> or undef if the given module has no
+#pod requirements. This should only be used for informational purposes such as error
+#pod messages and should not be interpreted or used for comparison (see
+#pod L</accepts_module> instead).
+#pod
+#pod =cut
+
+sub requirements_for_module {
+ my ($self, $module) = @_;
+ my $entry = $self->__entry_for($module);
+ return unless $entry;
+ return $entry->as_string;
+}
+
+#pod =method structured_requirements_for_module
+#pod
+#pod $req->structured_requirements_for_module( $module );
+#pod
+#pod This returns a data structure containing the version requirements for a given
+#pod module or undef if the given module has no requirements. This should
+#pod not be used for version checks (see L</accepts_module> instead).
+#pod
+#pod Added in version 2.134.
+#pod
+#pod =cut
+
+sub structured_requirements_for_module {
+ my ($self, $module) = @_;
+ my $entry = $self->__entry_for($module);
+ return unless $entry;
+ return $entry->as_struct;
+}
+
+#pod =method required_modules
+#pod
+#pod This method returns a list of all the modules for which requirements have been
+#pod specified.
+#pod
+#pod =cut
+
+sub required_modules { keys %{ $_[0]{requirements} } }
+
+#pod =method clone
+#pod
+#pod $req->clone;
+#pod
+#pod This method returns a clone of the invocant. The clone and the original object
+#pod can then be changed independent of one another.
+#pod
+#pod =cut
+
+sub clone {
+ my ($self) = @_;
+ my $new = (ref $self)->new;
+
+ return $new->add_requirements($self);
+}
+
+sub __entry_for { $_[0]{requirements}{ $_[1] } }
+
+sub __modify_entry_for {
+ my ($self, $name, $method, $version) = @_;
+
+ my $fin = $self->is_finalized;
+ my $old = $self->__entry_for($name);
+
+ Carp::confess("can't add new requirements to finalized requirements")
+ if $fin and not $old;
+
+ my $new = ($old || 'CPAN::Meta::Requirements::_Range::Range')
+ ->$method($version, $name);
+
+ Carp::confess("can't modify finalized requirements")
+ if $fin and $old->as_string ne $new->as_string;
+
+ $self->{requirements}{ $name } = $new;
+}
+
+#pod =method is_simple
+#pod
+#pod This method returns true if and only if all requirements are inclusive minimums
+#pod -- that is, if their string expression is just the version number.
+#pod
+#pod =cut
+
+sub is_simple {
+ my ($self) = @_;
+ for my $module ($self->required_modules) {
+ # XXX: This is a complete hack, but also entirely correct.
+ return if $self->__entry_for($module)->as_string =~ /\s/;
+ }
+
+ return 1;
+}
+
+#pod =method is_finalized
+#pod
+#pod This method returns true if the requirements have been finalized by having the
+#pod C<finalize> method called on them.
+#pod
+#pod =cut
+
+sub is_finalized { $_[0]{finalized} }
+
+#pod =method finalize
+#pod
+#pod This method marks the requirements finalized. Subsequent attempts to change
+#pod the requirements will be fatal, I<if> they would result in a change. If they
+#pod would not alter the requirements, they have no effect.
+#pod
+#pod If a finalized set of requirements is cloned, the cloned requirements are not
+#pod also finalized.
+#pod
+#pod =cut
+
+sub finalize { $_[0]{finalized} = 1 }
+
+#pod =method as_string_hash
+#pod
+#pod This returns a reference to a hash describing the requirements using the
+#pod strings in the L<CPAN::Meta::Spec> specification.
+#pod
+#pod For example after the following program:
+#pod
+#pod my $req = CPAN::Meta::Requirements->new;
+#pod
+#pod $req->add_minimum('CPAN::Meta::Requirements' => 0.102);
+#pod
+#pod $req->add_minimum('Library::Foo' => 1.208);
+#pod
+#pod $req->add_maximum('Library::Foo' => 2.602);
+#pod
+#pod $req->add_minimum('Module::Bar' => 'v1.2.3');
+#pod
+#pod $req->add_exclusion('Module::Bar' => 'v1.2.8');
+#pod
+#pod $req->exact_version('Xyzzy' => '6.01');
+#pod
+#pod my $hashref = $req->as_string_hash;
+#pod
+#pod C<$hashref> would contain:
+#pod
+#pod {
+#pod 'CPAN::Meta::Requirements' => '0.102',
+#pod 'Library::Foo' => '>= 1.208, <= 2.206',
+#pod 'Module::Bar' => '>= v1.2.3, != v1.2.8',
+#pod 'Xyzzy' => '== 6.01',
+#pod }
+#pod
+#pod =cut
+
+sub as_string_hash {
+ my ($self) = @_;
+
+ my %hash = map {; $_ => $self->{requirements}{$_}->as_string }
+ $self->required_modules;
+
+ return \%hash;
+}
+
+#pod =method add_string_requirement
+#pod
+#pod $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206');
+#pod $req->add_string_requirement('Library::Foo' => v1.208);
+#pod
+#pod This method parses the passed in string and adds the appropriate requirement
+#pod for the given module. A version can be a Perl "v-string". It understands
+#pod version ranges as described in the L<CPAN::Meta::Spec/Version Ranges>. For
+#pod example:
+#pod
+#pod =over 4
+#pod
+#pod =item 1.3
+#pod
+#pod =item >= 1.3
+#pod
+#pod =item <= 1.3
+#pod
+#pod =item == 1.3
+#pod
+#pod =item != 1.3
+#pod
+#pod =item > 1.3
+#pod
+#pod =item < 1.3
+#pod
+#pod =item >= 1.3, != 1.5, <= 2.0
+#pod
+#pod A version number without an operator is equivalent to specifying a minimum
+#pod (C<E<gt>=>). Extra whitespace is allowed.
+#pod
+#pod =back
+#pod
+#pod =cut
+
+my %methods_for_op = (
+ '==' => [ qw(exact_version) ],
+ '!=' => [ qw(add_exclusion) ],
+ '>=' => [ qw(add_minimum) ],
+ '<=' => [ qw(add_maximum) ],
+ '>' => [ qw(add_minimum add_exclusion) ],
+ '<' => [ qw(add_maximum add_exclusion) ],
+);
+
+sub add_string_requirement {
+ my ($self, $module, $req) = @_;
+
+ unless ( defined $req && length $req ) {
+ $req = 0;
+ $self->_blank_carp($module);
+ }
+
+ my $magic = _find_magic_vstring( $req );
+ if (length $magic) {
+ $self->add_minimum($module => $magic);
+ return;
+ }
+
+ my @parts = split qr{\s*,\s*}, $req;
+
+ for my $part (@parts) {
+ my ($op, $ver) = $part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z};
+
+ if (! defined $op) {
+ $self->add_minimum($module => $part);
+ } else {
+ Carp::confess("illegal requirement string: $req")
+ unless my $methods = $methods_for_op{ $op };
+
+ $self->$_($module => $ver) for @$methods;
+ }
+ }
+}
+
+#pod =method from_string_hash
+#pod
+#pod my $req = CPAN::Meta::Requirements->from_string_hash( \%hash );
+#pod my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts );
+#pod
+#pod This is an alternate constructor for a CPAN::Meta::Requirements
+#pod object. It takes a hash of module names and version requirement
+#pod strings and returns a new CPAN::Meta::Requirements object. As with
+#pod add_string_requirement, a version can be a Perl "v-string". Optionally,
+#pod you can supply a hash-reference of options, exactly as with the L</new>
+#pod method.
+#pod
+#pod =cut
+
+sub _blank_carp {
+ my ($self, $module) = @_;
+ Carp::carp("Undefined requirement for $module treated as '0'");
+}
+
+sub from_string_hash {
+ my ($class, $hash, $options) = @_;
+
+ my $self = $class->new($options);
+
+ for my $module (keys %$hash) {
+ my $req = $hash->{$module};
+ unless ( defined $req && length $req ) {
+ $req = 0;
+ $class->_blank_carp($module);
+ }
+ $self->add_string_requirement($module, $req);
+ }
+
+ return $self;
+}
+
+##############################################################
+
+{
+ package
+ CPAN::Meta::Requirements::_Range::Exact;
+ sub _new { bless { version => $_[1] } => $_[0] }
+
+ sub _accepts { return $_[0]{version} == $_[1] }
+
+ sub as_string { return "== $_[0]{version}" }
+
+ sub as_struct { return [ [ '==', "$_[0]{version}" ] ] }
+
+ sub as_modifiers { return [ [ exact_version => $_[0]{version} ] ] }
+
+ sub _reject_requirements {
+ my ($self, $module, $error) = @_;
+ Carp::confess("illegal requirements for $module: $error")
+ }
+
+ sub _clone {
+ (ref $_[0])->_new( version->new( $_[0]{version} ) )
+ }
+
+ sub with_exact_version {
+ my ($self, $version, $module) = @_;
+ $module = 'module' unless defined $module;
+
+ return $self->_clone if $self->_accepts($version);
+
+ $self->_reject_requirements(
+ $module,
+ "can't be exactly $version when exact requirement is already $self->{version}",
+ );
+ }
+
+ sub with_minimum {
+ my ($self, $minimum, $module) = @_;
+ $module = 'module' unless defined $module;
+
+ return $self->_clone if $self->{version} >= $minimum;
+ $self->_reject_requirements(
+ $module,
+ "minimum $minimum exceeds exact specification $self->{version}",
+ );
+ }
+
+ sub with_maximum {
+ my ($self, $maximum, $module) = @_;
+ $module = 'module' unless defined $module;
+
+ return $self->_clone if $self->{version} <= $maximum;
+ $self->_reject_requirements(
+ $module,
+ "maximum $maximum below exact specification $self->{version}",
+ );
+ }
+
+ sub with_exclusion {
+ my ($self, $exclusion, $module) = @_;
+ $module = 'module' unless defined $module;
+
+ return $self->_clone unless $exclusion == $self->{version};
+ $self->_reject_requirements(
+ $module,
+ "tried to exclude $exclusion, which is already exactly specified",
+ );
+ }
+}
+
+##############################################################
+
+{
+ package
+ CPAN::Meta::Requirements::_Range::Range;
+
+ sub _self { ref($_[0]) ? $_[0] : (bless { } => $_[0]) }
+
+ sub _clone {
+ return (bless { } => $_[0]) unless ref $_[0];
+
+ my ($s) = @_;
+ my %guts = (
+ (exists $s->{minimum} ? (minimum => version->new($s->{minimum})) : ()),
+ (exists $s->{maximum} ? (maximum => version->new($s->{maximum})) : ()),
+
+ (exists $s->{exclusions}
+ ? (exclusions => [ map { version->new($_) } @{ $s->{exclusions} } ])
+ : ()),
+ );
+
+ bless \%guts => ref($s);
+ }
+
+ sub as_modifiers {
+ my ($self) = @_;
+ my @mods;
+ push @mods, [ add_minimum => $self->{minimum} ] if exists $self->{minimum};
+ push @mods, [ add_maximum => $self->{maximum} ] if exists $self->{maximum};
+ push @mods, map {; [ add_exclusion => $_ ] } @{$self->{exclusions} || []};
+ return \@mods;
+ }
+
+ sub as_struct {
+ my ($self) = @_;
+
+ return 0 if ! keys %$self;
+
+ my @exclusions = @{ $self->{exclusions} || [] };
+
+ my @parts;
+
+ for my $tuple (
+ [ qw( >= > minimum ) ],
+ [ qw( <= < maximum ) ],
+ ) {
+ my ($op, $e_op, $k) = @$tuple;
+ if (exists $self->{$k}) {
+ my @new_exclusions = grep { $_ != $self->{ $k } } @exclusions;
+ if (@new_exclusions == @exclusions) {
+ push @parts, [ $op, "$self->{ $k }" ];
+ } else {
+ push @parts, [ $e_op, "$self->{ $k }" ];
+ @exclusions = @new_exclusions;
+ }
+ }
+ }
+
+ push @parts, map {; [ "!=", "$_" ] } @exclusions;
+
+ return \@parts;
+ }
+
+ sub as_string {
+ my ($self) = @_;
+
+ my @parts = @{ $self->as_struct };
+
+ return $parts[0][1] if @parts == 1 and $parts[0][0] eq '>=';
+
+ return join q{, }, map {; join q{ }, @$_ } @parts;
+ }
+
+ sub _reject_requirements {
+ my ($self, $module, $error) = @_;
+ Carp::confess("illegal requirements for $module: $error")
+ }
+
+ sub with_exact_version {
+ my ($self, $version, $module) = @_;
+ $module = 'module' unless defined $module;
+ $self = $self->_clone;
+
+ unless ($self->_accepts($version)) {
+ $self->_reject_requirements(
+ $module,
+ "exact specification $version outside of range " . $self->as_string
+ );
+ }
+
+ return CPAN::Meta::Requirements::_Range::Exact->_new($version);
+ }
+
+ sub _simplify {
+ my ($self, $module) = @_;
+
+ if (defined $self->{minimum} and defined $self->{maximum}) {
+ if ($self->{minimum} == $self->{maximum}) {
+ if (grep { $_ == $self->{minimum} } @{ $self->{exclusions} || [] }) {
+ $self->_reject_requirements(
+ $module,
+ "minimum and maximum are both $self->{minimum}, which is excluded",
+ );
+ }
+
+ return CPAN::Meta::Requirements::_Range::Exact->_new($self->{minimum})
+ }
+
+ if ($self->{minimum} > $self->{maximum}) {
+ $self->_reject_requirements(
+ $module,
+ "minimum $self->{minimum} exceeds maximum $self->{maximum}",
+ );
+ }
+ }
+
+ # eliminate irrelevant exclusions
+ if ($self->{exclusions}) {
+ my %seen;
+ @{ $self->{exclusions} } = grep {
+ (! defined $self->{minimum} or $_ >= $self->{minimum})
+ and
+ (! defined $self->{maximum} or $_ <= $self->{maximum})
+ and
+ ! $seen{$_}++
+ } @{ $self->{exclusions} };
+ }
+
+ return $self;
+ }
+
+ sub with_minimum {
+ my ($self, $minimum, $module) = @_;
+ $module = 'module' unless defined $module;
+ $self = $self->_clone;
+
+ if (defined (my $old_min = $self->{minimum})) {
+ $self->{minimum} = (sort { $b cmp $a } ($minimum, $old_min))[0];
+ } else {
+ $self->{minimum} = $minimum;
+ }
+
+ return $self->_simplify($module);
+ }
+
+ sub with_maximum {
+ my ($self, $maximum, $module) = @_;
+ $module = 'module' unless defined $module;
+ $self = $self->_clone;
+
+ if (defined (my $old_max = $self->{maximum})) {
+ $self->{maximum} = (sort { $a cmp $b } ($maximum, $old_max))[0];
+ } else {
+ $self->{maximum} = $maximum;
+ }
+
+ return $self->_simplify($module);
+ }
+
+ sub with_exclusion {
+ my ($self, $exclusion, $module) = @_;
+ $module = 'module' unless defined $module;
+ $self = $self->_clone;
+
+ push @{ $self->{exclusions} ||= [] }, $exclusion;
+
+ return $self->_simplify($module);
+ }
+
+ sub _accepts {
+ my ($self, $version) = @_;
+
+ return if defined $self->{minimum} and $version < $self->{minimum};
+ return if defined $self->{maximum} and $version > $self->{maximum};
+ return if defined $self->{exclusions}
+ and grep { $version == $_ } @{ $self->{exclusions} };
+
+ return 1;
+ }
+}
+
+1;
+# vim: ts=2 sts=2 sw=2 et:
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+CPAN::Meta::Requirements - a set of version requirements for a CPAN dist
+
+=head1 VERSION
+
+version 2.140
+
+=head1 SYNOPSIS
+
+ use CPAN::Meta::Requirements;
+
+ my $build_requires = CPAN::Meta::Requirements->new;
+
+ $build_requires->add_minimum('Library::Foo' => 1.208);
+
+ $build_requires->add_minimum('Library::Foo' => 2.602);
+
+ $build_requires->add_minimum('Module::Bar' => 'v1.2.3');
+
+ $METAyml->{build_requires} = $build_requires->as_string_hash;
+
+=head1 DESCRIPTION
+
+A CPAN::Meta::Requirements object models a set of version constraints like
+those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
+and as defined by L<CPAN::Meta::Spec>;
+It can be built up by adding more and more constraints, and it will reduce them
+to the simplest representation.
+
+Logically impossible constraints will be identified immediately by thrown
+exceptions.
+
+=head1 METHODS
+
+=head2 new
+
+ my $req = CPAN::Meta::Requirements->new;
+
+This returns a new CPAN::Meta::Requirements object. It takes an optional
+hash reference argument. Currently, only one key is supported:
+
+=over 4
+
+=item *
+
+C<bad_version_hook> -- if provided, when a version cannot be parsed into a version object, this code reference will be called with the invalid version string as first argument, and the module name as second argument. It must return a valid version object.
+
+=back
+
+All other keys are ignored.
+
+=head2 add_minimum
+
+ $req->add_minimum( $module => $version );
+
+This adds a new minimum version requirement. If the new requirement is
+redundant to the existing specification, this has no effect.
+
+Minimum requirements are inclusive. C<$version> is required, along with any
+greater version number.
+
+This method returns the requirements object.
+
+=head2 add_maximum
+
+ $req->add_maximum( $module => $version );
+
+This adds a new maximum version requirement. If the new requirement is
+redundant to the existing specification, this has no effect.
+
+Maximum requirements are inclusive. No version strictly greater than the given
+version is allowed.
+
+This method returns the requirements object.
+
+=head2 add_exclusion
+
+ $req->add_exclusion( $module => $version );
+
+This adds a new excluded version. For example, you might use these three
+method calls:
+
+ $req->add_minimum( $module => '1.00' );
+ $req->add_maximum( $module => '1.82' );
+
+ $req->add_exclusion( $module => '1.75' );
+
+Any version between 1.00 and 1.82 inclusive would be acceptable, except for
+1.75.
+
+This method returns the requirements object.
+
+=head2 exact_version
+
+ $req->exact_version( $module => $version );
+
+This sets the version required for the given module to I<exactly> the given
+version. No other version would be considered acceptable.
+
+This method returns the requirements object.
+
+=head2 add_requirements
+
+ $req->add_requirements( $another_req_object );
+
+This method adds all the requirements in the given CPAN::Meta::Requirements
+object to the requirements object on which it was called. If there are any
+conflicts, an exception is thrown.
+
+This method returns the requirements object.
+
+=head2 accepts_module
+
+ my $bool = $req->accepts_module($module => $version);
+
+Given an module and version, this method returns true if the version
+specification for the module accepts the provided version. In other words,
+given:
+
+ Module => '>= 1.00, < 2.00'
+
+We will accept 1.00 and 1.75 but not 0.50 or 2.00.
+
+For modules that do not appear in the requirements, this method will return
+true.
+
+=head2 clear_requirement
+
+ $req->clear_requirement( $module );
+
+This removes the requirement for a given module from the object.
+
+This method returns the requirements object.
+
+=head2 requirements_for_module
+
+ $req->requirements_for_module( $module );
+
+This returns a string containing the version requirements for a given module in
+the format described in L<CPAN::Meta::Spec> or undef if the given module has no
+requirements. This should only be used for informational purposes such as error
+messages and should not be interpreted or used for comparison (see
+L</accepts_module> instead).
+
+=head2 structured_requirements_for_module
+
+ $req->structured_requirements_for_module( $module );
+
+This returns a data structure containing the version requirements for a given
+module or undef if the given module has no requirements. This should
+not be used for version checks (see L</accepts_module> instead).
+
+Added in version 2.134.
+
+=head2 required_modules
+
+This method returns a list of all the modules for which requirements have been
+specified.
+
+=head2 clone
+
+ $req->clone;
+
+This method returns a clone of the invocant. The clone and the original object
+can then be changed independent of one another.
+
+=head2 is_simple
+
+This method returns true if and only if all requirements are inclusive minimums
+-- that is, if their string expression is just the version number.
+
+=head2 is_finalized
+
+This method returns true if the requirements have been finalized by having the
+C<finalize> method called on them.
+
+=head2 finalize
+
+This method marks the requirements finalized. Subsequent attempts to change
+the requirements will be fatal, I<if> they would result in a change. If they
+would not alter the requirements, they have no effect.
+
+If a finalized set of requirements is cloned, the cloned requirements are not
+also finalized.
+
+=head2 as_string_hash
+
+This returns a reference to a hash describing the requirements using the
+strings in the L<CPAN::Meta::Spec> specification.
+
+For example after the following program:
+
+ my $req = CPAN::Meta::Requirements->new;
+
+ $req->add_minimum('CPAN::Meta::Requirements' => 0.102);
+
+ $req->add_minimum('Library::Foo' => 1.208);
+
+ $req->add_maximum('Library::Foo' => 2.602);
+
+ $req->add_minimum('Module::Bar' => 'v1.2.3');
+
+ $req->add_exclusion('Module::Bar' => 'v1.2.8');
+
+ $req->exact_version('Xyzzy' => '6.01');
+
+ my $hashref = $req->as_string_hash;
+
+C<$hashref> would contain:
+
+ {
+ 'CPAN::Meta::Requirements' => '0.102',
+ 'Library::Foo' => '>= 1.208, <= 2.206',
+ 'Module::Bar' => '>= v1.2.3, != v1.2.8',
+ 'Xyzzy' => '== 6.01',
+ }
+
+=head2 add_string_requirement
+
+ $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206');
+ $req->add_string_requirement('Library::Foo' => v1.208);
+
+This method parses the passed in string and adds the appropriate requirement
+for the given module. A version can be a Perl "v-string". It understands
+version ranges as described in the L<CPAN::Meta::Spec/Version Ranges>. For
+example:
+
+=over 4
+
+=item 1.3
+
+=item >= 1.3
+
+=item <= 1.3
+
+=item == 1.3
+
+=item != 1.3
+
+=item > 1.3
+
+=item < 1.3
+
+=item >= 1.3, != 1.5, <= 2.0
+
+A version number without an operator is equivalent to specifying a minimum
+(C<E<gt>=>). Extra whitespace is allowed.
+
+=back
+
+=head2 from_string_hash
+
+ my $req = CPAN::Meta::Requirements->from_string_hash( \%hash );
+ my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts );
+
+This is an alternate constructor for a CPAN::Meta::Requirements
+object. It takes a hash of module names and version requirement
+strings and returns a new CPAN::Meta::Requirements object. As with
+add_string_requirement, a version can be a Perl "v-string". Optionally,
+you can supply a hash-reference of options, exactly as with the L</new>
+method.
+
+=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
+
+=head1 SUPPORT
+
+=head2 Bugs / Feature Requests
+
+Please report any bugs or feature requests through the issue tracker
+at L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements/issues>.
+You will be notified automatically of any progress on your issue.
+
+=head2 Source Code
+
+This is open source software. The code repository is available for
+public review and contribution under the terms of the license.
+
+L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements>
+
+ git clone https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements.git
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+David Golden <dagolden@cpan.org>
+
+=item *
+
+Ricardo Signes <rjbs@cpan.org>
+
+=back
+
+=head1 CONTRIBUTORS
+
+=for stopwords Ed J Karen Etheridge Leon Timmermans robario
+
+=over 4
+
+=item *
+
+Ed J <mohawk2@users.noreply.github.com>
+
+=item *
+
+Karen Etheridge <ether@cpan.org>
+
+=item *
+
+Leon Timmermans <fawaka@gmail.com>
+
+=item *
+
+robario <webmaster@robario.com>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2010 by David Golden and Ricardo Signes.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Spec.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Spec.pm
new file mode 100644
index 0000000000..16e7495938
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Spec.pm
@@ -0,0 +1,1244 @@
+# XXX RULES FOR PATCHING THIS FILE XXX
+# Patches that fix typos or formatting are acceptable. Patches
+# that change semantics are not acceptable without prior approval
+# by David Golden or Ricardo Signes.
+
+use 5.006;
+use strict;
+use warnings;
+package CPAN::Meta::Spec;
+
+our $VERSION = '2.150010';
+
+1;
+
+# ABSTRACT: specification for CPAN distribution metadata
+
+
+# vi:tw=72
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+CPAN::Meta::Spec - specification for CPAN distribution metadata
+
+=head1 VERSION
+
+version 2.150010
+
+=head1 SYNOPSIS
+
+ my $distmeta = {
+ name => 'Module-Build',
+ abstract => 'Build and install Perl modules',
+ description => "Module::Build is a system for "
+ . "building, testing, and installing Perl modules. "
+ . "It is meant to ... blah blah blah ...",
+ version => '0.36',
+ release_status => 'stable',
+ author => [
+ 'Ken Williams <kwilliams@cpan.org>',
+ 'Module-Build List <module-build@perl.org>', # additional contact
+ ],
+ license => [ 'perl_5' ],
+ prereqs => {
+ runtime => {
+ requires => {
+ 'perl' => '5.006',
+ 'ExtUtils::Install' => '0',
+ 'File::Basename' => '0',
+ 'File::Compare' => '0',
+ 'IO::File' => '0',
+ },
+ recommends => {
+ 'Archive::Tar' => '1.00',
+ 'ExtUtils::Install' => '0.3',
+ 'ExtUtils::ParseXS' => '2.02',
+ },
+ },
+ build => {
+ requires => {
+ 'Test::More' => '0',
+ },
+ }
+ },
+ resources => {
+ license => ['http://dev.perl.org/licenses/'],
+ },
+ optional_features => {
+ domination => {
+ description => 'Take over the world',
+ prereqs => {
+ develop => { requires => { 'Genius::Evil' => '1.234' } },
+ runtime => { requires => { 'Machine::Weather' => '2.0' } },
+ },
+ },
+ },
+ dynamic_config => 1,
+ keywords => [ qw/ toolchain cpan dual-life / ],
+ 'meta-spec' => {
+ version => '2',
+ url => 'https://metacpan.org/pod/CPAN::Meta::Spec',
+ },
+ generated_by => 'Module::Build version 0.36',
+ };
+
+=head1 DESCRIPTION
+
+This document describes version 2 of the CPAN distribution metadata
+specification, also known as the "CPAN Meta Spec".
+
+Revisions of this specification for typo corrections and prose
+clarifications may be issued as CPAN::Meta::Spec 2.I<x>. These
+revisions will never change semantics or add or remove specified
+behavior.
+
+Distribution metadata describe important properties of Perl
+distributions. Distribution building tools like Module::Build,
+Module::Install, ExtUtils::MakeMaker or Dist::Zilla should create a
+metadata file in accordance with this specification and include it with
+the distribution for use by automated tools that index, examine, package
+or install Perl distributions.
+
+=head1 TERMINOLOGY
+
+=over 4
+
+=item distribution
+
+This is the primary object described by the metadata. In the context of
+this document it usually refers to a collection of modules, scripts,
+and/or documents that are distributed together for other developers to
+use. Examples of distributions are C<Class-Container>, C<libwww-perl>,
+or C<DBI>.
+
+=item module
+
+This refers to a reusable library of code contained in a single file.
+Modules usually contain one or more packages and are often referred
+to by the name of a primary package that can be mapped to the file
+name. For example, one might refer to C<File::Spec> instead of
+F<File/Spec.pm>
+
+=item package
+
+This refers to a namespace declared with the Perl C<package> statement.
+In Perl, packages often have a version number property given by the
+C<$VERSION> variable in the namespace.
+
+=item consumer
+
+This refers to code that reads a metadata file, deserializes it into a
+data structure in memory, or interprets a data structure of metadata
+elements.
+
+=item producer
+
+This refers to code that constructs a metadata data structure,
+serializes into a bytestream and/or writes it to disk.
+
+=item must, should, may, etc.
+
+These terms are interpreted as described in IETF RFC 2119.
+
+=back
+
+=head1 DATA TYPES
+
+Fields in the L</STRUCTURE> section describe data elements, each of
+which has an associated data type as described herein. There are four
+primitive types: Boolean, String, List and Map. Other types are
+subtypes of primitives and define compound data structures or define
+constraints on the values of a data element.
+
+=head2 Boolean
+
+A I<Boolean> is used to provide a true or false value. It B<must> be
+represented as a defined value that is either "1" or "0" or stringifies
+to those values.
+
+=head2 String
+
+A I<String> is data element containing a non-zero length sequence of
+Unicode characters, such as an ordinary Perl scalar that is not a
+reference.
+
+=head2 List
+
+A I<List> is an ordered collection of zero or more data elements.
+Elements of a List may be of mixed types.
+
+Producers B<must> represent List elements using a data structure which
+unambiguously indicates that multiple values are possible, such as a
+reference to a Perl array (an "arrayref").
+
+Consumers expecting a List B<must> consider a String as equivalent to a
+List of length 1.
+
+=head2 Map
+
+A I<Map> is an unordered collection of zero or more data elements
+("values"), indexed by associated String elements ("keys"). The Map's
+value elements may be of mixed types.
+
+=head2 License String
+
+A I<License String> is a subtype of String with a restricted set of
+values. Valid values are described in detail in the description of
+the L</license> field.
+
+=head2 URL
+
+I<URL> is a subtype of String containing a Uniform Resource Locator or
+Identifier. [ This type is called URL and not URI for historical reasons. ]
+
+=head2 Version
+
+A I<Version> is a subtype of String containing a value that describes
+the version number of packages or distributions. Restrictions on format
+are described in detail in the L</Version Formats> section.
+
+=head2 Version Range
+
+The I<Version Range> type is a subtype of String. It describes a range
+of Versions that may be present or installed to fulfill prerequisites.
+It is specified in detail in the L</Version Ranges> section.
+
+=head1 STRUCTURE
+
+The metadata structure is a data element of type Map. This section
+describes valid keys within the Map.
+
+Any keys not described in this specification document (whether top-level
+or within compound data structures described herein) are considered
+I<custom keys> and B<must> begin with an "x" or "X" and be followed by an
+underscore; i.e. they must match the pattern: C<< qr{\Ax_}i >>. If a
+custom key refers to a compound data structure, subkeys within it do not
+need an "x_" or "X_" prefix.
+
+Consumers of metadata may ignore any or all custom keys. All other keys
+not described herein are invalid and should be ignored by consumers.
+Producers must not generate or output invalid keys.
+
+For each key, an example is provided followed by a description. The
+description begins with the version of spec in which the key was added
+or in which the definition was modified, whether the key is I<required>
+or I<optional> and the data type of the corresponding data element.
+These items are in parentheses, brackets and braces, respectively.
+
+If a data type is a Map or Map subtype, valid subkeys will be described
+as well.
+
+Some fields are marked I<Deprecated>. These are shown for historical
+context and must not be produced in or consumed from any metadata structure
+of version 2 or higher.
+
+=head2 REQUIRED FIELDS
+
+=head3 abstract
+
+Example:
+
+ abstract => 'Build and install Perl modules'
+
+(Spec 1.2) [required] {String}
+
+This is a short description of the purpose of the distribution.
+
+=head3 author
+
+Example:
+
+ author => [ 'Ken Williams <kwilliams@cpan.org>' ]
+
+(Spec 1.2) [required] {List of one or more Strings}
+
+This List indicates the person(s) to contact concerning the
+distribution. The preferred form of the contact string is:
+
+ contact-name <email-address>
+
+This field provides a general contact list independent of other
+structured fields provided within the L</resources> field, such as
+C<bugtracker>. The addressee(s) can be contacted for any purpose
+including but not limited to (security) problems with the distribution,
+questions about the distribution or bugs in the distribution.
+
+A distribution's original author is usually the contact listed within
+this field. Co-maintainers, successor maintainers or mailing lists
+devoted to the distribution may also be listed in addition to or instead
+of the original author.
+
+=head3 dynamic_config
+
+Example:
+
+ dynamic_config => 1
+
+(Spec 2) [required] {Boolean}
+
+A boolean flag indicating whether a F<Build.PL> or F<Makefile.PL> (or
+similar) must be executed to determine prerequisites.
+
+This field should be set to a true value if the distribution performs
+some dynamic configuration (asking questions, sensing the environment,
+etc.) as part of its configuration. This field should be set to a false
+value to indicate that prerequisites included in metadata may be
+considered final and valid for static analysis.
+
+Note: when this field is true, post-configuration prerequisites are not
+guaranteed to bear any relation whatsoever to those stated in the metadata,
+and relying on them doing so is an error. See also
+L</Prerequisites for dynamically configured distributions> in the implementors'
+notes.
+
+This field explicitly B<does not> indicate whether installation may be
+safely performed without using a Makefile or Build file, as there may be
+special files to install or custom installation targets (e.g. for
+dual-life modules that exist on CPAN as well as in the Perl core). This
+field only defines whether or not prerequisites are exactly as given in the
+metadata.
+
+=head3 generated_by
+
+Example:
+
+ generated_by => 'Module::Build version 0.36'
+
+(Spec 1.0) [required] {String}
+
+This field indicates the tool that was used to create this metadata.
+There are no defined semantics for this field, but it is traditional to
+use a string in the form "Generating::Package version 1.23" or the
+author's name, if the file was generated by hand.
+
+=head3 license
+
+Example:
+
+ license => [ 'perl_5' ]
+
+ license => [ 'apache_2_0', 'mozilla_1_0' ]
+
+(Spec 2) [required] {List of one or more License Strings}
+
+One or more licenses that apply to some or all of the files in the
+distribution. If multiple licenses are listed, the distribution
+documentation should be consulted to clarify the interpretation of
+multiple licenses.
+
+The following list of license strings are valid:
+
+ string description
+ ------------- -----------------------------------------------
+ agpl_3 GNU Affero General Public License, Version 3
+ apache_1_1 Apache Software License, Version 1.1
+ apache_2_0 Apache License, Version 2.0
+ artistic_1 Artistic License, (Version 1)
+ artistic_2 Artistic License, Version 2.0
+ bsd BSD License (three-clause)
+ freebsd FreeBSD License (two-clause)
+ gfdl_1_2 GNU Free Documentation License, Version 1.2
+ gfdl_1_3 GNU Free Documentation License, Version 1.3
+ gpl_1 GNU General Public License, Version 1
+ gpl_2 GNU General Public License, Version 2
+ gpl_3 GNU General Public License, Version 3
+ lgpl_2_1 GNU Lesser General Public License, Version 2.1
+ lgpl_3_0 GNU Lesser General Public License, Version 3.0
+ mit MIT (aka X11) License
+ mozilla_1_0 Mozilla Public License, Version 1.0
+ mozilla_1_1 Mozilla Public License, Version 1.1
+ openssl OpenSSL License
+ perl_5 The Perl 5 License (Artistic 1 & GPL 1 or later)
+ qpl_1_0 Q Public License, Version 1.0
+ ssleay Original SSLeay License
+ sun Sun Internet Standards Source License (SISSL)
+ zlib zlib License
+
+The following license strings are also valid and indicate other
+licensing not described above:
+
+ string description
+ ------------- -----------------------------------------------
+ open_source Other Open Source Initiative (OSI) approved license
+ restricted Requires special permission from copyright holder
+ unrestricted Not an OSI approved license, but not restricted
+ unknown License not provided in metadata
+
+All other strings are invalid in the license field.
+
+=head3 meta-spec
+
+Example:
+
+ 'meta-spec' => {
+ version => '2',
+ url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
+ }
+
+(Spec 1.2) [required] {Map}
+
+This field indicates the version of the CPAN Meta Spec that should be
+used to interpret the metadata. Consumers must check this key as soon
+as possible and abort further metadata processing if the meta-spec
+version is not supported by the consumer.
+
+The following keys are valid, but only C<version> is required.
+
+=over
+
+=item version
+
+This subkey gives the integer I<Version> of the CPAN Meta Spec against
+which the document was generated.
+
+=item url
+
+This is a I<URL> of the metadata specification document corresponding to
+the given version. This is strictly for human-consumption and should
+not impact the interpretation of the document.
+
+For the version 2 spec, either of these are recommended:
+
+=over 4
+
+=item *
+
+C<https://metacpan.org/pod/CPAN::Meta::Spec>
+
+=item *
+
+C<http://search.cpan.org/perldoc?CPAN::Meta::Spec>
+
+=back
+
+=back
+
+=head3 name
+
+Example:
+
+ name => 'Module-Build'
+
+(Spec 1.0) [required] {String}
+
+This field is the name of the distribution. This is often created by
+taking the "main package" in the distribution and changing C<::> to
+C<->, but the name may be completely unrelated to the packages within
+the distribution. For example, L<LWP::UserAgent> is distributed as part
+of the distribution name "libwww-perl".
+
+=head3 release_status
+
+Example:
+
+ release_status => 'stable'
+
+(Spec 2) [required] {String}
+
+This field provides the release status of this distribution. If the
+C<version> field contains an underscore character, then
+C<release_status> B<must not> be "stable."
+
+The C<release_status> field B<must> have one of the following values:
+
+=over
+
+=item stable
+
+This indicates an ordinary, "final" release that should be indexed by PAUSE
+or other indexers.
+
+=item testing
+
+This indicates a "beta" release that is substantially complete, but has an
+elevated risk of bugs and requires additional testing. The distribution
+should not be installed over a stable release without an explicit request
+or other confirmation from a user. This release status may also be used
+for "release candidate" versions of a distribution.
+
+=item unstable
+
+This indicates an "alpha" release that is under active development, but has
+been released for early feedback or testing and may be missing features or
+may have serious bugs. The distribution should not be installed over a
+stable release without an explicit request or other confirmation from a
+user.
+
+=back
+
+Consumers B<may> use this field to determine how to index the
+distribution for CPAN or other repositories in addition to or in
+replacement of heuristics based on version number or file name.
+
+=head3 version
+
+Example:
+
+ version => '0.36'
+
+(Spec 1.0) [required] {Version}
+
+This field gives the version of the distribution to which the metadata
+structure refers.
+
+=head2 OPTIONAL FIELDS
+
+=head3 description
+
+Example:
+
+ description => "Module::Build is a system for "
+ . "building, testing, and installing Perl modules. "
+ . "It is meant to ... blah blah blah ...",
+
+(Spec 2) [optional] {String}
+
+A longer, more complete description of the purpose or intended use of
+the distribution than the one provided by the C<abstract> key.
+
+=head3 keywords
+
+Example:
+
+ keywords => [ qw/ toolchain cpan dual-life / ]
+
+(Spec 1.1) [optional] {List of zero or more Strings}
+
+A List of keywords that describe this distribution. Keywords
+B<must not> include whitespace.
+
+=head3 no_index
+
+Example:
+
+ no_index => {
+ file => [ 'My/Module.pm' ],
+ directory => [ 'My/Private' ],
+ package => [ 'My::Module::Secret' ],
+ namespace => [ 'My::Module::Sample' ],
+ }
+
+(Spec 1.2) [optional] {Map}
+
+This Map describes any files, directories, packages, and namespaces that
+are private to the packaging or implementation of the distribution and
+should be ignored by indexing or search tools. Note that this is a list of
+exclusions, and the spec does not define what to I<include> - see
+L</Indexing distributions a la PAUSE> in the implementors notes for more
+information.
+
+Valid subkeys are as follows:
+
+=over
+
+=item file
+
+A I<List> of relative paths to files. Paths B<must be> specified with
+unix conventions.
+
+=item directory
+
+A I<List> of relative paths to directories. Paths B<must be> specified
+with unix conventions.
+
+[ Note: previous editions of the spec had C<dir> instead of C<directory> ]
+
+=item package
+
+A I<List> of package names.
+
+=item namespace
+
+A I<List> of package namespaces, where anything below the namespace
+must be ignored, but I<not> the namespace itself.
+
+In the example above for C<no_index>, C<My::Module::Sample::Foo> would
+be ignored, but C<My::Module::Sample> would not.
+
+=back
+
+=head3 optional_features
+
+Example:
+
+ optional_features => {
+ sqlite => {
+ description => 'Provides SQLite support',
+ prereqs => {
+ runtime => {
+ requires => {
+ 'DBD::SQLite' => '1.25'
+ }
+ }
+ }
+ }
+ }
+
+(Spec 2) [optional] {Map}
+
+This Map describes optional features with incremental prerequisites.
+Each key of the C<optional_features> Map is a String used to identify
+the feature and each value is a Map with additional information about
+the feature. Valid subkeys include:
+
+=over
+
+=item description
+
+This is a String describing the feature. Every optional feature
+should provide a description
+
+=item prereqs
+
+This entry is required and has the same structure as that of the
+C<L</prereqs>> key. It provides a list of package requirements
+that must be satisfied for the feature to be supported or enabled.
+
+There is one crucial restriction: the prereqs of an optional feature
+B<must not> include C<configure> phase prereqs.
+
+=back
+
+Consumers B<must not> include optional features as prerequisites without
+explicit instruction from users (whether via interactive prompting,
+a function parameter or a configuration value, etc. ).
+
+If an optional feature is used by a consumer to add additional
+prerequisites, the consumer should merge the optional feature
+prerequisites into those given by the C<prereqs> key using the same
+semantics. See L</Merging and Resolving Prerequisites> for details on
+merging prerequisites.
+
+I<Suggestion for disuse:> Because there is currently no way for a
+distribution to specify a dependency on an optional feature of another
+dependency, the use of C<optional_feature> is discouraged. Instead,
+create a separate, installable distribution that ensures the desired
+feature is available. For example, if C<Foo::Bar> has a C<Baz> feature,
+release a separate C<Foo-Bar-Baz> distribution that satisfies
+requirements for the feature.
+
+=head3 prereqs
+
+Example:
+
+ prereqs => {
+ runtime => {
+ requires => {
+ 'perl' => '5.006',
+ 'File::Spec' => '0.86',
+ 'JSON' => '2.16',
+ },
+ recommends => {
+ 'JSON::XS' => '2.26',
+ },
+ suggests => {
+ 'Archive::Tar' => '0',
+ },
+ },
+ build => {
+ requires => {
+ 'Alien::SDL' => '1.00',
+ },
+ },
+ test => {
+ recommends => {
+ 'Test::Deep' => '0.10',
+ },
+ }
+ }
+
+(Spec 2) [optional] {Map}
+
+This is a Map that describes all the prerequisites of the distribution.
+The keys are phases of activity, such as C<configure>, C<build>, C<test>
+or C<runtime>. Values are Maps in which the keys name the type of
+prerequisite relationship such as C<requires>, C<recommends>, or
+C<suggests> and the value provides a set of prerequisite relations. The
+set of relations B<must> be specified as a Map of package names to
+version ranges.
+
+The full definition for this field is given in the L</Prereq Spec>
+section.
+
+=head3 provides
+
+Example:
+
+ provides => {
+ 'Foo::Bar' => {
+ file => 'lib/Foo/Bar.pm',
+ version => '0.27_02',
+ },
+ 'Foo::Bar::Blah' => {
+ file => 'lib/Foo/Bar/Blah.pm',
+ },
+ 'Foo::Bar::Baz' => {
+ file => 'lib/Foo/Bar/Baz.pm',
+ version => '0.3',
+ },
+ }
+
+(Spec 1.2) [optional] {Map}
+
+This describes all packages provided by this distribution. This
+information is used by distribution and automation mechanisms like
+PAUSE, CPAN, metacpan.org and search.cpan.org to build indexes saying in
+which distribution various packages can be found.
+
+The keys of C<provides> are package names that can be found within
+the distribution. If a package name key is provided, it must
+have a Map with the following valid subkeys:
+
+=over
+
+=item file
+
+This field is required. It must contain a Unix-style relative file path
+from the root of the distribution directory to a file that contains or
+generates the package. It may be given as C<META.yml> or C<META.json>
+to claim a package for indexing without needing a C<*.pm>.
+
+=item version
+
+If it exists, this field must contains a I<Version> String for the
+package. If the package does not have a C<$VERSION>, this field must
+be omitted.
+
+=back
+
+=head3 resources
+
+Example:
+
+ resources => {
+ license => [ 'http://dev.perl.org/licenses/' ],
+ homepage => 'http://sourceforge.net/projects/module-build',
+ bugtracker => {
+ web => 'http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta',
+ mailto => 'meta-bugs@example.com',
+ },
+ repository => {
+ url => 'git://github.com/dagolden/cpan-meta.git',
+ web => 'http://github.com/dagolden/cpan-meta',
+ type => 'git',
+ },
+ x_twitter => 'http://twitter.com/cpan_linked/',
+ }
+
+(Spec 2) [optional] {Map}
+
+This field describes resources related to this distribution.
+
+Valid subkeys include:
+
+=over
+
+=item homepage
+
+The official home of this project on the web.
+
+=item license
+
+A List of I<URL>'s that relate to this distribution's license. As with the
+top-level C<license> field, distribution documentation should be consulted
+to clarify the interpretation of multiple licenses provided here.
+
+=item bugtracker
+
+This entry describes the bug tracking system for this distribution. It
+is a Map with the following valid keys:
+
+ web - a URL pointing to a web front-end for the bug tracker
+ mailto - an email address to which bugs can be sent
+
+=item repository
+
+This entry describes the source control repository for this distribution. It
+is a Map with the following valid keys:
+
+ url - a URL pointing to the repository itself
+ web - a URL pointing to a web front-end for the repository
+ type - a lowercase string indicating the VCS used
+
+Because a url like C<http://myrepo.example.com/> is ambiguous as to
+type, producers should provide a C<type> whenever a C<url> key is given.
+The C<type> field should be the name of the most common program used
+to work with the repository, e.g. C<git>, C<svn>, C<cvs>, C<darcs>,
+C<bzr> or C<hg>.
+
+=back
+
+=head2 DEPRECATED FIELDS
+
+=head3 build_requires
+
+I<(Deprecated in Spec 2)> [optional] {String}
+
+Replaced by C<prereqs>
+
+=head3 configure_requires
+
+I<(Deprecated in Spec 2)> [optional] {String}
+
+Replaced by C<prereqs>
+
+=head3 conflicts
+
+I<(Deprecated in Spec 2)> [optional] {String}
+
+Replaced by C<prereqs>
+
+=head3 distribution_type
+
+I<(Deprecated in Spec 2)> [optional] {String}
+
+This field indicated 'module' or 'script' but was considered
+meaningless, since many distributions are hybrids of several kinds of
+things.
+
+=head3 license_uri
+
+I<(Deprecated in Spec 1.2)> [optional] {URL}
+
+Replaced by C<license> in C<resources>
+
+=head3 private
+
+I<(Deprecated in Spec 1.2)> [optional] {Map}
+
+This field has been renamed to L</"no_index">.
+
+=head3 recommends
+
+I<(Deprecated in Spec 2)> [optional] {String}
+
+Replaced by C<prereqs>
+
+=head3 requires
+
+I<(Deprecated in Spec 2)> [optional] {String}
+
+Replaced by C<prereqs>
+
+=head1 VERSION NUMBERS
+
+=head2 Version Formats
+
+This section defines the Version type, used by several fields in the
+CPAN Meta Spec.
+
+Version numbers must be treated as strings, not numbers. For
+example, C<1.200> B<must not> be serialized as C<1.2>. Version
+comparison should be delegated to the Perl L<version> module, version
+0.80 or newer.
+
+Unless otherwise specified, version numbers B<must> appear in one of two
+formats:
+
+=over
+
+=item Decimal versions
+
+Decimal versions are regular "decimal numbers", with some limitations.
+They B<must> be non-negative and B<must> begin and end with a digit. A
+single underscore B<may> be included, but B<must> be between two digits.
+They B<must not> use exponential notation ("1.23e-2").
+
+ version => '1.234' # OK
+ version => '1.23_04' # OK
+
+ version => '1.23_04_05' # Illegal
+ version => '1.' # Illegal
+ version => '.1' # Illegal
+
+=item Dotted-integer versions
+
+Dotted-integer (also known as dotted-decimal) versions consist of
+positive integers separated by full stop characters (i.e. "dots",
+"periods" or "decimal points"). This are equivalent in format to Perl
+"v-strings", with some additional restrictions on form. They must be
+given in "normal" form, which has a leading "v" character and at least
+three integer components. To retain a one-to-one mapping with decimal
+versions, all components after the first B<should> be restricted to the
+range 0 to 999. The final component B<may> be separated by an
+underscore character instead of a period.
+
+ version => 'v1.2.3' # OK
+ version => 'v1.2_3' # OK
+ version => 'v1.2.3.4' # OK
+ version => 'v1.2.3_4' # OK
+ version => 'v2009.10.31' # OK
+
+ version => 'v1.2' # Illegal
+ version => '1.2.3' # Illegal
+ version => 'v1.2_3_4' # Illegal
+ version => 'v1.2009.10.31' # Not recommended
+
+=back
+
+=head2 Version Ranges
+
+Some fields (prereq, optional_features) indicate the particular
+version(s) of some other module that may be required as a prerequisite.
+This section details the Version Range type used to provide this
+information.
+
+The simplest format for a Version Range is just the version
+number itself, e.g. C<2.4>. This means that B<at least> version 2.4
+must be present. To indicate that B<any> version of a prerequisite is
+okay, even if the prerequisite doesn't define a version at all, use
+the version C<0>.
+
+Alternatively, a version range B<may> use the operators E<lt> (less than),
+E<lt>= (less than or equal), E<gt> (greater than), E<gt>= (greater than
+or equal), == (equal), and != (not equal). For example, the
+specification C<E<lt> 2.0> means that any version of the prerequisite
+less than 2.0 is suitable.
+
+For more complicated situations, version specifications B<may> be AND-ed
+together using commas. The specification C<E<gt>= 1.2, != 1.5, E<lt>
+2.0> indicates a version that must be B<at least> 1.2, B<less than> 2.0,
+and B<not equal to> 1.5.
+
+=head1 PREREQUISITES
+
+=head2 Prereq Spec
+
+The C<prereqs> key in the top-level metadata and within
+C<optional_features> define the relationship between a distribution and
+other packages. The prereq spec structure is a hierarchical data
+structure which divides prerequisites into I<Phases> of activity in the
+installation process and I<Relationships> that indicate how
+prerequisites should be resolved.
+
+For example, to specify that C<Data::Dumper> is C<required> during the
+C<test> phase, this entry would appear in the distribution metadata:
+
+ prereqs => {
+ test => {
+ requires => {
+ 'Data::Dumper' => '2.00'
+ }
+ }
+ }
+
+=head3 Phases
+
+Requirements for regular use must be listed in the C<runtime> phase.
+Other requirements should be listed in the earliest stage in which they
+are required and consumers must accumulate and satisfy requirements
+across phases before executing the activity. For example, C<build>
+requirements must also be available during the C<test> phase.
+
+ before action requirements that must be met
+ ---------------- --------------------------------
+ perl Build.PL configure
+ perl Makefile.PL
+
+ make configure, runtime, build
+ Build
+
+ make test configure, runtime, build, test
+ Build test
+
+Consumers that install the distribution must ensure that
+I<runtime> requirements are also installed and may install
+dependencies from other phases.
+
+ after action requirements that must be met
+ ---------------- --------------------------------
+ make install runtime
+ Build install
+
+=over
+
+=item configure
+
+The configure phase occurs before any dynamic configuration has been
+attempted. Libraries required by the configure phase B<must> be
+available for use before the distribution building tool has been
+executed.
+
+=item build
+
+The build phase is when the distribution's source code is compiled (if
+necessary) and otherwise made ready for installation.
+
+=item test
+
+The test phase is when the distribution's automated test suite is run.
+Any library that is needed only for testing and not for subsequent use
+should be listed here.
+
+=item runtime
+
+The runtime phase refers not only to when the distribution's contents
+are installed, but also to its continued use. Any library that is a
+prerequisite for regular use of this distribution should be indicated
+here.
+
+=item develop
+
+The develop phase's prereqs are libraries needed to work on the
+distribution's source code as its author does. These tools might be
+needed to build a release tarball, to run author-only tests, or to
+perform other tasks related to developing new versions of the
+distribution.
+
+=back
+
+=head3 Relationships
+
+=over
+
+=item requires
+
+These dependencies B<must> be installed for proper completion of the
+phase.
+
+=item recommends
+
+Recommended dependencies are I<strongly> encouraged and should be
+satisfied except in resource constrained environments.
+
+=item suggests
+
+These dependencies are optional, but are suggested for enhanced operation
+of the described distribution.
+
+=item conflicts
+
+These libraries cannot be installed when the phase is in operation.
+This is a very rare situation, and the C<conflicts> relationship should
+be used with great caution, or not at all.
+
+=back
+
+=head2 Merging and Resolving Prerequisites
+
+Whenever metadata consumers merge prerequisites, either from different
+phases or from C<optional_features>, they should merged in a way which
+preserves the intended semantics of the prerequisite structure. Generally,
+this means concatenating the version specifications using commas, as
+described in the L<Version Ranges> section.
+
+Another subtle error that can occur in resolving prerequisites comes from
+the way that modules in prerequisites are indexed to distribution files on
+CPAN. When a module is deleted from a distribution, prerequisites calling
+for that module could indicate an older distribution should be installed,
+potentially overwriting files from a newer distribution.
+
+For example, as of Oct 31, 2009, the CPAN index file contained these
+module-distribution mappings:
+
+ Class::MOP 0.94 D/DR/DROLSKY/Class-MOP-0.94.tar.gz
+ Class::MOP::Class 0.94 D/DR/DROLSKY/Class-MOP-0.94.tar.gz
+ Class::MOP::Class::Immutable 0.04 S/ST/STEVAN/Class-MOP-0.36.tar.gz
+
+Consider the case where "Class::MOP" 0.94 is installed. If a
+distribution specified "Class::MOP::Class::Immutable" as a prerequisite,
+it could result in Class-MOP-0.36.tar.gz being installed, overwriting
+any files from Class-MOP-0.94.tar.gz.
+
+Consumers of metadata B<should> test whether prerequisites would result
+in installed module files being "downgraded" to an older version and
+B<may> warn users or ignore the prerequisite that would cause such a
+result.
+
+=head1 SERIALIZATION
+
+Distribution metadata should be serialized (as a hashref) as
+JSON-encoded data and packaged with distributions as the file
+F<META.json>.
+
+In the past, the distribution metadata structure had been packed with
+distributions as F<META.yml>, a file in the YAML Tiny format (for which,
+see L<YAML::Tiny>). Tools that consume distribution metadata from disk
+should be capable of loading F<META.yml>, but should prefer F<META.json>
+if both are found.
+
+=head1 NOTES FOR IMPLEMENTORS
+
+=head2 Extracting Version Numbers from Perl Modules
+
+To get the version number from a Perl module, consumers should use the
+C<< MM->parse_version($file) >> method provided by
+L<ExtUtils::MakeMaker> or L<Module::Metadata>. For example, for the
+module given by C<$mod>, the version may be retrieved in one of the
+following ways:
+
+ # via ExtUtils::MakeMaker
+ my $file = MM->_installed_file_for_module($mod);
+ my $version = MM->parse_version($file)
+
+The private C<_installed_file_for_module> method may be replaced with
+other methods for locating a module in C<@INC>.
+
+ # via Module::Metadata
+ my $info = Module::Metadata->new_from_module($mod);
+ my $version = $info->version;
+
+If only a filename is available, the following approach may be used:
+
+ # via Module::Build
+ my $info = Module::Metadata->new_from_file($file);
+ my $version = $info->version;
+
+=head2 Comparing Version Numbers
+
+The L<version> module provides the most reliable way to compare version
+numbers in all the various ways they might be provided or might exist
+within modules. Given two strings containing version numbers, C<$v1> and
+C<$v2>, they should be converted to C<version> objects before using
+ordinary comparison operators. For example:
+
+ use version;
+ if ( version->new($v1) <=> version->new($v2) ) {
+ print "Versions are not equal\n";
+ }
+
+If the only comparison needed is whether an installed module is of a
+sufficiently high version, a direct test may be done using the string
+form of C<eval> and the C<use> function. For example, for module C<$mod>
+and version prerequisite C<$prereq>:
+
+ if ( eval "use $mod $prereq (); 1" ) {
+ print "Module $mod version is OK.\n";
+ }
+
+If the values of C<$mod> and C<$prereq> have not been scrubbed, however,
+this presents security implications.
+
+=head2 Prerequisites for dynamically configured distributions
+
+When C<dynamic_config> is true, it is an error to presume that the
+prerequisites given in distribution metadata will have any relationship
+whatsoever to the actual prerequisites of the distribution.
+
+In practice, however, one can generally expect such prerequisites to be
+one of two things:
+
+=over 4
+
+=item *
+
+The minimum prerequisites for the distribution, to which dynamic configuration will only add items
+
+=item *
+
+Whatever the distribution configured with on the releaser's machine at release time
+
+=back
+
+The second case often turns out to have identical results to the first case,
+albeit only by accident.
+
+As such, consumers may use this data for informational analysis, but
+presenting it to the user as canonical or relying on it as such is
+invariably the height of folly.
+
+=head2 Indexing distributions a la PAUSE
+
+While no_index tells you what must be ignored when indexing, this spec holds
+no opinion on how you should get your initial candidate list of things to
+possibly index. For "normal" distributions you might consider simply indexing
+the contents of lib/, but there are many fascinating oddities on CPAN and
+many dists from the days when it was normal to put the main .pm file in the
+root of the distribution archive - so PAUSE currently indexes all .pm and .PL
+files that are not either (a) specifically excluded by no_index (b) in
+C<inc>, C<xt>, or C<t> directories, or common 'mistake' directories such as
+C<perl5>.
+
+Or: If you're trying to be PAUSE-like, make sure you skip C<inc>, C<xt> and
+C<t> as well as anything marked as no_index.
+
+Also remember: If the META file contains a provides field, you shouldn't be
+indexing anything in the first place - just use that.
+
+=head1 SEE ALSO
+
+=over 4
+
+=item *
+
+CPAN, L<http://www.cpan.org/>
+
+=item *
+
+JSON, L<http://json.org/>
+
+=item *
+
+YAML, L<http://www.yaml.org/>
+
+=item *
+
+L<CPAN>
+
+=item *
+
+L<CPANPLUS>
+
+=item *
+
+L<ExtUtils::MakeMaker>
+
+=item *
+
+L<Module::Build>
+
+=item *
+
+L<Module::Install>
+
+=item *
+
+L<CPAN::Meta::History::Meta_1_4>
+
+=back
+
+=head1 HISTORY
+
+Ken Williams wrote the original CPAN Meta Spec (also known as the
+"META.yml spec") in 2003 and maintained it through several revisions
+with input from various members of the community. In 2005, Randy
+Sims redrafted it from HTML to POD for the version 1.2 release. Ken
+continued to maintain the spec through version 1.4.
+
+In late 2009, David Golden organized the version 2 proposal review
+process. David and Ricardo Signes drafted the final version 2 spec
+in April 2010 based on the version 1.4 spec and patches contributed
+during the proposal process.
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+David Golden <dagolden@cpan.org>
+
+=item *
+
+Ricardo Signes <rjbs@cpan.org>
+
+=item *
+
+Adam Kennedy <adamk@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Validator.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Validator.pm
new file mode 100644
index 0000000000..a2256dea66
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Validator.pm
@@ -0,0 +1,1214 @@
+use 5.006;
+use strict;
+use warnings;
+package CPAN::Meta::Validator;
+
+our $VERSION = '2.150010';
+
+#pod =head1 SYNOPSIS
+#pod
+#pod my $struct = decode_json_file('META.json');
+#pod
+#pod my $cmv = CPAN::Meta::Validator->new( $struct );
+#pod
+#pod unless ( $cmv->is_valid ) {
+#pod my $msg = "Invalid META structure. Errors found:\n";
+#pod $msg .= join( "\n", $cmv->errors );
+#pod die $msg;
+#pod }
+#pod
+#pod =head1 DESCRIPTION
+#pod
+#pod This module validates a CPAN Meta structure against the version of the
+#pod the specification claimed in the C<meta-spec> field of the structure.
+#pod
+#pod =cut
+
+#--------------------------------------------------------------------------#
+# This code copied and adapted from Test::CPAN::Meta
+# by Barbie, <barbie@cpan.org> for Miss Barbell Productions,
+# L<http://www.missbarbell.co.uk>
+#--------------------------------------------------------------------------#
+
+#--------------------------------------------------------------------------#
+# Specification Definitions
+#--------------------------------------------------------------------------#
+
+my %known_specs = (
+ '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
+ '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html',
+ '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
+ '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html',
+ '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html'
+);
+my %known_urls = map {$known_specs{$_} => $_} keys %known_specs;
+
+my $module_map1 = { 'map' => { ':key' => { name => \&module, value => \&exversion } } };
+
+my $module_map2 = { 'map' => { ':key' => { name => \&module, value => \&version } } };
+
+my $no_index_2 = {
+ 'map' => { file => { list => { value => \&string } },
+ directory => { list => { value => \&string } },
+ 'package' => { list => { value => \&string } },
+ namespace => { list => { value => \&string } },
+ ':key' => { name => \&custom_2, value => \&anything },
+ }
+};
+
+my $no_index_1_3 = {
+ 'map' => { file => { list => { value => \&string } },
+ directory => { list => { value => \&string } },
+ 'package' => { list => { value => \&string } },
+ namespace => { list => { value => \&string } },
+ ':key' => { name => \&string, value => \&anything },
+ }
+};
+
+my $no_index_1_2 = {
+ 'map' => { file => { list => { value => \&string } },
+ dir => { list => { value => \&string } },
+ 'package' => { list => { value => \&string } },
+ namespace => { list => { value => \&string } },
+ ':key' => { name => \&string, value => \&anything },
+ }
+};
+
+my $no_index_1_1 = {
+ 'map' => { ':key' => { name => \&string, list => { value => \&string } },
+ }
+};
+
+my $prereq_map = {
+ map => {
+ ':key' => {
+ name => \&phase,
+ 'map' => {
+ ':key' => {
+ name => \&relation,
+ %$module_map1,
+ },
+ },
+ }
+ },
+};
+
+my %definitions = (
+ '2' => {
+ # REQUIRED
+ 'abstract' => { mandatory => 1, value => \&string },
+ 'author' => { mandatory => 1, list => { value => \&string } },
+ 'dynamic_config' => { mandatory => 1, value => \&boolean },
+ 'generated_by' => { mandatory => 1, value => \&string },
+ 'license' => { mandatory => 1, list => { value => \&license } },
+ 'meta-spec' => {
+ mandatory => 1,
+ 'map' => {
+ version => { mandatory => 1, value => \&version},
+ url => { value => \&url },
+ ':key' => { name => \&custom_2, value => \&anything },
+ }
+ },
+ 'name' => { mandatory => 1, value => \&string },
+ 'release_status' => { mandatory => 1, value => \&release_status },
+ 'version' => { mandatory => 1, value => \&version },
+
+ # OPTIONAL
+ 'description' => { value => \&string },
+ 'keywords' => { list => { value => \&string } },
+ 'no_index' => $no_index_2,
+ 'optional_features' => {
+ 'map' => {
+ ':key' => {
+ name => \&string,
+ 'map' => {
+ description => { value => \&string },
+ prereqs => $prereq_map,
+ ':key' => { name => \&custom_2, value => \&anything },
+ }
+ }
+ }
+ },
+ 'prereqs' => $prereq_map,
+ 'provides' => {
+ 'map' => {
+ ':key' => {
+ name => \&module,
+ 'map' => {
+ file => { mandatory => 1, value => \&file },
+ version => { value => \&version },
+ ':key' => { name => \&custom_2, value => \&anything },
+ }
+ }
+ }
+ },
+ 'resources' => {
+ 'map' => {
+ license => { list => { value => \&url } },
+ homepage => { value => \&url },
+ bugtracker => {
+ 'map' => {
+ web => { value => \&url },
+ mailto => { value => \&string},
+ ':key' => { name => \&custom_2, value => \&anything },
+ }
+ },
+ repository => {
+ 'map' => {
+ web => { value => \&url },
+ url => { value => \&url },
+ type => { value => \&string },
+ ':key' => { name => \&custom_2, value => \&anything },
+ }
+ },
+ ':key' => { value => \&string, name => \&custom_2 },
+ }
+ },
+
+ # CUSTOM -- additional user defined key/value pairs
+ # note we can only validate the key name, as the structure is user defined
+ ':key' => { name => \&custom_2, value => \&anything },
+ },
+
+'1.4' => {
+ 'meta-spec' => {
+ mandatory => 1,
+ 'map' => {
+ version => { mandatory => 1, value => \&version},
+ url => { mandatory => 1, value => \&urlspec },
+ ':key' => { name => \&string, value => \&anything },
+ },
+ },
+
+ 'name' => { mandatory => 1, value => \&string },
+ 'version' => { mandatory => 1, value => \&version },
+ 'abstract' => { mandatory => 1, value => \&string },
+ 'author' => { mandatory => 1, list => { value => \&string } },
+ 'license' => { mandatory => 1, value => \&license },
+ 'generated_by' => { mandatory => 1, value => \&string },
+
+ 'distribution_type' => { value => \&string },
+ 'dynamic_config' => { value => \&boolean },
+
+ 'requires' => $module_map1,
+ 'recommends' => $module_map1,
+ 'build_requires' => $module_map1,
+ 'configure_requires' => $module_map1,
+ 'conflicts' => $module_map2,
+
+ 'optional_features' => {
+ 'map' => {
+ ':key' => { name => \&string,
+ 'map' => { description => { value => \&string },
+ requires => $module_map1,
+ recommends => $module_map1,
+ build_requires => $module_map1,
+ conflicts => $module_map2,
+ ':key' => { name => \&string, value => \&anything },
+ }
+ }
+ }
+ },
+
+ 'provides' => {
+ 'map' => {
+ ':key' => { name => \&module,
+ 'map' => {
+ file => { mandatory => 1, value => \&file },
+ version => { value => \&version },
+ ':key' => { name => \&string, value => \&anything },
+ }
+ }
+ }
+ },
+
+ 'no_index' => $no_index_1_3,
+ 'private' => $no_index_1_3,
+
+ 'keywords' => { list => { value => \&string } },
+
+ 'resources' => {
+ 'map' => { license => { value => \&url },
+ homepage => { value => \&url },
+ bugtracker => { value => \&url },
+ repository => { value => \&url },
+ ':key' => { value => \&string, name => \&custom_1 },
+ }
+ },
+
+ # additional user defined key/value pairs
+ # note we can only validate the key name, as the structure is user defined
+ ':key' => { name => \&string, value => \&anything },
+},
+
+'1.3' => {
+ 'meta-spec' => {
+ mandatory => 1,
+ 'map' => {
+ version => { mandatory => 1, value => \&version},
+ url => { mandatory => 1, value => \&urlspec },
+ ':key' => { name => \&string, value => \&anything },
+ },
+ },
+
+ 'name' => { mandatory => 1, value => \&string },
+ 'version' => { mandatory => 1, value => \&version },
+ 'abstract' => { mandatory => 1, value => \&string },
+ 'author' => { mandatory => 1, list => { value => \&string } },
+ 'license' => { mandatory => 1, value => \&license },
+ 'generated_by' => { mandatory => 1, value => \&string },
+
+ 'distribution_type' => { value => \&string },
+ 'dynamic_config' => { value => \&boolean },
+
+ 'requires' => $module_map1,
+ 'recommends' => $module_map1,
+ 'build_requires' => $module_map1,
+ 'conflicts' => $module_map2,
+
+ 'optional_features' => {
+ 'map' => {
+ ':key' => { name => \&string,
+ 'map' => { description => { value => \&string },
+ requires => $module_map1,
+ recommends => $module_map1,
+ build_requires => $module_map1,
+ conflicts => $module_map2,
+ ':key' => { name => \&string, value => \&anything },
+ }
+ }
+ }
+ },
+
+ 'provides' => {
+ 'map' => {
+ ':key' => { name => \&module,
+ 'map' => {
+ file => { mandatory => 1, value => \&file },
+ version => { value => \&version },
+ ':key' => { name => \&string, value => \&anything },
+ }
+ }
+ }
+ },
+
+
+ 'no_index' => $no_index_1_3,
+ 'private' => $no_index_1_3,
+
+ 'keywords' => { list => { value => \&string } },
+
+ 'resources' => {
+ 'map' => { license => { value => \&url },
+ homepage => { value => \&url },
+ bugtracker => { value => \&url },
+ repository => { value => \&url },
+ ':key' => { value => \&string, name => \&custom_1 },
+ }
+ },
+
+ # additional user defined key/value pairs
+ # note we can only validate the key name, as the structure is user defined
+ ':key' => { name => \&string, value => \&anything },
+},
+
+# v1.2 is misleading, it seems to assume that a number of fields where created
+# within v1.1, when they were created within v1.2. This may have been an
+# original mistake, and that a v1.1 was retro fitted into the timeline, when
+# v1.2 was originally slated as v1.1. But I could be wrong ;)
+'1.2' => {
+ 'meta-spec' => {
+ mandatory => 1,
+ 'map' => {
+ version => { mandatory => 1, value => \&version},
+ url => { mandatory => 1, value => \&urlspec },
+ ':key' => { name => \&string, value => \&anything },
+ },
+ },
+
+
+ 'name' => { mandatory => 1, value => \&string },
+ 'version' => { mandatory => 1, value => \&version },
+ 'license' => { mandatory => 1, value => \&license },
+ 'generated_by' => { mandatory => 1, value => \&string },
+ 'author' => { mandatory => 1, list => { value => \&string } },
+ 'abstract' => { mandatory => 1, value => \&string },
+
+ 'distribution_type' => { value => \&string },
+ 'dynamic_config' => { value => \&boolean },
+
+ 'keywords' => { list => { value => \&string } },
+
+ 'private' => $no_index_1_2,
+ '$no_index' => $no_index_1_2,
+
+ 'requires' => $module_map1,
+ 'recommends' => $module_map1,
+ 'build_requires' => $module_map1,
+ 'conflicts' => $module_map2,
+
+ 'optional_features' => {
+ 'map' => {
+ ':key' => { name => \&string,
+ 'map' => { description => { value => \&string },
+ requires => $module_map1,
+ recommends => $module_map1,
+ build_requires => $module_map1,
+ conflicts => $module_map2,
+ ':key' => { name => \&string, value => \&anything },
+ }
+ }
+ }
+ },
+
+ 'provides' => {
+ 'map' => {
+ ':key' => { name => \&module,
+ 'map' => {
+ file => { mandatory => 1, value => \&file },
+ version => { value => \&version },
+ ':key' => { name => \&string, value => \&anything },
+ }
+ }
+ }
+ },
+
+ 'resources' => {
+ 'map' => { license => { value => \&url },
+ homepage => { value => \&url },
+ bugtracker => { value => \&url },
+ repository => { value => \&url },
+ ':key' => { value => \&string, name => \&custom_1 },
+ }
+ },
+
+ # additional user defined key/value pairs
+ # note we can only validate the key name, as the structure is user defined
+ ':key' => { name => \&string, value => \&anything },
+},
+
+# note that the 1.1 spec only specifies 'version' as mandatory
+'1.1' => {
+ 'name' => { value => \&string },
+ 'version' => { mandatory => 1, value => \&version },
+ 'license' => { value => \&license },
+ 'generated_by' => { value => \&string },
+
+ 'license_uri' => { value => \&url },
+ 'distribution_type' => { value => \&string },
+ 'dynamic_config' => { value => \&boolean },
+
+ 'private' => $no_index_1_1,
+
+ 'requires' => $module_map1,
+ 'recommends' => $module_map1,
+ 'build_requires' => $module_map1,
+ 'conflicts' => $module_map2,
+
+ # additional user defined key/value pairs
+ # note we can only validate the key name, as the structure is user defined
+ ':key' => { name => \&string, value => \&anything },
+},
+
+# note that the 1.0 spec doesn't specify optional or mandatory fields
+# but we will treat version as mandatory since otherwise META 1.0 is
+# completely arbitrary and pointless
+'1.0' => {
+ 'name' => { value => \&string },
+ 'version' => { mandatory => 1, value => \&version },
+ 'license' => { value => \&license },
+ 'generated_by' => { value => \&string },
+
+ 'license_uri' => { value => \&url },
+ 'distribution_type' => { value => \&string },
+ 'dynamic_config' => { value => \&boolean },
+
+ 'requires' => $module_map1,
+ 'recommends' => $module_map1,
+ 'build_requires' => $module_map1,
+ 'conflicts' => $module_map2,
+
+ # additional user defined key/value pairs
+ # note we can only validate the key name, as the structure is user defined
+ ':key' => { name => \&string, value => \&anything },
+},
+);
+
+#--------------------------------------------------------------------------#
+# Code
+#--------------------------------------------------------------------------#
+
+#pod =method new
+#pod
+#pod my $cmv = CPAN::Meta::Validator->new( $struct )
+#pod
+#pod The constructor must be passed a metadata structure.
+#pod
+#pod =cut
+
+sub new {
+ my ($class,$data) = @_;
+
+ # create an attributes hash
+ my $self = {
+ 'data' => $data,
+ 'spec' => eval { $data->{'meta-spec'}{'version'} } || "1.0",
+ 'errors' => undef,
+ };
+
+ # create the object
+ return bless $self, $class;
+}
+
+#pod =method is_valid
+#pod
+#pod if ( $cmv->is_valid ) {
+#pod ...
+#pod }
+#pod
+#pod Returns a boolean value indicating whether the metadata provided
+#pod is valid.
+#pod
+#pod =cut
+
+sub is_valid {
+ my $self = shift;
+ my $data = $self->{data};
+ my $spec_version = $self->{spec};
+ $self->check_map($definitions{$spec_version},$data);
+ return ! $self->errors;
+}
+
+#pod =method errors
+#pod
+#pod warn( join "\n", $cmv->errors );
+#pod
+#pod Returns a list of errors seen during validation.
+#pod
+#pod =cut
+
+sub errors {
+ my $self = shift;
+ return () unless(defined $self->{errors});
+ return @{$self->{errors}};
+}
+
+#pod =begin :internals
+#pod
+#pod =head2 Check Methods
+#pod
+#pod =over
+#pod
+#pod =item *
+#pod
+#pod check_map($spec,$data)
+#pod
+#pod Checks whether a map (or hash) part of the data structure conforms to the
+#pod appropriate specification definition.
+#pod
+#pod =item *
+#pod
+#pod check_list($spec,$data)
+#pod
+#pod Checks whether a list (or array) part of the data structure conforms to
+#pod the appropriate specification definition.
+#pod
+#pod =item *
+#pod
+#pod =back
+#pod
+#pod =cut
+
+my $spec_error = "Missing validation action in specification. "
+ . "Must be one of 'map', 'list', or 'value'";
+
+sub check_map {
+ my ($self,$spec,$data) = @_;
+
+ if(ref($spec) ne 'HASH') {
+ $self->_error( "Unknown META specification, cannot validate." );
+ return;
+ }
+
+ if(ref($data) ne 'HASH') {
+ $self->_error( "Expected a map structure from string or file." );
+ return;
+ }
+
+ for my $key (keys %$spec) {
+ next unless($spec->{$key}->{mandatory});
+ next if(defined $data->{$key});
+ push @{$self->{stack}}, $key;
+ $self->_error( "Missing mandatory field, '$key'" );
+ pop @{$self->{stack}};
+ }
+
+ for my $key (keys %$data) {
+ push @{$self->{stack}}, $key;
+ if($spec->{$key}) {
+ if($spec->{$key}{value}) {
+ $spec->{$key}{value}->($self,$key,$data->{$key});
+ } elsif($spec->{$key}{'map'}) {
+ $self->check_map($spec->{$key}{'map'},$data->{$key});
+ } elsif($spec->{$key}{'list'}) {
+ $self->check_list($spec->{$key}{'list'},$data->{$key});
+ } else {
+ $self->_error( "$spec_error for '$key'" );
+ }
+
+ } elsif ($spec->{':key'}) {
+ $spec->{':key'}{name}->($self,$key,$key);
+ if($spec->{':key'}{value}) {
+ $spec->{':key'}{value}->($self,$key,$data->{$key});
+ } elsif($spec->{':key'}{'map'}) {
+ $self->check_map($spec->{':key'}{'map'},$data->{$key});
+ } elsif($spec->{':key'}{'list'}) {
+ $self->check_list($spec->{':key'}{'list'},$data->{$key});
+ } else {
+ $self->_error( "$spec_error for ':key'" );
+ }
+
+
+ } else {
+ $self->_error( "Unknown key, '$key', found in map structure" );
+ }
+ pop @{$self->{stack}};
+ }
+}
+
+sub check_list {
+ my ($self,$spec,$data) = @_;
+
+ if(ref($data) ne 'ARRAY') {
+ $self->_error( "Expected a list structure" );
+ return;
+ }
+
+ if(defined $spec->{mandatory}) {
+ if(!defined $data->[0]) {
+ $self->_error( "Missing entries from mandatory list" );
+ }
+ }
+
+ for my $value (@$data) {
+ push @{$self->{stack}}, $value || "<undef>";
+ if(defined $spec->{value}) {
+ $spec->{value}->($self,'list',$value);
+ } elsif(defined $spec->{'map'}) {
+ $self->check_map($spec->{'map'},$value);
+ } elsif(defined $spec->{'list'}) {
+ $self->check_list($spec->{'list'},$value);
+ } elsif ($spec->{':key'}) {
+ $self->check_map($spec,$value);
+ } else {
+ $self->_error( "$spec_error associated with '$self->{stack}[-2]'" );
+ }
+ pop @{$self->{stack}};
+ }
+}
+
+#pod =head2 Validator Methods
+#pod
+#pod =over
+#pod
+#pod =item *
+#pod
+#pod header($self,$key,$value)
+#pod
+#pod Validates that the header is valid.
+#pod
+#pod Note: No longer used as we now read the data structure, not the file.
+#pod
+#pod =item *
+#pod
+#pod url($self,$key,$value)
+#pod
+#pod Validates that a given value is in an acceptable URL format
+#pod
+#pod =item *
+#pod
+#pod urlspec($self,$key,$value)
+#pod
+#pod Validates that the URL to a META specification is a known one.
+#pod
+#pod =item *
+#pod
+#pod string_or_undef($self,$key,$value)
+#pod
+#pod Validates that the value is either a string or an undef value. Bit of a
+#pod catchall function for parts of the data structure that are completely user
+#pod defined.
+#pod
+#pod =item *
+#pod
+#pod string($self,$key,$value)
+#pod
+#pod Validates that a string exists for the given key.
+#pod
+#pod =item *
+#pod
+#pod file($self,$key,$value)
+#pod
+#pod Validate that a file is passed for the given key. This may be made more
+#pod thorough in the future. For now it acts like \&string.
+#pod
+#pod =item *
+#pod
+#pod exversion($self,$key,$value)
+#pod
+#pod Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'.
+#pod
+#pod =item *
+#pod
+#pod version($self,$key,$value)
+#pod
+#pod Validates a single version string. Versions of the type '5.8.8' and '0.00_00'
+#pod are both valid. A leading 'v' like 'v1.2.3' is also valid.
+#pod
+#pod =item *
+#pod
+#pod boolean($self,$key,$value)
+#pod
+#pod Validates for a boolean value: a defined value that is either "1" or "0" or
+#pod stringifies to those values.
+#pod
+#pod =item *
+#pod
+#pod license($self,$key,$value)
+#pod
+#pod Validates that a value is given for the license. Returns 1 if an known license
+#pod type, or 2 if a value is given but the license type is not a recommended one.
+#pod
+#pod =item *
+#pod
+#pod custom_1($self,$key,$value)
+#pod
+#pod Validates that the given key is in CamelCase, to indicate a user defined
+#pod keyword and only has characters in the class [-_a-zA-Z]. In version 1.X
+#pod of the spec, this was only explicitly stated for 'resources'.
+#pod
+#pod =item *
+#pod
+#pod custom_2($self,$key,$value)
+#pod
+#pod Validates that the given key begins with 'x_' or 'X_', to indicate a user
+#pod defined keyword and only has characters in the class [-_a-zA-Z]
+#pod
+#pod =item *
+#pod
+#pod identifier($self,$key,$value)
+#pod
+#pod Validates that key is in an acceptable format for the META specification,
+#pod for an identifier, i.e. any that matches the regular expression
+#pod qr/[a-z][a-z_]/i.
+#pod
+#pod =item *
+#pod
+#pod module($self,$key,$value)
+#pod
+#pod Validates that a given key is in an acceptable module name format, e.g.
+#pod 'Test::CPAN::Meta::Version'.
+#pod
+#pod =back
+#pod
+#pod =end :internals
+#pod
+#pod =cut
+
+sub header {
+ my ($self,$key,$value) = @_;
+ if(defined $value) {
+ return 1 if($value && $value =~ /^--- #YAML:1.0/);
+ }
+ $self->_error( "file does not have a valid YAML header." );
+ return 0;
+}
+
+sub release_status {
+ my ($self,$key,$value) = @_;
+ if(defined $value) {
+ my $version = $self->{data}{version} || '';
+ if ( $version =~ /_/ ) {
+ return 1 if ( $value =~ /\A(?:testing|unstable)\z/ );
+ $self->_error( "'$value' for '$key' is invalid for version '$version'" );
+ }
+ else {
+ return 1 if ( $value =~ /\A(?:stable|testing|unstable)\z/ );
+ $self->_error( "'$value' for '$key' is invalid" );
+ }
+ }
+ else {
+ $self->_error( "'$key' is not defined" );
+ }
+ return 0;
+}
+
+# _uri_split taken from URI::Split by Gisle Aas, Copyright 2003
+sub _uri_split {
+ return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,;
+}
+
+sub url {
+ my ($self,$key,$value) = @_;
+ if(defined $value) {
+ my ($scheme, $auth, $path, $query, $frag) = _uri_split($value);
+ unless ( defined $scheme && length $scheme ) {
+ $self->_error( "'$value' for '$key' does not have a URL scheme" );
+ return 0;
+ }
+ unless ( defined $auth && length $auth ) {
+ $self->_error( "'$value' for '$key' does not have a URL authority" );
+ return 0;
+ }
+ return 1;
+ }
+ $value ||= '';
+ $self->_error( "'$value' for '$key' is not a valid URL." );
+ return 0;
+}
+
+sub urlspec {
+ my ($self,$key,$value) = @_;
+ if(defined $value) {
+ return 1 if($value && $known_specs{$self->{spec}} eq $value);
+ if($value && $known_urls{$value}) {
+ $self->_error( 'META specification URL does not match version' );
+ return 0;
+ }
+ }
+ $self->_error( 'Unknown META specification' );
+ return 0;
+}
+
+sub anything { return 1 }
+
+sub string {
+ my ($self,$key,$value) = @_;
+ if(defined $value) {
+ return 1 if($value || $value =~ /^0$/);
+ }
+ $self->_error( "value is an undefined string" );
+ return 0;
+}
+
+sub string_or_undef {
+ my ($self,$key,$value) = @_;
+ return 1 unless(defined $value);
+ return 1 if($value || $value =~ /^0$/);
+ $self->_error( "No string defined for '$key'" );
+ return 0;
+}
+
+sub file {
+ my ($self,$key,$value) = @_;
+ return 1 if(defined $value);
+ $self->_error( "No file defined for '$key'" );
+ return 0;
+}
+
+sub exversion {
+ my ($self,$key,$value) = @_;
+ if(defined $value && ($value || $value =~ /0/)) {
+ my $pass = 1;
+ for(split(",",$value)) { $self->version($key,$_) or ($pass = 0); }
+ return $pass;
+ }
+ $value = '<undef>' unless(defined $value);
+ $self->_error( "'$value' for '$key' is not a valid version." );
+ return 0;
+}
+
+sub version {
+ my ($self,$key,$value) = @_;
+ if(defined $value) {
+ return 0 unless($value || $value =~ /0/);
+ return 1 if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/);
+ } else {
+ $value = '<undef>';
+ }
+ $self->_error( "'$value' for '$key' is not a valid version." );
+ return 0;
+}
+
+sub boolean {
+ my ($self,$key,$value) = @_;
+ if(defined $value) {
+ return 1 if($value =~ /^(0|1)$/);
+ } else {
+ $value = '<undef>';
+ }
+ $self->_error( "'$value' for '$key' is not a boolean value." );
+ return 0;
+}
+
+my %v1_licenses = (
+ 'perl' => 'http://dev.perl.org/licenses/',
+ 'gpl' => 'http://www.opensource.org/licenses/gpl-license.php',
+ 'apache' => 'http://apache.org/licenses/LICENSE-2.0',
+ 'artistic' => 'http://opensource.org/licenses/artistic-license.php',
+ 'artistic_2' => 'http://opensource.org/licenses/artistic-license-2.0.php',
+ 'lgpl' => 'http://www.opensource.org/licenses/lgpl-license.php',
+ 'bsd' => 'http://www.opensource.org/licenses/bsd-license.php',
+ 'gpl' => 'http://www.opensource.org/licenses/gpl-license.php',
+ 'mit' => 'http://opensource.org/licenses/mit-license.php',
+ 'mozilla' => 'http://opensource.org/licenses/mozilla1.1.php',
+ 'open_source' => undef,
+ 'unrestricted' => undef,
+ 'restrictive' => undef,
+ 'unknown' => undef,
+);
+
+my %v2_licenses = map { $_ => 1 } qw(
+ agpl_3
+ apache_1_1
+ apache_2_0
+ artistic_1
+ artistic_2
+ bsd
+ freebsd
+ gfdl_1_2
+ gfdl_1_3
+ gpl_1
+ gpl_2
+ gpl_3
+ lgpl_2_1
+ lgpl_3_0
+ mit
+ mozilla_1_0
+ mozilla_1_1
+ openssl
+ perl_5
+ qpl_1_0
+ ssleay
+ sun
+ zlib
+ open_source
+ restricted
+ unrestricted
+ unknown
+);
+
+sub license {
+ my ($self,$key,$value) = @_;
+ my $licenses = $self->{spec} < 2 ? \%v1_licenses : \%v2_licenses;
+ if(defined $value) {
+ return 1 if($value && exists $licenses->{$value});
+ } else {
+ $value = '<undef>';
+ }
+ $self->_error( "License '$value' is invalid" );
+ return 0;
+}
+
+sub custom_1 {
+ my ($self,$key) = @_;
+ if(defined $key) {
+ # a valid user defined key should be alphabetic
+ # and contain at least one capital case letter.
+ return 1 if($key && $key =~ /^[_a-z]+$/i && $key =~ /[A-Z]/);
+ } else {
+ $key = '<undef>';
+ }
+ $self->_error( "Custom resource '$key' must be in CamelCase." );
+ return 0;
+}
+
+sub custom_2 {
+ my ($self,$key) = @_;
+ if(defined $key) {
+ return 1 if($key && $key =~ /^x_/i); # user defined
+ } else {
+ $key = '<undef>';
+ }
+ $self->_error( "Custom key '$key' must begin with 'x_' or 'X_'." );
+ return 0;
+}
+
+sub identifier {
+ my ($self,$key) = @_;
+ if(defined $key) {
+ return 1 if($key && $key =~ /^([a-z][_a-z]+)$/i); # spec 2.0 defined
+ } else {
+ $key = '<undef>';
+ }
+ $self->_error( "Key '$key' is not a legal identifier." );
+ return 0;
+}
+
+sub module {
+ my ($self,$key) = @_;
+ if(defined $key) {
+ return 1 if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/);
+ } else {
+ $key = '<undef>';
+ }
+ $self->_error( "Key '$key' is not a legal module name." );
+ return 0;
+}
+
+my @valid_phases = qw/ configure build test runtime develop /;
+sub phase {
+ my ($self,$key) = @_;
+ if(defined $key) {
+ return 1 if( length $key && grep { $key eq $_ } @valid_phases );
+ return 1 if $key =~ /x_/i;
+ } else {
+ $key = '<undef>';
+ }
+ $self->_error( "Key '$key' is not a legal phase." );
+ return 0;
+}
+
+my @valid_relations = qw/ requires recommends suggests conflicts /;
+sub relation {
+ my ($self,$key) = @_;
+ if(defined $key) {
+ return 1 if( length $key && grep { $key eq $_ } @valid_relations );
+ return 1 if $key =~ /x_/i;
+ } else {
+ $key = '<undef>';
+ }
+ $self->_error( "Key '$key' is not a legal prereq relationship." );
+ return 0;
+}
+
+sub _error {
+ my $self = shift;
+ my $mess = shift;
+
+ $mess .= ' ('.join(' -> ',@{$self->{stack}}).')' if($self->{stack});
+ $mess .= " [Validation: $self->{spec}]";
+
+ push @{$self->{errors}}, $mess;
+}
+
+1;
+
+# ABSTRACT: validate CPAN distribution metadata structures
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+CPAN::Meta::Validator - validate CPAN distribution metadata structures
+
+=head1 VERSION
+
+version 2.150010
+
+=head1 SYNOPSIS
+
+ my $struct = decode_json_file('META.json');
+
+ my $cmv = CPAN::Meta::Validator->new( $struct );
+
+ unless ( $cmv->is_valid ) {
+ my $msg = "Invalid META structure. Errors found:\n";
+ $msg .= join( "\n", $cmv->errors );
+ die $msg;
+ }
+
+=head1 DESCRIPTION
+
+This module validates a CPAN Meta structure against the version of the
+the specification claimed in the C<meta-spec> field of the structure.
+
+=head1 METHODS
+
+=head2 new
+
+ my $cmv = CPAN::Meta::Validator->new( $struct )
+
+The constructor must be passed a metadata structure.
+
+=head2 is_valid
+
+ if ( $cmv->is_valid ) {
+ ...
+ }
+
+Returns a boolean value indicating whether the metadata provided
+is valid.
+
+=head2 errors
+
+ warn( join "\n", $cmv->errors );
+
+Returns a list of errors seen during validation.
+
+=begin :internals
+
+=head2 Check Methods
+
+=over
+
+=item *
+
+check_map($spec,$data)
+
+Checks whether a map (or hash) part of the data structure conforms to the
+appropriate specification definition.
+
+=item *
+
+check_list($spec,$data)
+
+Checks whether a list (or array) part of the data structure conforms to
+the appropriate specification definition.
+
+=item *
+
+=back
+
+=head2 Validator Methods
+
+=over
+
+=item *
+
+header($self,$key,$value)
+
+Validates that the header is valid.
+
+Note: No longer used as we now read the data structure, not the file.
+
+=item *
+
+url($self,$key,$value)
+
+Validates that a given value is in an acceptable URL format
+
+=item *
+
+urlspec($self,$key,$value)
+
+Validates that the URL to a META specification is a known one.
+
+=item *
+
+string_or_undef($self,$key,$value)
+
+Validates that the value is either a string or an undef value. Bit of a
+catchall function for parts of the data structure that are completely user
+defined.
+
+=item *
+
+string($self,$key,$value)
+
+Validates that a string exists for the given key.
+
+=item *
+
+file($self,$key,$value)
+
+Validate that a file is passed for the given key. This may be made more
+thorough in the future. For now it acts like \&string.
+
+=item *
+
+exversion($self,$key,$value)
+
+Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'.
+
+=item *
+
+version($self,$key,$value)
+
+Validates a single version string. Versions of the type '5.8.8' and '0.00_00'
+are both valid. A leading 'v' like 'v1.2.3' is also valid.
+
+=item *
+
+boolean($self,$key,$value)
+
+Validates for a boolean value: a defined value that is either "1" or "0" or
+stringifies to those values.
+
+=item *
+
+license($self,$key,$value)
+
+Validates that a value is given for the license. Returns 1 if an known license
+type, or 2 if a value is given but the license type is not a recommended one.
+
+=item *
+
+custom_1($self,$key,$value)
+
+Validates that the given key is in CamelCase, to indicate a user defined
+keyword and only has characters in the class [-_a-zA-Z]. In version 1.X
+of the spec, this was only explicitly stated for 'resources'.
+
+=item *
+
+custom_2($self,$key,$value)
+
+Validates that the given key begins with 'x_' or 'X_', to indicate a user
+defined keyword and only has characters in the class [-_a-zA-Z]
+
+=item *
+
+identifier($self,$key,$value)
+
+Validates that key is in an acceptable format for the META specification,
+for an identifier, i.e. any that matches the regular expression
+qr/[a-z][a-z_]/i.
+
+=item *
+
+module($self,$key,$value)
+
+Validates that a given key is in an acceptable module name format, e.g.
+'Test::CPAN::Meta::Version'.
+
+=back
+
+=end :internals
+
+=for Pod::Coverage anything boolean check_list custom_1 custom_2 exversion file
+identifier license module phase relation release_status string string_or_undef
+url urlspec version header check_map
+
+=head1 BUGS
+
+Please report any bugs or feature using the CPAN Request Tracker.
+Bugs can be submitted through the web interface at
+L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
+
+When submitting a bug or request, please include a test-file or a patch to an
+existing test-file that illustrates the bug or desired feature.
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+David Golden <dagolden@cpan.org>
+
+=item *
+
+Ricardo Signes <rjbs@cpan.org>
+
+=item *
+
+Adam Kennedy <adamk@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
+
+__END__
+
+
+# vim: ts=2 sts=2 sw=2 et :
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/YAML.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/YAML.pm
new file mode 100644
index 0000000000..746abd63bc
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/YAML.pm
@@ -0,0 +1,951 @@
+use 5.008001; # sane UTF-8 support
+use strict;
+use warnings;
+package CPAN::Meta::YAML; # git description: v1.68-2-gcc5324e
+# XXX-INGY is 5.8.1 too old/broken for utf8?
+# XXX-XDG Lancaster consensus was that it was sufficient until
+# proven otherwise
+$CPAN::Meta::YAML::VERSION = '0.018';
+; # original $VERSION removed by Doppelgaenger
+
+#####################################################################
+# The CPAN::Meta::YAML API.
+#
+# These are the currently documented API functions/methods and
+# exports:
+
+use Exporter;
+our @ISA = qw{ Exporter };
+our @EXPORT = qw{ Load Dump };
+our @EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };
+
+###
+# Functional/Export API:
+
+sub Dump {
+ return CPAN::Meta::YAML->new(@_)->_dump_string;
+}
+
+# XXX-INGY Returning last document seems a bad behavior.
+# XXX-XDG I think first would seem more natural, but I don't know
+# that it's worth changing now
+sub Load {
+ my $self = CPAN::Meta::YAML->_load_string(@_);
+ if ( wantarray ) {
+ return @$self;
+ } else {
+ # To match YAML.pm, return the last document
+ return $self->[-1];
+ }
+}
+
+# XXX-INGY Do we really need freeze and thaw?
+# XXX-XDG I don't think so. I'd support deprecating them.
+BEGIN {
+ *freeze = \&Dump;
+ *thaw = \&Load;
+}
+
+sub DumpFile {
+ my $file = shift;
+ return CPAN::Meta::YAML->new(@_)->_dump_file($file);
+}
+
+sub LoadFile {
+ my $file = shift;
+ my $self = CPAN::Meta::YAML->_load_file($file);
+ if ( wantarray ) {
+ return @$self;
+ } else {
+ # Return only the last document to match YAML.pm,
+ return $self->[-1];
+ }
+}
+
+
+###
+# Object Oriented API:
+
+# Create an empty CPAN::Meta::YAML object
+# XXX-INGY Why do we use ARRAY object?
+# NOTE: I get it now, but I think it's confusing and not needed.
+# Will change it on a branch later, for review.
+#
+# XXX-XDG I don't support changing it yet. It's a very well-documented
+# "API" of CPAN::Meta::YAML. I'd support deprecating it, but Adam suggested
+# we not change it until YAML.pm's own OO API is established so that
+# users only have one API change to digest, not two
+sub new {
+ my $class = shift;
+ bless [ @_ ], $class;
+}
+
+# XXX-INGY It probably doesn't matter, and it's probably too late to
+# change, but 'read/write' are the wrong names. Read and Write
+# are actions that take data from storage to memory
+# characters/strings. These take the data to/from storage to native
+# Perl objects, which the terms dump and load are meant. As long as
+# this is a legacy quirk to CPAN::Meta::YAML it's ok, but I'd prefer not
+# to add new {read,write}_* methods to this API.
+
+sub read_string {
+ my $self = shift;
+ $self->_load_string(@_);
+}
+
+sub write_string {
+ my $self = shift;
+ $self->_dump_string(@_);
+}
+
+sub read {
+ my $self = shift;
+ $self->_load_file(@_);
+}
+
+sub write {
+ my $self = shift;
+ $self->_dump_file(@_);
+}
+
+
+
+
+#####################################################################
+# Constants
+
+# Printed form of the unprintable characters in the lowest range
+# of ASCII characters, listed by ASCII ordinal position.
+my @UNPRINTABLE = qw(
+ 0 x01 x02 x03 x04 x05 x06 a
+ b t n v f r x0E x0F
+ x10 x11 x12 x13 x14 x15 x16 x17
+ x18 x19 x1A e x1C x1D x1E x1F
+);
+
+# Printable characters for escapes
+my %UNESCAPES = (
+ 0 => "\x00", z => "\x00", N => "\x85",
+ a => "\x07", b => "\x08", t => "\x09",
+ n => "\x0a", v => "\x0b", f => "\x0c",
+ r => "\x0d", e => "\x1b", '\\' => '\\',
+);
+
+# XXX-INGY
+# I(ngy) need to decide if these values should be quoted in
+# CPAN::Meta::YAML or not. Probably yes.
+
+# These 3 values have special meaning when unquoted and using the
+# default YAML schema. They need quotes if they are strings.
+my %QUOTE = map { $_ => 1 } qw{
+ null true false
+};
+
+# The commented out form is simpler, but overloaded the Perl regex
+# engine due to recursion and backtracking problems on strings
+# larger than 32,000ish characters. Keep it for reference purposes.
+# qr/\"((?:\\.|[^\"])*)\"/
+my $re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;
+my $re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/;
+# unquoted re gets trailing space that needs to be stripped
+my $re_capture_unquoted_key = qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/;
+my $re_trailing_comment = qr/(?:\s+\#.*)?/;
+my $re_key_value_separator = qr/\s*:(?:\s+(?:\#.*)?|$)/;
+
+
+
+
+
+#####################################################################
+# CPAN::Meta::YAML Implementation.
+#
+# These are the private methods that do all the work. They may change
+# at any time.
+
+
+###
+# Loader functions:
+
+# Create an object from a file
+sub _load_file {
+ my $class = ref $_[0] ? ref shift : shift;
+
+ # Check the file
+ my $file = shift or $class->_error( 'You did not specify a file name' );
+ $class->_error( "File '$file' does not exist" )
+ unless -e $file;
+ $class->_error( "'$file' is a directory, not a file" )
+ unless -f _;
+ $class->_error( "Insufficient permissions to read '$file'" )
+ unless -r _;
+
+ # Open unbuffered with strict UTF-8 decoding and no translation layers
+ open( my $fh, "<:unix:encoding(UTF-8)", $file );
+ unless ( $fh ) {
+ $class->_error("Failed to open file '$file': $!");
+ }
+
+ # flock if available (or warn if not possible for OS-specific reasons)
+ if ( _can_flock() ) {
+ flock( $fh, Fcntl::LOCK_SH() )
+ or warn "Couldn't lock '$file' for reading: $!";
+ }
+
+ # slurp the contents
+ my $contents = eval {
+ use warnings FATAL => 'utf8';
+ local $/;
+ <$fh>
+ };
+ if ( my $err = $@ ) {
+ $class->_error("Error reading from file '$file': $err");
+ }
+
+ # close the file (release the lock)
+ unless ( close $fh ) {
+ $class->_error("Failed to close file '$file': $!");
+ }
+
+ $class->_load_string( $contents );
+}
+
+# Create an object from a string
+sub _load_string {
+ my $class = ref $_[0] ? ref shift : shift;
+ my $self = bless [], $class;
+ my $string = $_[0];
+ eval {
+ unless ( defined $string ) {
+ die \"Did not provide a string to load";
+ }
+
+ # Check if Perl has it marked as characters, but it's internally
+ # inconsistent. E.g. maybe latin1 got read on a :utf8 layer
+ if ( utf8::is_utf8($string) && ! utf8::valid($string) ) {
+ die \<<'...';
+Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set).
+Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"?
+...
+ }
+
+ # Ensure Unicode character semantics, even for 0x80-0xff
+ utf8::upgrade($string);
+
+ # Check for and strip any leading UTF-8 BOM
+ $string =~ s/^\x{FEFF}//;
+
+ # Check for some special cases
+ return $self unless length $string;
+
+ # Split the file into lines
+ my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
+ split /(?:\015{1,2}\012|\015|\012)/, $string;
+
+ # Strip the initial YAML header
+ @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
+
+ # A nibbling parser
+ my $in_document = 0;
+ while ( @lines ) {
+ # Do we have a document header?
+ if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
+ # Handle scalar documents
+ shift @lines;
+ if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
+ push @$self,
+ $self->_load_scalar( "$1", [ undef ], \@lines );
+ next;
+ }
+ $in_document = 1;
+ }
+
+ if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
+ # A naked document
+ push @$self, undef;
+ while ( @lines and $lines[0] !~ /^---/ ) {
+ shift @lines;
+ }
+ $in_document = 0;
+
+ # XXX The final '-+$' is to look for -- which ends up being an
+ # error later.
+ } elsif ( ! $in_document && @$self ) {
+ # only the first document can be explicit
+ die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
+ } elsif ( $lines[0] =~ /^\s*\-(?:\s|$|-+$)/ ) {
+ # An array at the root
+ my $document = [ ];
+ push @$self, $document;
+ $self->_load_array( $document, [ 0 ], \@lines );
+
+ } elsif ( $lines[0] =~ /^(\s*)\S/ ) {
+ # A hash at the root
+ my $document = { };
+ push @$self, $document;
+ $self->_load_hash( $document, [ length($1) ], \@lines );
+
+ } else {
+ # Shouldn't get here. @lines have whitespace-only lines
+ # stripped, and previous match is a line with any
+ # non-whitespace. So this clause should only be reachable via
+ # a perlbug where \s is not symmetric with \S
+
+ # uncoverable statement
+ die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
+ }
+ }
+ };
+ my $err = $@;
+ if ( ref $err eq 'SCALAR' ) {
+ $self->_error(${$err});
+ } elsif ( $err ) {
+ $self->_error($err);
+ }
+
+ return $self;
+}
+
+sub _unquote_single {
+ my ($self, $string) = @_;
+ return '' unless length $string;
+ $string =~ s/\'\'/\'/g;
+ return $string;
+}
+
+sub _unquote_double {
+ my ($self, $string) = @_;
+ return '' unless length $string;
+ $string =~ s/\\"/"/g;
+ $string =~
+ s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))}
+ {(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex;
+ return $string;
+}
+
+# Load a YAML scalar string to the actual Perl scalar
+sub _load_scalar {
+ my ($self, $string, $indent, $lines) = @_;
+
+ # Trim trailing whitespace
+ $string =~ s/\s*\z//;
+
+ # Explitic null/undef
+ return undef if $string eq '~';
+
+ # Single quote
+ if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) {
+ return $self->_unquote_single($1);
+ }
+
+ # Double quote.
+ if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) {
+ return $self->_unquote_double($1);
+ }
+
+ # Special cases
+ if ( $string =~ /^[\'\"!&]/ ) {
+ die \"CPAN::Meta::YAML does not support a feature in line '$string'";
+ }
+ return {} if $string =~ /^{}(?:\s+\#.*)?\z/;
+ return [] if $string =~ /^\[\](?:\s+\#.*)?\z/;
+
+ # Regular unquoted string
+ if ( $string !~ /^[>|]/ ) {
+ die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'"
+ if $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or
+ $string =~ /:(?:\s|$)/;
+ $string =~ s/\s+#.*\z//;
+ return $string;
+ }
+
+ # Error
+ die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines;
+
+ # Check the indent depth
+ $lines->[0] =~ /^(\s*)/;
+ $indent->[-1] = length("$1");
+ if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
+ die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
+ }
+
+ # Pull the lines
+ my @multiline = ();
+ while ( @$lines ) {
+ $lines->[0] =~ /^(\s*)/;
+ last unless length($1) >= $indent->[-1];
+ push @multiline, substr(shift(@$lines), length($1));
+ }
+
+ my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
+ my $t = (substr($string, 1, 1) eq '-') ? '' : "\n";
+ return join( $j, @multiline ) . $t;
+}
+
+# Load an array
+sub _load_array {
+ my ($self, $array, $indent, $lines) = @_;
+
+ while ( @$lines ) {
+ # Check for a new document
+ if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
+ while ( @$lines and $lines->[0] !~ /^---/ ) {
+ shift @$lines;
+ }
+ return 1;
+ }
+
+ # Check the indent level
+ $lines->[0] =~ /^(\s*)/;
+ if ( length($1) < $indent->[-1] ) {
+ return 1;
+ } elsif ( length($1) > $indent->[-1] ) {
+ die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
+ }
+
+ if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
+ # Inline nested hash
+ my $indent2 = length("$1");
+ $lines->[0] =~ s/-/ /;
+ push @$array, { };
+ $self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
+
+ } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
+ shift @$lines;
+ unless ( @$lines ) {
+ push @$array, undef;
+ return 1;
+ }
+ if ( $lines->[0] =~ /^(\s*)\-/ ) {
+ my $indent2 = length("$1");
+ if ( $indent->[-1] == $indent2 ) {
+ # Null array entry
+ push @$array, undef;
+ } else {
+ # Naked indenter
+ push @$array, [ ];
+ $self->_load_array(
+ $array->[-1], [ @$indent, $indent2 ], $lines
+ );
+ }
+
+ } elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
+ push @$array, { };
+ $self->_load_hash(
+ $array->[-1], [ @$indent, length("$1") ], $lines
+ );
+
+ } else {
+ die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
+ }
+
+ } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
+ # Array entry with a value
+ shift @$lines;
+ push @$array, $self->_load_scalar(
+ "$2", [ @$indent, undef ], $lines
+ );
+
+ } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
+ # This is probably a structure like the following...
+ # ---
+ # foo:
+ # - list
+ # bar: value
+ #
+ # ... so lets return and let the hash parser handle it
+ return 1;
+
+ } else {
+ die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
+ }
+ }
+
+ return 1;
+}
+
+# Load a hash
+sub _load_hash {
+ my ($self, $hash, $indent, $lines) = @_;
+
+ while ( @$lines ) {
+ # Check for a new document
+ if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
+ while ( @$lines and $lines->[0] !~ /^---/ ) {
+ shift @$lines;
+ }
+ return 1;
+ }
+
+ # Check the indent level
+ $lines->[0] =~ /^(\s*)/;
+ if ( length($1) < $indent->[-1] ) {
+ return 1;
+ } elsif ( length($1) > $indent->[-1] ) {
+ die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
+ }
+
+ # Find the key
+ my $key;
+
+ # Quoted keys
+ if ( $lines->[0] =~
+ s/^\s*$re_capture_single_quoted$re_key_value_separator//
+ ) {
+ $key = $self->_unquote_single($1);
+ }
+ elsif ( $lines->[0] =~
+ s/^\s*$re_capture_double_quoted$re_key_value_separator//
+ ) {
+ $key = $self->_unquote_double($1);
+ }
+ elsif ( $lines->[0] =~
+ s/^\s*$re_capture_unquoted_key$re_key_value_separator//
+ ) {
+ $key = $1;
+ $key =~ s/\s+$//;
+ }
+ elsif ( $lines->[0] =~ /^\s*\?/ ) {
+ die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'";
+ }
+ else {
+ die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
+ }
+
+ if ( exists $hash->{$key} ) {
+ warn "CPAN::Meta::YAML found a duplicate key '$key' in line '$lines->[0]'";
+ }
+
+ # Do we have a value?
+ if ( length $lines->[0] ) {
+ # Yes
+ $hash->{$key} = $self->_load_scalar(
+ shift(@$lines), [ @$indent, undef ], $lines
+ );
+ } else {
+ # An indent
+ shift @$lines;
+ unless ( @$lines ) {
+ $hash->{$key} = undef;
+ return 1;
+ }
+ if ( $lines->[0] =~ /^(\s*)-/ ) {
+ $hash->{$key} = [];
+ $self->_load_array(
+ $hash->{$key}, [ @$indent, length($1) ], $lines
+ );
+ } elsif ( $lines->[0] =~ /^(\s*)./ ) {
+ my $indent2 = length("$1");
+ if ( $indent->[-1] >= $indent2 ) {
+ # Null hash entry
+ $hash->{$key} = undef;
+ } else {
+ $hash->{$key} = {};
+ $self->_load_hash(
+ $hash->{$key}, [ @$indent, length($1) ], $lines
+ );
+ }
+ }
+ }
+ }
+
+ return 1;
+}
+
+
+###
+# Dumper functions:
+
+# Save an object to a file
+sub _dump_file {
+ my $self = shift;
+
+ require Fcntl;
+
+ # Check the file
+ my $file = shift or $self->_error( 'You did not specify a file name' );
+
+ my $fh;
+ # flock if available (or warn if not possible for OS-specific reasons)
+ if ( _can_flock() ) {
+ # Open without truncation (truncate comes after lock)
+ my $flags = Fcntl::O_WRONLY()|Fcntl::O_CREAT();
+ sysopen( $fh, $file, $flags );
+ unless ( $fh ) {
+ $self->_error("Failed to open file '$file' for writing: $!");
+ }
+
+ # Use no translation and strict UTF-8
+ binmode( $fh, ":raw:encoding(UTF-8)");
+
+ flock( $fh, Fcntl::LOCK_EX() )
+ or warn "Couldn't lock '$file' for reading: $!";
+
+ # truncate and spew contents
+ truncate $fh, 0;
+ seek $fh, 0, 0;
+ }
+ else {
+ open $fh, ">:unix:encoding(UTF-8)", $file;
+ }
+
+ # serialize and spew to the handle
+ print {$fh} $self->_dump_string;
+
+ # close the file (release the lock)
+ unless ( close $fh ) {
+ $self->_error("Failed to close file '$file': $!");
+ }
+
+ return 1;
+}
+
+# Save an object to a string
+sub _dump_string {
+ my $self = shift;
+ return '' unless ref $self && @$self;
+
+ # Iterate over the documents
+ my $indent = 0;
+ my @lines = ();
+
+ eval {
+ foreach my $cursor ( @$self ) {
+ push @lines, '---';
+
+ # An empty document
+ if ( ! defined $cursor ) {
+ # Do nothing
+
+ # A scalar document
+ } elsif ( ! ref $cursor ) {
+ $lines[-1] .= ' ' . $self->_dump_scalar( $cursor );
+
+ # A list at the root
+ } elsif ( ref $cursor eq 'ARRAY' ) {
+ unless ( @$cursor ) {
+ $lines[-1] .= ' []';
+ next;
+ }
+ push @lines, $self->_dump_array( $cursor, $indent, {} );
+
+ # A hash at the root
+ } elsif ( ref $cursor eq 'HASH' ) {
+ unless ( %$cursor ) {
+ $lines[-1] .= ' {}';
+ next;
+ }
+ push @lines, $self->_dump_hash( $cursor, $indent, {} );
+
+ } else {
+ die \("Cannot serialize " . ref($cursor));
+ }
+ }
+ };
+ if ( ref $@ eq 'SCALAR' ) {
+ $self->_error(${$@});
+ } elsif ( $@ ) {
+ $self->_error($@);
+ }
+
+ join '', map { "$_\n" } @lines;
+}
+
+sub _has_internal_string_value {
+ my $value = shift;
+ my $b_obj = B::svref_2object(\$value); # for round trip problem
+ return $b_obj->FLAGS & B::SVf_POK();
+}
+
+sub _dump_scalar {
+ my $string = $_[1];
+ my $is_key = $_[2];
+ # Check this before checking length or it winds up looking like a string!
+ my $has_string_flag = _has_internal_string_value($string);
+ return '~' unless defined $string;
+ return "''" unless length $string;
+ if (Scalar::Util::looks_like_number($string)) {
+ # keys and values that have been used as strings get quoted
+ if ( $is_key || $has_string_flag ) {
+ return qq['$string'];
+ }
+ else {
+ return $string;
+ }
+ }
+ if ( $string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/ ) {
+ $string =~ s/\\/\\\\/g;
+ $string =~ s/"/\\"/g;
+ $string =~ s/\n/\\n/g;
+ $string =~ s/[\x85]/\\N/g;
+ $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
+ $string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge;
+ return qq|"$string"|;
+ }
+ if ( $string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or
+ $QUOTE{$string}
+ ) {
+ return "'$string'";
+ }
+ return $string;
+}
+
+sub _dump_array {
+ my ($self, $array, $indent, $seen) = @_;
+ if ( $seen->{refaddr($array)}++ ) {
+ die \"CPAN::Meta::YAML does not support circular references";
+ }
+ my @lines = ();
+ foreach my $el ( @$array ) {
+ my $line = (' ' x $indent) . '-';
+ my $type = ref $el;
+ if ( ! $type ) {
+ $line .= ' ' . $self->_dump_scalar( $el );
+ push @lines, $line;
+
+ } elsif ( $type eq 'ARRAY' ) {
+ if ( @$el ) {
+ push @lines, $line;
+ push @lines, $self->_dump_array( $el, $indent + 1, $seen );
+ } else {
+ $line .= ' []';
+ push @lines, $line;
+ }
+
+ } elsif ( $type eq 'HASH' ) {
+ if ( keys %$el ) {
+ push @lines, $line;
+ push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
+ } else {
+ $line .= ' {}';
+ push @lines, $line;
+ }
+
+ } else {
+ die \"CPAN::Meta::YAML does not support $type references";
+ }
+ }
+
+ @lines;
+}
+
+sub _dump_hash {
+ my ($self, $hash, $indent, $seen) = @_;
+ if ( $seen->{refaddr($hash)}++ ) {
+ die \"CPAN::Meta::YAML does not support circular references";
+ }
+ my @lines = ();
+ foreach my $name ( sort keys %$hash ) {
+ my $el = $hash->{$name};
+ my $line = (' ' x $indent) . $self->_dump_scalar($name, 1) . ":";
+ my $type = ref $el;
+ if ( ! $type ) {
+ $line .= ' ' . $self->_dump_scalar( $el );
+ push @lines, $line;
+
+ } elsif ( $type eq 'ARRAY' ) {
+ if ( @$el ) {
+ push @lines, $line;
+ push @lines, $self->_dump_array( $el, $indent + 1, $seen );
+ } else {
+ $line .= ' []';
+ push @lines, $line;
+ }
+
+ } elsif ( $type eq 'HASH' ) {
+ if ( keys %$el ) {
+ push @lines, $line;
+ push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
+ } else {
+ $line .= ' {}';
+ push @lines, $line;
+ }
+
+ } else {
+ die \"CPAN::Meta::YAML does not support $type references";
+ }
+ }
+
+ @lines;
+}
+
+
+
+#####################################################################
+# DEPRECATED API methods:
+
+# Error storage (DEPRECATED as of 1.57)
+our $errstr = '';
+
+# Set error
+sub _error {
+ require Carp;
+ $errstr = $_[1];
+ $errstr =~ s/ at \S+ line \d+.*//;
+ Carp::croak( $errstr );
+}
+
+# Retrieve error
+my $errstr_warned;
+sub errstr {
+ require Carp;
+ Carp::carp( "CPAN::Meta::YAML->errstr and \$CPAN::Meta::YAML::errstr is deprecated" )
+ unless $errstr_warned++;
+ $errstr;
+}
+
+
+
+
+#####################################################################
+# Helper functions. Possibly not needed.
+
+
+# Use to detect nv or iv
+use B;
+
+# XXX-INGY Is flock CPAN::Meta::YAML's responsibility?
+# Some platforms can't flock :-(
+# XXX-XDG I think it is. When reading and writing files, we ought
+# to be locking whenever possible. People (foolishly) use YAML
+# files for things like session storage, which has race issues.
+my $HAS_FLOCK;
+sub _can_flock {
+ if ( defined $HAS_FLOCK ) {
+ return $HAS_FLOCK;
+ }
+ else {
+ require Config;
+ my $c = \%Config::Config;
+ $HAS_FLOCK = grep { $c->{$_} } qw/d_flock d_fcntl_can_lock d_lockf/;
+ require Fcntl if $HAS_FLOCK;
+ return $HAS_FLOCK;
+ }
+}
+
+
+# XXX-INGY Is this core in 5.8.1? Can we remove this?
+# XXX-XDG Scalar::Util 1.18 didn't land until 5.8.8, so we need this
+#####################################################################
+# Use Scalar::Util if possible, otherwise emulate it
+
+use Scalar::Util ();
+BEGIN {
+ local $@;
+ if ( eval { Scalar::Util->VERSION(1.18); } ) {
+ *refaddr = *Scalar::Util::refaddr;
+ }
+ else {
+ eval <<'END_PERL';
+# Scalar::Util failed to load or too old
+sub refaddr {
+ my $pkg = ref($_[0]) or return undef;
+ if ( !! UNIVERSAL::can($_[0], 'can') ) {
+ bless $_[0], 'Scalar::Util::Fake';
+ } else {
+ $pkg = undef;
+ }
+ "$_[0]" =~ /0x(\w+)/;
+ my $i = do { no warnings 'portable'; hex $1 };
+ bless $_[0], $pkg if defined $pkg;
+ $i;
+}
+END_PERL
+ }
+}
+
+delete $CPAN::Meta::YAML::{refaddr};
+
+1;
+
+# XXX-INGY Doc notes I'm putting up here. Changing the doc when it's wrong
+# but leaving grey area stuff up here.
+#
+# I would like to change Read/Write to Load/Dump below without
+# changing the actual API names.
+#
+# It might be better to put Load/Dump API in the SYNOPSIS instead of the
+# dubious OO API.
+#
+# null and bool explanations may be outdated.
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+CPAN::Meta::YAML - Read and write a subset of YAML for CPAN Meta files
+
+=head1 VERSION
+
+version 0.018
+
+=head1 SYNOPSIS
+
+ use CPAN::Meta::YAML;
+
+ # reading a META file
+ open $fh, "<:utf8", "META.yml";
+ $yaml_text = do { local $/; <$fh> };
+ $yaml = CPAN::Meta::YAML->read_string($yaml_text)
+ or die CPAN::Meta::YAML->errstr;
+
+ # finding the metadata
+ $meta = $yaml->[0];
+
+ # writing a META file
+ $yaml_text = $yaml->write_string
+ or die CPAN::Meta::YAML->errstr;
+ open $fh, ">:utf8", "META.yml";
+ print $fh $yaml_text;
+
+=head1 DESCRIPTION
+
+This module implements a subset of the YAML specification for use in reading
+and writing CPAN metadata files like F<META.yml> and F<MYMETA.yml>. It should
+not be used for any other general YAML parsing or generation task.
+
+NOTE: F<META.yml> (and F<MYMETA.yml>) files should be UTF-8 encoded. Users are
+responsible for proper encoding and decoding. In particular, the C<read> and
+C<write> methods do B<not> support UTF-8 and should not be used.
+
+=head1 SUPPORT
+
+This module is currently derived from L<YAML::Tiny> by Adam Kennedy. If
+there are bugs in how it parses a particular META.yml file, please file
+a bug report in the YAML::Tiny bugtracker:
+L<https://github.com/Perl-Toolchain-Gang/YAML-Tiny/issues>
+
+=head1 SEE ALSO
+
+L<YAML::Tiny>, L<YAML>, L<YAML::XS>
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+Adam Kennedy <adamk@cpan.org>
+
+=item *
+
+David Golden <dagolden@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2010 by Adam Kennedy.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
+
+__END__
+
+
+# ABSTRACT: Read and write a subset of YAML for CPAN Meta files
+
+
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Mirrors.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Mirrors.pm
new file mode 100644
index 0000000000..4ceca0458c
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Mirrors.pm
@@ -0,0 +1,589 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+=head1 NAME
+
+CPAN::Mirrors - Get CPAN mirror information and select a fast one
+
+=head1 SYNOPSIS
+
+ use CPAN::Mirrors;
+
+ my $mirrors = CPAN::Mirrors->new( $mirrored_by_file );
+
+ my $seen = {};
+
+ my $best_continent = $mirrors->find_best_continents( { seen => $seen } );
+ my @mirrors = $mirrors->get_mirrors_by_continents( $best_continent );
+
+ my $callback = sub {
+ my( $m ) = @_;
+ printf "%s = %s\n", $m->hostname, $m->rtt
+ };
+ $mirrors->get_mirrors_timings( \@mirrors, $seen, $callback );
+
+ @mirrors = sort { $a->rtt <=> $b->rtt } @mirrors;
+
+ print "Best mirrors are ", map( { $_->rtt } @mirrors[0..3] ), "\n";
+
+=head1 DESCRIPTION
+
+=over
+
+=cut
+
+package CPAN::Mirrors;
+use strict;
+use vars qw($VERSION $urllist $silent);
+$VERSION = "2.12";
+
+use Carp;
+use FileHandle;
+use Fcntl ":flock";
+use Net::Ping ();
+
+=item new( LOCAL_FILE_NAME )
+
+Create a new CPAN::Mirrors object from LOCAL_FILE_NAME. This file
+should look like that in http://www.cpan.org/MIRRORED.BY .
+
+=cut
+
+sub new {
+ my ($class, $file) = @_;
+ croak "CPAN::Mirrors->new requires a filename" unless defined $file;
+ croak "The file [$file] was not found" unless -e $file;
+
+ my $self = bless {
+ mirrors => [],
+ geography => {},
+ }, $class;
+
+ $self->parse_mirrored_by( $file );
+
+ return $self;
+}
+
+sub parse_mirrored_by {
+ my ($self, $file) = @_;
+ my $handle = FileHandle->new;
+ $handle->open($file)
+ or croak "Couldn't open $file: $!";
+ flock $handle, LOCK_SH;
+ $self->_parse($file,$handle);
+ flock $handle, LOCK_UN;
+ $handle->close;
+}
+
+=item continents()
+
+Return a list of continents based on those defined in F<MIRRORED.BY>.
+
+=cut
+
+sub continents {
+ my ($self) = @_;
+ return sort keys %{$self->{geography}};
+}
+
+=item countries( [CONTINENTS] )
+
+Return a list of countries based on those defined in F<MIRRORED.BY>.
+It only returns countries for the continents you specify (as defined
+in C<continents>). If you don't specify any continents, it returns all
+of the countries listed in F<MIRRORED.BY>.
+
+=cut
+
+sub countries {
+ my ($self, @continents) = @_;
+ @continents = $self->continents unless @continents;
+ my @countries;
+ for my $c (@continents) {
+ push @countries, sort keys %{ $self->{geography}{$c} };
+ }
+ return @countries;
+}
+
+=item mirrors( [COUNTRIES] )
+
+Return a list of mirrors based on those defined in F<MIRRORED.BY>.
+It only returns mirrors for the countries you specify (as defined
+in C<countries>). If you don't specify any countries, it returns all
+of the mirrors listed in F<MIRRORED.BY>.
+
+=cut
+
+sub mirrors {
+ my ($self, @countries) = @_;
+ return @{$self->{mirrors}} unless @countries;
+ my %wanted = map { $_ => 1 } @countries;
+ my @found;
+ for my $m (@{$self->{mirrors}}) {
+ push @found, $m if exists $wanted{$m->country};
+ }
+ return @found;
+}
+
+=item get_mirrors_by_countries( [COUNTRIES] )
+
+A more sensible synonym for mirrors.
+
+=cut
+
+sub get_mirrors_by_countries { &mirrors }
+
+=item get_mirrors_by_continents( [CONTINENTS] )
+
+Return a list of mirrors for all of continents you specify. If you don't
+specify any continents, it returns all of the mirrors.
+
+You can specify a single continent or an array reference of continents.
+
+=cut
+
+sub get_mirrors_by_continents {
+ my ($self, $continents ) = @_;
+ $continents = [ $continents ] unless ref $continents;
+
+ eval {
+ $self->mirrors( $self->get_countries_by_continents( @$continents ) );
+ };
+ }
+
+=item get_countries_by_continents( [CONTINENTS] )
+
+A more sensible synonym for countries.
+
+=cut
+
+sub get_countries_by_continents { &countries }
+
+=item default_mirror
+
+Returns the default mirror, http://www.cpan.org/ . This mirror uses
+dynamic DNS to give a close mirror.
+
+=cut
+
+sub default_mirror { 'http://www.cpan.org/' }
+
+=item best_mirrors
+
+C<best_mirrors> checks for the best mirrors based on the list of
+continents you pass, or, without that, all continents, as defined
+by C<CPAN::Mirrored::By>. It pings each mirror, up to the value of
+C<how_many>. In list context, it returns up to C<how_many> mirror.
+In scalar context, it returns the single best mirror.
+
+Arguments
+
+ how_many - the number of mirrors to return. Default: 1
+ callback - a callback for find_best_continents
+ verbose - true or false on all the whining and moaning. Default: false
+ continents - an array ref of the continents to check
+
+If you don't specify the continents, C<best_mirrors> calls
+C<find_best_continents> to get the list of continents to check.
+
+If you don't have L<Net::Ping> v2.13 or later, needed for timings,
+this returns the default mirror.
+
+=cut
+
+sub best_mirrors {
+ my ($self, %args) = @_;
+ my $how_many = $args{how_many} || 1;
+ my $callback = $args{callback};
+ my $verbose = defined $args{verbose} ? $args{verbose} : 0;
+ my $continents = $args{continents} || [];
+ $continents = [$continents] unless ref $continents;
+
+ # Old Net::Ping did not do timings at all
+ my $min_version = '2.13';
+ unless( Net::Ping->VERSION gt $min_version ) {
+ carp sprintf "Net::Ping version is %s (< %s). Returning %s",
+ Net::Ping->VERSION, $min_version, $self->default_mirror;
+ return $self->default_mirror;
+ }
+
+ my $seen = {};
+
+ if ( ! @$continents ) {
+ print "Searching for the best continent ...\n" if $verbose;
+ my @best_continents = $self->find_best_continents(
+ seen => $seen,
+ verbose => $verbose,
+ callback => $callback,
+ );
+
+ # Only add enough continents to find enough mirrors
+ my $count = 0;
+ for my $continent ( @best_continents ) {
+ push @$continents, $continent;
+ $count += $self->mirrors( $self->countries($continent) );
+ last if $count >= $how_many;
+ }
+ }
+
+ print "Scanning " . join(", ", @$continents) . " ...\n" if $verbose;
+
+ my $trial_mirrors = $self->get_n_random_mirrors_by_continents( 3 * $how_many, $continents->[0] );
+
+ my $timings = $self->get_mirrors_timings( $trial_mirrors, $seen, $callback );
+ return [] unless @$timings;
+
+ $how_many = @$timings if $how_many > @$timings;
+
+ return wantarray ? @{$timings}[0 .. $how_many-1] : $timings->[0];
+}
+
+=item get_n_random_mirrors_by_continents( N, [CONTINENTS] )
+
+Returns up to N random mirrors for the specified continents. Specify the
+continents as an array reference.
+
+=cut
+
+sub get_n_random_mirrors_by_continents {
+ my( $self, $n, $continents ) = @_;
+ $n ||= 3;
+ $continents = [ $continents ] unless ref $continents;
+
+ if ( $n <= 0 ) {
+ return wantarray ? () : [];
+ }
+
+ my @long_list = $self->get_mirrors_by_continents( $continents );
+
+ if ( $n eq '*' or $n > @long_list ) {
+ return wantarray ? @long_list : \@long_list;
+ }
+
+ @long_list = map {$_->[0]}
+ sort {$a->[1] <=> $b->[1]}
+ map {[$_, rand]} @long_list;
+
+ splice @long_list, $n; # truncate
+
+ \@long_list;
+}
+
+=item get_mirrors_timings( MIRROR_LIST, SEEN, CALLBACK );
+
+Pings the listed mirrors and returns a list of mirrors sorted in
+ascending ping times.
+
+C<MIRROR_LIST> is an anonymous array of C<CPAN::Mirrored::By> objects to
+ping.
+
+The optional argument C<SEEN> is a hash reference used to track the
+mirrors you've already pinged.
+
+The optional argument C<CALLBACK> is a subroutine reference to call
+after each ping. It gets the C<CPAN::Mirrored::By> object after each
+ping.
+
+=cut
+
+sub get_mirrors_timings {
+ my( $self, $mirror_list, $seen, $callback ) = @_;
+
+ $seen = {} unless defined $seen;
+ croak "The mirror list argument must be an array reference"
+ unless ref $mirror_list eq ref [];
+ croak "The seen argument must be a hash reference"
+ unless ref $seen eq ref {};
+ croak "callback must be a subroutine"
+ if( defined $callback and ref $callback ne ref sub {} );
+
+ my $timings = [];
+ for my $m ( @$mirror_list ) {
+ $seen->{$m->hostname} = $m;
+ next unless eval{ $m->http };
+
+ if( $self->_try_a_ping( $seen, $m, ) ) {
+ my $ping = $m->ping;
+ next unless defined $ping;
+ push @$timings, $m;
+ $callback->( $m ) if $callback;
+ }
+ else {
+ push @$timings, $seen->{$m->hostname}
+ if defined $seen->{$m->hostname}->rtt;
+ }
+ }
+
+ my @best = sort {
+ if( defined $a->rtt and defined $b->rtt ) {
+ $a->rtt <=> $b->rtt
+ }
+ elsif( defined $a->rtt and ! defined $b->rtt ) {
+ return -1;
+ }
+ elsif( ! defined $a->rtt and defined $b->rtt ) {
+ return 1;
+ }
+ elsif( ! defined $a->rtt and ! defined $b->rtt ) {
+ return 0;
+ }
+
+ } @$timings;
+
+ return wantarray ? @best : \@best;
+}
+
+=item find_best_continents( HASH_REF );
+
+C<find_best_continents> goes through each continent and pings C<N>
+random mirrors on that continent. It then orders the continents by
+ascending median ping time. In list context, it returns the ordered list
+of continent. In scalar context, it returns the same list as an
+anonymous array.
+
+Arguments:
+
+ n - the number of hosts to ping for each continent. Default: 3
+ seen - a hashref of cached hostname ping times
+ verbose - true or false for noisy or quiet. Default: false
+ callback - a subroutine to run after each ping.
+ ping_cache_limit - how long, in seconds, to reuse previous ping times.
+ Default: 1 day
+
+The C<seen> hash has hostnames as keys and anonymous arrays as values.
+The anonymous array is a triplet of a C<CPAN::Mirrored::By> object, a
+ping time, and the epoch time for the measurement.
+
+The callback subroutine gets the C<CPAN::Mirrored::By> object, the ping
+time, and measurement time (the same things in the C<seen> hashref) as
+arguments. C<find_best_continents> doesn't care what the callback does
+and ignores the return value.
+
+With a low value for C<N>, a single mirror might skew the results enough
+to choose a worse continent. If you have that problem, try a larger
+value.
+
+=cut
+
+sub find_best_continents {
+ my ($self, %args) = @_;
+
+ $args{n} ||= 3;
+ $args{verbose} = 0 unless defined $args{verbose};
+ $args{seen} = {} unless defined $args{seen};
+ croak "The seen argument must be a hash reference"
+ unless ref $args{seen} eq ref {};
+ $args{ping_cache_limit} = 24 * 60 * 60
+ unless defined $args{ping_cache_time};
+ croak "callback must be a subroutine"
+ if( defined $args{callback} and ref $args{callback} ne ref sub {} );
+
+ my %medians;
+ CONT: for my $c ( $self->continents ) {
+ print "Testing $c\n" if $args{verbose};
+ my @mirrors = $self->mirrors( $self->countries($c) );
+
+ next CONT unless @mirrors;
+ my $n = (@mirrors < $args{n}) ? @mirrors : $args{n};
+
+ my @tests;
+ my $tries = 0;
+ RANDOM: while ( @mirrors && @tests < $n && $tries++ < 15 ) {
+ my $m = splice( @mirrors, int(rand(@mirrors)), 1 );
+ if( $self->_try_a_ping( $args{seen}, $m, $args{ping_cache_limit} ) ) {
+ $self->get_mirrors_timings( [ $m ], @args{qw(seen callback)} );
+ next RANDOM unless defined $args{seen}{$m->hostname}->rtt;
+ }
+ printf "\t%s -> %0.2f ms\n",
+ $m->hostname,
+ join ' ', 1000 * $args{seen}{$m->hostname}->rtt
+ if $args{verbose};
+
+ push @tests, $args{seen}{$m->hostname}->rtt;
+ }
+
+ my $median = $self->_get_median_ping_time( \@tests, $args{verbose} );
+ $medians{$c} = $median if defined $median;
+ }
+
+ my @best_cont = sort { $medians{$a} <=> $medians{$b} } keys %medians;
+
+ if ( $args{verbose} ) {
+ print "Median result by continent:\n";
+ for my $c ( @best_cont ) {
+ printf( " %4d ms %s\n", int($medians{$c}*1000+.5), $c );
+ }
+ }
+
+ return wantarray ? @best_cont : $best_cont[0];
+}
+
+# retry if
+sub _try_a_ping {
+ my ($self, $seen, $mirror, $ping_cache_limit ) = @_;
+
+ ( ! exists $seen->{$mirror->hostname} )
+ or
+ (
+ ! defined $seen->{$mirror->hostname}->rtt
+ or
+ time - $seen->{$mirror->hostname}->rtt > $ping_cache_limit
+ )
+}
+
+sub _get_median_ping_time {
+ my ($self, $tests, $verbose ) = @_;
+
+ my @sorted = sort { $a <=> $b } @$tests;
+
+ my $median = do {
+ if ( @sorted == 0 ) { undef }
+ elsif ( @sorted == 1 ) { $sorted[0] }
+ elsif ( @sorted % 2 ) { $sorted[ int(@sorted / 2) ] }
+ else {
+ my $mid_high = int(@sorted/2);
+ ($sorted[$mid_high-1] + $sorted[$mid_high])/2;
+ }
+ };
+
+ printf "\t-->median time: %0.2f ms\n", $median * 1000 if $verbose;
+
+ return $median;
+}
+
+# Adapted from Parse::CPAN::MirroredBy by Adam Kennedy
+sub _parse {
+ my ($self, $file, $handle) = @_;
+ my $output = $self->{mirrors};
+ my $geo = $self->{geography};
+
+ local $/ = "\012";
+ my $line = 0;
+ my $mirror = undef;
+ while ( 1 ) {
+ # Next line
+ my $string = <$handle>;
+ last if ! defined $string;
+ $line = $line + 1;
+
+ # Remove the useless lines
+ chomp( $string );
+ next if $string =~ /^\s*$/;
+ next if $string =~ /^\s*#/;
+
+ # Hostname or property?
+ if ( $string =~ /^\s/ ) {
+ # Property
+ unless ( $string =~ /^\s+(\w+)\s+=\s+\"(.*)\"$/ ) {
+ croak("Invalid property on line $line");
+ }
+ my ($prop, $value) = ($1,$2);
+ $mirror ||= {};
+ if ( $prop eq 'dst_location' ) {
+ my (@location,$continent,$country);
+ @location = (split /\s*,\s*/, $value)
+ and ($continent, $country) = @location[-1,-2];
+ $continent =~ s/\s\(.*//;
+ $continent =~ s/\W+$//; # if Jarkko doesn't know latitude/longitude
+ $geo->{$continent}{$country} = 1 if $continent && $country;
+ $mirror->{continent} = $continent || "unknown";
+ $mirror->{country} = $country || "unknown";
+ }
+ elsif ( $prop eq 'dst_http' ) {
+ $mirror->{http} = $value;
+ }
+ elsif ( $prop eq 'dst_ftp' ) {
+ $mirror->{ftp} = $value;
+ }
+ elsif ( $prop eq 'dst_rsync' ) {
+ $mirror->{rsync} = $value;
+ }
+ else {
+ $prop =~ s/^dst_//;
+ $mirror->{$prop} = $value;
+ }
+ } else {
+ # Hostname
+ unless ( $string =~ /^([\w\.-]+)\:\s*$/ ) {
+ croak("Invalid host name on line $line");
+ }
+ my $current = $mirror;
+ $mirror = { hostname => "$1" };
+ if ( $current ) {
+ push @$output, CPAN::Mirrored::By->new($current);
+ }
+ }
+ }
+ if ( $mirror ) {
+ push @$output, CPAN::Mirrored::By->new($mirror);
+ }
+
+ return;
+}
+
+#--------------------------------------------------------------------------#
+
+package CPAN::Mirrored::By;
+use strict;
+use Net::Ping ();
+
+sub new {
+ my($self,$arg) = @_;
+ $arg ||= {};
+ bless $arg, $self;
+}
+sub hostname { shift->{hostname} }
+sub continent { shift->{continent} }
+sub country { shift->{country} }
+sub http { shift->{http} || '' }
+sub ftp { shift->{ftp} || '' }
+sub rsync { shift->{rsync} || '' }
+sub rtt { shift->{rtt} }
+sub ping_time { shift->{ping_time} }
+
+sub url {
+ my $self = shift;
+ return $self->{http} || $self->{ftp};
+}
+
+sub ping {
+ my $self = shift;
+
+ my $ping = Net::Ping->new($^O eq 'VMS' ? 'icmp' : 'tcp', 1);
+ my ($proto) = $self->url =~ m{^([^:]+)};
+ my $port = $proto eq 'http' ? 80 : 21;
+ return unless $port;
+
+ if ( $ping->can('port_number') ) {
+ $ping->port_number($port);
+ }
+ else {
+ $ping->{'port_num'} = $port;
+ }
+
+ $ping->hires(1) if $ping->can('hires');
+ my ($alive,$rtt) = $ping->ping($self->hostname);
+
+ $self->{rtt} = $alive ? $rtt : undef;
+ $self->{ping_time} = time;
+
+ $self->rtt;
+}
+
+
+1;
+
+=back
+
+=head1 AUTHOR
+
+Andreas Koenig C<< <andk@cpan.org> >>, David Golden C<< <dagolden@cpan.org> >>,
+brian d foy C<< <bdfoy@cpan.org> >>
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Module.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Module.pm
new file mode 100644
index 0000000000..62ca42caf0
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Module.pm
@@ -0,0 +1,702 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Module;
+use strict;
+@CPAN::Module::ISA = qw(CPAN::InfoObj);
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5003";
+
+BEGIN {
+ # alarm() is not implemented in perl 5.6.x and earlier under Windows
+ *ALARM_IMPLEMENTED = sub () { $] >= 5.007 || $^O !~ /MSWin/ };
+}
+
+# Accessors
+#-> sub CPAN::Module::userid
+sub userid {
+ my $self = shift;
+ my $ro = $self->ro;
+ return unless $ro;
+ return $ro->{userid} || $ro->{CPAN_USERID};
+}
+#-> sub CPAN::Module::description
+sub description {
+ my $self = shift;
+ my $ro = $self->ro or return "";
+ $ro->{description}
+}
+
+#-> sub CPAN::Module::distribution
+sub distribution {
+ my($self) = @_;
+ CPAN::Shell->expand("Distribution",$self->cpan_file);
+}
+
+#-> sub CPAN::Module::_is_representative_module
+sub _is_representative_module {
+ my($self) = @_;
+ return $self->{_is_representative_module} if defined $self->{_is_representative_module};
+ my $pm = $self->cpan_file or return $self->{_is_representative_module} = 0;
+ $pm =~ s|.+/||;
+ $pm =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i; # see base_id
+ $pm =~ s|-\d+\.\d+.+$||;
+ $pm =~ s|-[\d\.]+$||;
+ $pm =~ s/-/::/g;
+ $self->{_is_representative_module} = $pm eq $self->{ID} ? 1 : 0;
+ # warn "DEBUG: $pm eq $self->{ID} => $self->{_is_representative_module}";
+ $self->{_is_representative_module};
+}
+
+#-> sub CPAN::Module::undelay
+sub undelay {
+ my $self = shift;
+ delete $self->{later};
+ if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
+ $dist->undelay;
+ }
+}
+
+# mark as dirty/clean
+#-> sub CPAN::Module::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
+
+ return if exists $self->{incommandcolor}
+ && $color==1
+ && $self->{incommandcolor}==$color;
+ return if $color==0 && !$self->{incommandcolor};
+ if ($color>=1) {
+ if ( $self->uptodate ) {
+ $self->{incommandcolor} = $color;
+ return;
+ } elsif (my $have_version = $self->available_version) {
+ # maybe what we have is good enough
+ if (@$ancestors) {
+ my $who_asked_for_me = $ancestors->[-1];
+ my $obj = CPAN::Shell->expandany($who_asked_for_me);
+ if (0) {
+ } elsif ($obj->isa("CPAN::Bundle")) {
+ # bundles cannot specify a minimum version
+ return;
+ } elsif ($obj->isa("CPAN::Distribution")) {
+ if (my $prereq_pm = $obj->prereq_pm) {
+ for my $k (keys %$prereq_pm) {
+ if (my $want_version = $prereq_pm->{$k}{$self->id}) {
+ if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
+ $self->{incommandcolor} = $color;
+ return;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ } else {
+ $self->{incommandcolor} = $color; # set me before recursion,
+ # so we can break it
+ }
+ if ($depth>=$CPAN::MAX_RECURSION) {
+ my $e = CPAN::Exception::RecursiveDependency->new($ancestors);
+ if ($e->is_resolvable) {
+ return $self->{incommandcolor}=2;
+ } else {
+ die $e;
+ }
+ }
+ # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
+
+ if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
+ $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
+ }
+ # unreached code?
+ # if ($color==0) {
+ # delete $self->{badtestcnt};
+ # }
+ $self->{incommandcolor} = $color;
+}
+
+#-> sub CPAN::Module::as_glimpse ;
+sub as_glimpse {
+ my($self) = @_;
+ my(@m);
+ my $class = ref($self);
+ $class =~ s/^CPAN:://;
+ my $color_on = "";
+ my $color_off = "";
+ if (
+ $CPAN::Shell::COLOR_REGISTERED
+ &&
+ $CPAN::META->has_inst("Term::ANSIColor")
+ &&
+ $self->description
+ ) {
+ $color_on = Term::ANSIColor::color("green");
+ $color_off = Term::ANSIColor::color("reset");
+ }
+ my $uptodateness = " ";
+ unless ($class eq "Bundle") {
+ my $u = $self->uptodate;
+ $uptodateness = $u ? "=" : "<" if defined $u;
+ };
+ my $id = do {
+ my $d = $self->distribution;
+ $d ? $d -> pretty_id : $self->cpan_userid;
+ };
+ push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
+ $class,
+ $uptodateness,
+ $color_on,
+ $self->id,
+ $color_off,
+ $id,
+ );
+ join "", @m;
+}
+
+#-> sub CPAN::Module::dslip_status
+sub dslip_status {
+ my($self) = @_;
+ my($stat);
+ # development status
+ @{$stat->{D}}{qw,i c a b R M S,} = qw,idea
+ pre-alpha alpha beta released
+ mature standard,;
+ # support level
+ @{$stat->{S}}{qw,m d u n a,} = qw,mailing-list
+ developer comp.lang.perl.*
+ none abandoned,;
+ # language
+ @{$stat->{L}}{qw,p c + o h,} = qw,perl C C++ other hybrid,;
+ # interface
+ @{$stat->{I}}{qw,f r O p h n,} = qw,functions
+ references+ties
+ object-oriented pragma
+ hybrid none,;
+ # public licence
+ @{$stat->{P}}{qw,p g l b a 2 o d r n,} = qw,Standard-Perl
+ GPL LGPL
+ BSD Artistic Artistic_2
+ open-source
+ distribution_allowed
+ restricted_distribution
+ no_licence,;
+ for my $x (qw(d s l i p)) {
+ $stat->{$x}{' '} = 'unknown';
+ $stat->{$x}{'?'} = 'unknown';
+ }
+ my $ro = $self->ro;
+ return +{} unless $ro && $ro->{statd};
+ return {
+ D => $ro->{statd},
+ S => $ro->{stats},
+ L => $ro->{statl},
+ I => $ro->{stati},
+ P => $ro->{statp},
+ DV => $stat->{D}{$ro->{statd}},
+ SV => $stat->{S}{$ro->{stats}},
+ LV => $stat->{L}{$ro->{statl}},
+ IV => $stat->{I}{$ro->{stati}},
+ PV => $stat->{P}{$ro->{statp}},
+ };
+}
+
+#-> sub CPAN::Module::as_string ;
+sub as_string {
+ my($self) = @_;
+ my(@m);
+ CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
+ my $class = ref($self);
+ $class =~ s/^CPAN:://;
+ local($^W) = 0;
+ push @m, $class, " id = $self->{ID}\n";
+ my $sprintf = " %-12s %s\n";
+ push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
+ if $self->description;
+ my $sprintf2 = " %-12s %s (%s)\n";
+ my($userid);
+ $userid = $self->userid;
+ if ( $userid ) {
+ my $author;
+ if ($author = CPAN::Shell->expand('Author',$userid)) {
+ my $email = "";
+ my $m; # old perls
+ if ($m = $author->email) {
+ $email = " <$m>";
+ }
+ push @m, sprintf(
+ $sprintf2,
+ 'CPAN_USERID',
+ $userid,
+ $author->fullname . $email
+ );
+ }
+ }
+ push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
+ if $self->cpan_version;
+ if (my $cpan_file = $self->cpan_file) {
+ push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
+ if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
+ my $upload_date = $dist->upload_date;
+ if ($upload_date) {
+ push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
+ }
+ }
+ }
+ my $sprintf3 = " %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
+ my $dslip = $self->dslip_status;
+ push @m, sprintf(
+ $sprintf3,
+ 'DSLIP_STATUS',
+ @{$dslip}{qw(D S L I P DV SV LV IV PV)},
+ ) if $dslip->{D};
+ my $local_file = $self->inst_file;
+ unless ($self->{MANPAGE}) {
+ my $manpage;
+ if ($local_file) {
+ $manpage = $self->manpage_headline($local_file);
+ } else {
+ # If we have already untarred it, we should look there
+ my $dist = $CPAN::META->instance('CPAN::Distribution',
+ $self->cpan_file);
+ # warn "dist[$dist]";
+ # mff=manifest file; mfh=manifest handle
+ my($mff,$mfh);
+ if (
+ $dist->{build_dir}
+ and
+ (-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
+ and
+ $mfh = FileHandle->new($mff)
+ ) {
+ CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
+ my $lfre = $self->id; # local file RE
+ $lfre =~ s/::/./g;
+ $lfre .= "\\.pm\$";
+ my($lfl); # local file file
+ local $/ = "\n";
+ my(@mflines) = <$mfh>;
+ for (@mflines) {
+ s/^\s+//;
+ s/\s.*//s;
+ }
+ while (length($lfre)>5 and !$lfl) {
+ ($lfl) = grep /$lfre/, @mflines;
+ CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
+ $lfre =~ s/.+?\.//;
+ }
+ $lfl =~ s/\s.*//; # remove comments
+ $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
+ my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
+ # warn "lfl_abs[$lfl_abs]";
+ if (-f $lfl_abs) {
+ $manpage = $self->manpage_headline($lfl_abs);
+ }
+ }
+ }
+ $self->{MANPAGE} = $manpage if $manpage;
+ }
+ my($item);
+ for $item (qw/MANPAGE/) {
+ push @m, sprintf($sprintf, $item, $self->{$item})
+ if exists $self->{$item};
+ }
+ for $item (qw/CONTAINS/) {
+ push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
+ if exists $self->{$item} && @{$self->{$item}};
+ }
+ push @m, sprintf($sprintf, 'INST_FILE',
+ $local_file || "(not installed)");
+ push @m, sprintf($sprintf, 'INST_VERSION',
+ $self->inst_version) if $local_file;
+ if (%{$CPAN::META->{is_tested}||{}}) { # XXX needs to be methodified somehow
+ my $available_file = $self->available_file;
+ if ($available_file && $available_file ne $local_file) {
+ push @m, sprintf($sprintf, 'AVAILABLE_FILE', $available_file);
+ push @m, sprintf($sprintf, 'AVAILABLE_VERSION', $self->available_version);
+ }
+ }
+ join "", @m, "\n";
+}
+
+#-> sub CPAN::Module::manpage_headline
+sub manpage_headline {
+ my($self,$local_file) = @_;
+ my(@local_file) = $local_file;
+ $local_file =~ s/\.pm(?!\n)\Z/.pod/;
+ push @local_file, $local_file;
+ my(@result,$locf);
+ for $locf (@local_file) {
+ next unless -f $locf;
+ my $fh = FileHandle->new($locf)
+ or $Carp::Frontend->mydie("Couldn't open $locf: $!");
+ my $inpod = 0;
+ local $/ = "\n";
+ while (<$fh>) {
+ $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
+ m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
+ next unless $inpod;
+ next if /^=/;
+ next if /^\s+$/;
+ chomp;
+ push @result, $_;
+ }
+ close $fh;
+ last if @result;
+ }
+ for (@result) {
+ s/^\s+//;
+ s/\s+$//;
+ }
+ join " ", @result;
+}
+
+#-> sub CPAN::Module::cpan_file ;
+# Note: also inherited by CPAN::Bundle
+sub cpan_file {
+ my $self = shift;
+ # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
+ unless ($self->ro) {
+ CPAN::Index->reload;
+ }
+ my $ro = $self->ro;
+ if ($ro && defined $ro->{CPAN_FILE}) {
+ return $ro->{CPAN_FILE};
+ } else {
+ my $userid = $self->userid;
+ if ( $userid ) {
+ if ($CPAN::META->exists("CPAN::Author",$userid)) {
+ my $author = $CPAN::META->instance("CPAN::Author",
+ $userid);
+ my $fullname = $author->fullname;
+ my $email = $author->email;
+ unless (defined $fullname && defined $email) {
+ return sprintf("Contact Author %s",
+ $userid,
+ );
+ }
+ return "Contact Author $fullname <$email>";
+ } else {
+ return "Contact Author $userid (Email address not available)";
+ }
+ } else {
+ return "N/A";
+ }
+ }
+}
+
+#-> sub CPAN::Module::cpan_version ;
+sub cpan_version {
+ my $self = shift;
+
+ my $ro = $self->ro;
+ unless ($ro) {
+ # Can happen with modules that are not on CPAN
+ $ro = {};
+ }
+ $ro->{CPAN_VERSION} = 'undef'
+ unless defined $ro->{CPAN_VERSION};
+ $ro->{CPAN_VERSION};
+}
+
+#-> sub CPAN::Module::force ;
+sub force {
+ my($self) = @_;
+ $self->{force_update} = 1;
+}
+
+#-> sub CPAN::Module::fforce ;
+sub fforce {
+ my($self) = @_;
+ $self->{force_update} = 2;
+}
+
+#-> sub CPAN::Module::notest ;
+sub notest {
+ my($self) = @_;
+ # $CPAN::Frontend->mywarn("XDEBUG: set notest for Module");
+ $self->{notest}++;
+}
+
+#-> sub CPAN::Module::rematein ;
+sub rematein {
+ my($self,$meth) = @_;
+ $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
+ $meth,
+ $self->id));
+ my $cpan_file = $self->cpan_file;
+ if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/) {
+ $CPAN::Frontend->mywarn(sprintf qq{
+ The module %s isn\'t available on CPAN.
+
+ Either the module has not yet been uploaded to CPAN, or it is
+ temporary unavailable. Please contact the author to find out
+ more about the status. Try 'i %s'.
+},
+ $self->id,
+ $self->id,
+ );
+ return;
+ }
+ my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
+ $pack->called_for($self->id);
+ if (exists $self->{force_update}) {
+ if ($self->{force_update} == 2) {
+ $pack->fforce($meth);
+ } else {
+ $pack->force($meth);
+ }
+ }
+ $pack->notest($meth) if exists $self->{notest} && $self->{notest};
+
+ $pack->{reqtype} ||= "";
+ CPAN->debug("dist-reqtype[$pack->{reqtype}]".
+ "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
+ if ($pack->{reqtype}) {
+ if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
+ $pack->{reqtype} = $self->{reqtype};
+ if (
+ exists $pack->{install}
+ &&
+ (
+ UNIVERSAL::can($pack->{install},"failed") ?
+ $pack->{install}->failed :
+ $pack->{install} =~ /^NO/
+ )
+ ) {
+ delete $pack->{install};
+ $CPAN::Frontend->mywarn
+ ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
+ }
+ }
+ } else {
+ $pack->{reqtype} = $self->{reqtype};
+ }
+
+ my $success = eval {
+ $pack->$meth();
+ };
+ my $err = $@;
+ $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
+ $pack->unnotest if $pack->can("unnotest") && exists $self->{notest};
+ delete $self->{force_update};
+ delete $self->{notest};
+ if ($err) {
+ die $err;
+ }
+ return $success;
+}
+
+#-> sub CPAN::Module::perldoc ;
+sub perldoc { shift->rematein('perldoc') }
+#-> sub CPAN::Module::readme ;
+sub readme { shift->rematein('readme') }
+#-> sub CPAN::Module::look ;
+sub look { shift->rematein('look') }
+#-> sub CPAN::Module::cvs_import ;
+sub cvs_import { shift->rematein('cvs_import') }
+#-> sub CPAN::Module::get ;
+sub get { shift->rematein('get',@_) }
+#-> sub CPAN::Module::make ;
+sub make { shift->rematein('make') }
+#-> sub CPAN::Module::test ;
+sub test {
+ my $self = shift;
+ # $self->{badtestcnt} ||= 0;
+ $self->rematein('test',@_);
+}
+
+#-> sub CPAN::Module::deprecated_in_core ;
+sub deprecated_in_core {
+ my ($self) = @_;
+ return unless $CPAN::META->has_inst('Module::CoreList') && Module::CoreList->can('is_deprecated');
+ return Module::CoreList::is_deprecated($self->{ID});
+}
+
+#-> sub CPAN::Module::inst_deprecated;
+# Indicates whether the *installed* version of the module is a deprecated *and*
+# installed as part of the Perl core library path
+sub inst_deprecated {
+ my ($self) = @_;
+ my $inst_file = $self->inst_file or return;
+ return $self->deprecated_in_core && $self->_in_priv_or_arch($inst_file);
+}
+
+#-> sub CPAN::Module::uptodate ;
+sub uptodate {
+ my ($self) = @_;
+ local ($_);
+ my $inst = $self->inst_version or return 0;
+ my $cpan = $self->cpan_version;
+ return 0 if CPAN::Version->vgt($cpan,$inst) || $self->inst_deprecated;
+ CPAN->debug
+ (join
+ ("",
+ "returning uptodate. ",
+ "cpan[$cpan]inst[$inst]",
+ )) if $CPAN::DEBUG;
+ return 1;
+}
+
+# returns true if installed in privlib or archlib
+sub _in_priv_or_arch {
+ my($self,$inst_file) = @_;
+ foreach my $pair (
+ [qw(sitearchexp archlibexp)],
+ [qw(sitelibexp privlibexp)]
+ ) {
+ my ($site, $priv) = @Config::Config{@$pair};
+ if ($^O eq 'VMS') {
+ for my $d ($site, $priv) { $d = VMS::Filespec::unixify($d) };
+ }
+ s!/*$!!g foreach $site, $priv;
+ next if $site eq $priv;
+
+ if ($priv eq substr($inst_file,0,length($priv))) {
+ return 1;
+ }
+ }
+ return 0;
+}
+
+#-> sub CPAN::Module::install ;
+sub install {
+ my($self) = @_;
+ my($doit) = 0;
+ if ($self->uptodate
+ &&
+ not exists $self->{force_update}
+ ) {
+ $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
+ $self->id,
+ $self->inst_version,
+ ));
+ } else {
+ $doit = 1;
+ }
+ my $ro = $self->ro;
+ if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
+ $CPAN::Frontend->mywarn(qq{
+\n\n\n ***WARNING***
+ The module $self->{ID} has no active maintainer (CPAN support level flag 'abandoned').\n\n\n
+});
+ $CPAN::Frontend->mysleep(5);
+ }
+ return $doit ? $self->rematein('install') : 1;
+}
+#-> sub CPAN::Module::clean ;
+sub clean { shift->rematein('clean') }
+
+#-> sub CPAN::Module::inst_file ;
+sub inst_file {
+ my($self) = @_;
+ $self->_file_in_path([@INC]);
+}
+
+#-> sub CPAN::Module::available_file ;
+sub available_file {
+ my($self) = @_;
+ my $sep = $Config::Config{path_sep};
+ my $perllib = $ENV{PERL5LIB};
+ $perllib = $ENV{PERLLIB} unless defined $perllib;
+ my @perllib = split(/$sep/,$perllib) if defined $perllib;
+ my @cpan_perl5inc;
+ if ($CPAN::Perl5lib_tempfile) {
+ my $yaml = CPAN->_yaml_loadfile($CPAN::Perl5lib_tempfile);
+ @cpan_perl5inc = @{$yaml->[0]{inc} || []};
+ }
+ $self->_file_in_path([@cpan_perl5inc,@perllib,@INC]);
+}
+
+#-> sub CPAN::Module::file_in_path ;
+sub _file_in_path {
+ my($self,$path) = @_;
+ my($dir,@packpath);
+ @packpath = split /::/, $self->{ID};
+ $packpath[-1] .= ".pm";
+ if (@packpath == 1 && $packpath[0] eq "readline.pm") {
+ unshift @packpath, "Term", "ReadLine"; # historical reasons
+ }
+ foreach $dir (@$path) {
+ my $pmfile = File::Spec->catfile($dir,@packpath);
+ if (-f $pmfile) {
+ return $pmfile;
+ }
+ }
+ return;
+}
+
+#-> sub CPAN::Module::xs_file ;
+sub xs_file {
+ my($self) = @_;
+ my($dir,@packpath);
+ @packpath = split /::/, $self->{ID};
+ push @packpath, $packpath[-1];
+ $packpath[-1] .= "." . $Config::Config{'dlext'};
+ foreach $dir (@INC) {
+ my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
+ if (-f $xsfile) {
+ return $xsfile;
+ }
+ }
+ return;
+}
+
+#-> sub CPAN::Module::inst_version ;
+sub inst_version {
+ my($self) = @_;
+ my $parsefile = $self->inst_file or return;
+ my $have = $self->parse_version($parsefile);
+ $have;
+}
+
+#-> sub CPAN::Module::inst_version ;
+sub available_version {
+ my($self) = @_;
+ my $parsefile = $self->available_file or return;
+ my $have = $self->parse_version($parsefile);
+ $have;
+}
+
+#-> sub CPAN::Module::parse_version ;
+sub parse_version {
+ my($self,$parsefile) = @_;
+ if (ALARM_IMPLEMENTED) {
+ my $timeout = (exists($CPAN::Config{'version_timeout'}))
+ ? $CPAN::Config{'version_timeout'}
+ : 15;
+ alarm($timeout);
+ }
+ my $have = eval {
+ local $SIG{ALRM} = sub { die "alarm\n" };
+ MM->parse_version($parsefile);
+ };
+ if ($@) {
+ $CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n");
+ }
+ alarm(0) if ALARM_IMPLEMENTED;
+ my $leastsanity = eval { defined $have && length $have; };
+ $have = "undef" unless $leastsanity;
+ $have =~ s/^ //; # since the %vd hack these two lines here are needed
+ $have =~ s/ $//; # trailing whitespace happens all the time
+
+ $have = CPAN::Version->readable($have);
+
+ $have =~ s/\s*//g; # stringify to float around floating point issues
+ $have; # no stringify needed, \s* above matches always
+}
+
+#-> sub CPAN::Module::reports
+sub reports {
+ my($self) = @_;
+ $self->distribution->reports;
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Nox.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Nox.pm
new file mode 100644
index 0000000000..f7ed4a38af
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Nox.pm
@@ -0,0 +1,52 @@
+package CPAN::Nox;
+use strict;
+use vars qw($VERSION @EXPORT);
+
+BEGIN{
+ $CPAN::Suppress_readline=1 unless defined $CPAN::term;
+}
+
+use Exporter ();
+@CPAN::ISA = ('Exporter');
+use CPAN;
+
+$VERSION = "5.5001";
+$CPAN::META->has_inst('Digest::MD5','no');
+$CPAN::META->has_inst('LWP','no');
+$CPAN::META->has_inst('Compress::Zlib','no');
+@EXPORT = @CPAN::EXPORT;
+
+*AUTOLOAD = \&CPAN::AUTOLOAD;
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::Nox - Wrapper around CPAN.pm without using any XS module
+
+=head1 SYNOPSIS
+
+Interactive mode:
+
+ perl -MCPAN::Nox -e shell;
+
+=head1 DESCRIPTION
+
+This package has the same functionality as CPAN.pm, but tries to
+prevent the usage of compiled extensions during its own
+execution. Its primary purpose is a rescue in case you upgraded perl
+and broke binary compatibility somehow.
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<CPAN>
+
+=cut
+
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Plugin.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Plugin.pm
new file mode 100644
index 0000000000..77ad19b776
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Plugin.pm
@@ -0,0 +1,145 @@
+package CPAN::Plugin;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.96';
+
+require CPAN;
+
+######################################################################
+
+sub new { # ;
+ my ($class, %params) = @_;
+
+ my $self = +{
+ (ref $class ? (%$class) : ()),
+ %params,
+ };
+
+ $self = bless $self, ref $class ? ref $class : $class;
+
+ unless (ref $class) {
+ local $_;
+ no warnings 'once';
+ $CPAN::META->use_inst ($_) for $self->plugin_requires;
+ }
+
+ $self;
+}
+
+######################################################################
+sub plugin_requires { # ;
+}
+
+######################################################################
+sub distribution_object { # ;
+ my ($self) = @_;
+ $self->{distribution_object};
+}
+
+######################################################################
+sub distribution { # ;
+ my ($self) = @_;
+
+ my $distribution = $self->distribution_object->id;
+ CPAN::Shell->expand("Distribution",$distribution)
+ or $self->frontend->mydie("Unknowns distribution '$distribution'\n");
+}
+
+######################################################################
+sub distribution_info { # ;
+ my ($self) = @_;
+
+ CPAN::DistnameInfo->new ($self->distribution->id);
+}
+
+######################################################################
+sub build_dir { # ;
+ my ($self) = @_;
+
+ my $build_dir = $self->distribution->{build_dir}
+ or $self->frontend->mydie("Distribution has not been built yet, cannot proceed");
+}
+
+######################################################################
+sub is_xs { #
+ my ($self) = @_;
+
+ my @xs = glob File::Spec->catfile ($self->build_dir, '*.xs'); # quick try
+
+ unless (@xs) {
+ require ExtUtils::Manifest;
+ my $manifest_file = File::Spec->catfile ($self->build_dir, "MANIFEST");
+ my $manifest = ExtUtils::Manifest::maniread($manifest_file);
+ @xs = grep /\.xs$/, keys %$manifest;
+ }
+
+ scalar @xs;
+}
+
+######################################################################
+
+package CPAN::Plugin;
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+CPAN::Plugin - Base class for CPAN shell extensions
+
+=head1 SYNOPSIS
+
+ package CPAN::Plugin::Flurb;
+ use parent 'CPAN::Plugin';
+
+ sub post_test {
+ my ($self, $distribution_object) = @_;
+ $self = $self->new (distribution_object => $distribution_object);
+ ...;
+ }
+
+=head1 DESCRIPTION
+
+=head2 Alpha Status
+
+The plugin system in the CPAN shell was introduced in version 2.07 and
+is still considered experimental.
+
+=head2 How Plugins work?
+
+See L<CPAN/"Plugin support">.
+
+=head1 METHODS
+
+=head2 plugin_requires
+
+returns list of packages given plugin requires for functionality.
+This list is evaluated using C<CPAN->use_inst> method.
+
+=head2 distribution_object
+
+Get current distribution object.
+
+=head2 distribution
+
+=head2 distribution_info
+
+=head2 build_dir
+
+Simple delegatees for misc parameters derived from distribution
+
+=head2 is_xs
+
+Predicate to detect whether package contains XS.
+
+=head1 AUTHOR
+
+Branislav Zahradnik <barney@cpan.org>
+
+=cut
+
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Plugin/Specfile.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Plugin/Specfile.pm
new file mode 100644
index 0000000000..f63d322c74
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Plugin/Specfile.pm
@@ -0,0 +1,258 @@
+=head1 NAME
+
+CPAN::Plugin::Specfile - Proof of concept implementation of a trivial CPAN::Plugin
+
+=head1 SYNOPSIS
+
+ # once in the cpan shell
+ o conf plugin_list push CPAN::Plugin::Specfile
+
+ # make permanent
+ o conf commit
+
+ # any time in the cpan shell to write a spec file
+ test Acme::Meta
+
+ # disable
+ o conf plugin_list pop
+
+=head1 DESCRIPTION
+
+Implemented as a post-test hook, this plugin writes a specfile after
+every successful test run. The content is also written to the
+terminal.
+
+As a side effect, the timestamps of the written specfiles reflect the
+linear order of all dependencies.
+
+B<WARNING:> This code is just a small demo how to use the plugin
+system of the CPAN shell, not a full fledged spec file writer. Do not
+expect new features in this plugin.
+
+=head2 OPTIONS
+
+The target directory to store the spec files in can be set using C<dir>
+as in
+
+ o conf plugin_list push CPAN::Plugin::Specfile=dir,/tmp/specfiles-000042
+
+The default directory for this is the
+C<plugins/CPAN::Plugin::Specfile> directory in the I<cpan_home>
+directory.
+
+=head1 AUTHOR
+
+Andreas Koenig <andk@cpan.org>, Branislav Zahradnik <barney@cpan.org>
+
+=cut
+
+package CPAN::Plugin::Specfile;
+
+our $VERSION = '0.01';
+
+use File::Path;
+use File::Spec;
+
+sub __accessor {
+ my ($class, $key) = @_;
+ no strict 'refs';
+ *{$class . '::' . $key} = sub {
+ my $self = shift;
+ if (@_) {
+ $self->{$key} = shift;
+ }
+ return $self->{$key};
+ };
+}
+BEGIN { __PACKAGE__->__accessor($_) for qw(dir dir_default) }
+
+sub new {
+ my($class, @rest) = @_;
+ my $self = bless {}, $class;
+ while (my($arg,$val) = splice @rest, 0, 2) {
+ $self->$arg($val);
+ }
+ $self->dir_default(File::Spec->catdir($CPAN::Config->{cpan_home},"plugins",__PACKAGE__));
+ $self;
+}
+
+sub post_test {
+ my $self = shift;
+ my $distribution_object = shift;
+ my $distribution = $distribution_object->pretty_id;
+ unless ($CPAN::META->has_inst("CPAN::DistnameInfo")){
+ $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
+ }
+ my $d = CPAN::Shell->expand("Distribution",$distribution)
+ or $CPAN::Frontend->mydie("Unknowns distribution '$distribution'\n");
+ my $build_dir = $d->{build_dir} or $CPAN::Frontend->mydie("Distribution has not been built yet, cannot proceed");
+ my %contains = map {($_ => undef)} $d->containsmods;
+ my @m;
+ my $width = 16;
+ my $header = sub {
+ my($header,$value) = @_;
+ push @m, sprintf("%-s:%*s%s\n", $header, $width-length($header), "", $value);
+ };
+ my $dni = CPAN::DistnameInfo->new($distribution);
+ my $dist = $dni->dist;
+ my $summary = CPAN::Shell->_guess_manpage($d,\%contains,$dist);
+ $header->("Name", "perl-$dist");
+ my $version = $dni->version;
+ $header->("Version", $version);
+ $header->("Release", "1%{?dist}");
+#Summary: Template processing system
+#Group: Development/Libraries
+#License: GPL+ or Artistic
+#URL: http://www.template-toolkit.org/
+#Source0: http://search.cpan.org/CPAN/authors/id/A/AB/ABW/Template-Toolkit-%{version}.tar.gz
+#Patch0: Template-2.22-SREZIC-01.patch
+#BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n)
+ for my $h_tuple
+ ([Summary => $summary],
+ [Group => "Development/Libraries"],
+ [License =>],
+ [URL =>],
+ [BuildRoot => "%{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n)"],
+ [Requires => "perl(:MODULE_COMPAT_%(eval \"`%{__perl} -V:version`\"; echo \$version))"],
+ ) {
+ my($h,$v) = @$h_tuple;
+ $v = "unknown" unless defined $v;
+ $header->($h, $v);
+ }
+ $header->("Source0", sprintf(
+ "http://search.cpan.org/CPAN/authors/id/%s/%s/%s",
+ substr($distribution,0,1),
+ substr($distribution,0,2),
+ $distribution
+ ));
+ require POSIX;
+ my @xs = glob "$build_dir/*.xs"; # quick try
+ unless (@xs) {
+ require ExtUtils::Manifest;
+ my $manifest_file = "$build_dir/MANIFEST";
+ my $manifest = ExtUtils::Manifest::maniread($manifest_file);
+ @xs = grep /\.xs$/, keys %$manifest;
+ }
+ if (! @xs) {
+ $header->('BuildArch', 'noarch');
+ }
+ for my $k (sort keys %contains) {
+ my $m = CPAN::Shell->expand("Module",$k);
+ my $v = $contains{$k} = $m->cpan_version;
+ my $vspec = $v eq "undef" ? "" : " = $v";
+ $header->("Provides", "perl($k)$vspec");
+ }
+ if (my $prereq_pm = $d->{prereq_pm}) {
+ my %req;
+ for my $reqkey (keys %$prereq_pm) {
+ while (my($k,$v) = each %{$prereq_pm->{$reqkey}}) {
+ $req{$k} = $v;
+ }
+ }
+ if (-e "$build_dir/Build.PL" && ! exists $req{"Module::Build"}) {
+ $req{"Module::Build"} = 0;
+ }
+ for my $k (sort keys %req) {
+ next if $k eq "perl";
+ my $v = $req{$k};
+ my $vspec = defined $v && length $v && $v > 0 ? " >= $v" : "";
+ $header->(BuildRequires => "perl($k)$vspec");
+ next if $k =~ /^(Module::Build)$/; # MB is always only a
+ # BuildRequires; if we
+ # turn it into a
+ # Requires, then we
+ # would have to make it
+ # a BuildRequires
+ # everywhere we depend
+ # on *one* MB built
+ # module.
+ $header->(Requires => "perl($k)$vspec");
+ }
+ }
+ push @m, "\n%define _use_internal_dependency_generator 0
+%define __find_requires %{nil}
+%define __find_provides %{nil}
+";
+ push @m, "\n%description\n%{summary}.\n";
+ push @m, "\n%prep\n%setup -q -n $dist-%{version}\n";
+ if (-e "$build_dir/Build.PL") {
+ # see http://www.redhat.com/archives/rpm-list/2002-July/msg00110.html about RPM_BUILD_ROOT vs %{buildroot}
+ push @m, <<'EOF';
+
+%build
+%{__perl} Build.PL --installdirs=vendor --libdoc installvendorman3dir
+./Build
+
+%install
+rm -rf $RPM_BUILD_ROOT
+./Build install destdir=$RPM_BUILD_ROOT create_packlist=0
+find $RPM_BUILD_ROOT -depth -type d -exec rmdir {} 2>/dev/null \;
+%{_fixperms} $RPM_BUILD_ROOT/*
+
+%check
+./Build test
+EOF
+ } elsif (-e "$build_dir/Makefile.PL") {
+ push @m, <<'EOF';
+
+%build
+%{__perl} Makefile.PL INSTALLDIRS=vendor
+make %{?_smp_mflags}
+
+%install
+rm -rf $RPM_BUILD_ROOT
+make pure_install DESTDIR=$RPM_BUILD_ROOT
+find $RPM_BUILD_ROOT -type f -name .packlist -exec rm -f {} ';'
+find $RPM_BUILD_ROOT -depth -type d -exec rmdir {} 2>/dev/null ';'
+%{_fixperms} $RPM_BUILD_ROOT/*
+
+%check
+make test
+EOF
+ } else {
+ $CPAN::Frontend->mydie("'$distribution' has neither a Build.PL nor a Makefile.PL\n");
+ }
+ push @m, "\n%clean\nrm -rf \$RPM_BUILD_ROOT\n";
+ my $vendorlib = @xs ? "vendorarch" : "vendorlib";
+ my $date = POSIX::strftime("%a %b %d %Y", gmtime);
+ my @doc = grep { -e "$build_dir/$_" } qw(README Changes);
+ my $exe_stanza = "\n";
+ if (my $exe_files = $d->_exe_files) {
+ if (@$exe_files) {
+ $exe_stanza = "%{_mandir}/man1/*.1*\n";
+ for my $e (@$exe_files) {
+ unless (CPAN->has_inst("File::Basename")) {
+ $CPAN::Frontend->mydie("File::Basename not installed, cannot continue");
+ }
+ my $basename = File::Basename::basename($e);
+ $exe_stanza .= "/usr/bin/$basename\n";
+ }
+ }
+ }
+ push @m, <<EOF;
+
+%files
+%defattr(-,root,root,-)
+%doc @doc
+%{perl_$vendorlib}/*
+%{_mandir}/man3/*.3*
+$exe_stanza
+%changelog
+* $date <specfile\@specfile.cpan.org> - $version-1
+- autogenerated by CPAN::Plugin::Specfile()
+
+EOF
+
+ my $ret = join "", @m;
+ $CPAN::Frontend->myprint($ret);
+ my $target_dir = $self->dir || $self->dir_default;
+ File::Path::mkpath($target_dir);
+ my $outfile = File::Spec->catfile($target_dir, "perl-$dist.spec");
+ open my $specout, ">", $outfile
+ or $CPAN::Frontend->mydie("Could not open >$outfile: $!");
+ print $specout $ret;
+ $CPAN::Frontend->myprint("Wrote $outfile");
+ $ret;
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Prompt.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Prompt.pm
new file mode 100644
index 0000000000..7a4e2d81e1
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Prompt.pm
@@ -0,0 +1,29 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::Prompt;
+use overload '""' => "as_string";
+use vars qw($prompt);
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5";
+
+
+$prompt = "cpan> ";
+$CPAN::CurrentCommandId ||= 0;
+sub new {
+ bless {}, shift;
+}
+sub as_string {
+ my $word = "cpan";
+ unless ($CPAN::META->{LOCK}) {
+ $word = "nolock_cpan";
+ }
+ if ($CPAN::Config->{commandnumber_in_prompt}) {
+ sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
+ } else {
+ "$word> ";
+ }
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Queue.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Queue.pm
new file mode 100644
index 0000000000..8027d22d3b
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Queue.pm
@@ -0,0 +1,223 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+use strict;
+package CPAN::Queue::Item;
+
+# CPAN::Queue::Item::new ;
+sub new {
+ my($class,@attr) = @_;
+ my $self = bless { @attr }, $class;
+ return $self;
+}
+
+sub as_string {
+ my($self) = @_;
+ $self->{qmod};
+}
+
+# r => requires, b => build_requires, c => commandline
+sub reqtype {
+ my($self) = @_;
+ $self->{reqtype};
+}
+
+sub optional {
+ my($self) = @_;
+ $self->{optional};
+}
+
+package CPAN::Queue;
+
+# One use of the queue is to determine if we should or shouldn't
+# announce the availability of a new CPAN module
+
+# Now we try to use it for dependency tracking. For that to happen
+# we need to draw a dependency tree and do the leaves first. This can
+# easily be reached by running CPAN.pm recursively, but we don't want
+# to waste memory and run into deep recursion. So what we can do is
+# this:
+
+# CPAN::Queue is the package where the queue is maintained. Dependencies
+# often have high priority and must be brought to the head of the queue,
+# possibly by jumping the queue if they are already there. My first code
+# attempt tried to be extremely correct. Whenever a module needed
+# immediate treatment, I either unshifted it to the front of the queue,
+# or, if it was already in the queue, I spliced and let it bypass the
+# others. This became a too correct model that made it impossible to put
+# an item more than once into the queue. Why would you need that? Well,
+# you need temporary duplicates as the manager of the queue is a loop
+# that
+#
+# (1) looks at the first item in the queue without shifting it off
+#
+# (2) cares for the item
+#
+# (3) removes the item from the queue, *even if its agenda failed and
+# even if the item isn't the first in the queue anymore* (that way
+# protecting against never ending queues)
+#
+# So if an item has prerequisites, the installation fails now, but we
+# want to retry later. That's easy if we have it twice in the queue.
+#
+# I also expect insane dependency situations where an item gets more
+# than two lives in the queue. Simplest example is triggered by 'install
+# Foo Foo Foo'. People make this kind of mistakes and I don't want to
+# get in the way. I wanted the queue manager to be a dumb servant, not
+# one that knows everything.
+#
+# Who would I tell in this model that the user wants to be asked before
+# processing? I can't attach that information to the module object,
+# because not modules are installed but distributions. So I'd have to
+# tell the distribution object that it should ask the user before
+# processing. Where would the question be triggered then? Most probably
+# in CPAN::Distribution::rematein.
+
+use vars qw{ @All $VERSION };
+$VERSION = "5.5002";
+
+# CPAN::Queue::queue_item ;
+sub queue_item {
+ my($class,@attr) = @_;
+ my $item = "$class\::Item"->new(@attr);
+ $class->qpush($item);
+ return 1;
+}
+
+# CPAN::Queue::qpush ;
+sub qpush {
+ my($class,$obj) = @_;
+ push @All, $obj;
+ CPAN->debug(sprintf("in new All[%s]",
+ join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All),
+ )) if $CPAN::DEBUG;
+}
+
+# CPAN::Queue::first ;
+sub first {
+ my $obj = $All[0];
+ $obj;
+}
+
+# CPAN::Queue::delete_first ;
+sub delete_first {
+ my($class,$what) = @_;
+ my $i;
+ for my $i (0..$#All) {
+ if ( $All[$i]->{qmod} eq $what ) {
+ splice @All, $i, 1;
+ last;
+ }
+ }
+ CPAN->debug(sprintf("after delete_first mod[%s] All[%s]",
+ $what,
+ join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All)
+ )) if $CPAN::DEBUG;
+}
+
+# CPAN::Queue::jumpqueue ;
+sub jumpqueue {
+ my $class = shift;
+ my @what = @_;
+ CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
+ join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All),
+ join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @what),
+ )) if $CPAN::DEBUG;
+ unless (defined $what[0]{reqtype}) {
+ # apparently it was not the Shell that sent us this enquiry,
+ # treat it as commandline
+ $what[0]{reqtype} = "c";
+ }
+ my $inherit_reqtype = $what[0]{reqtype} =~ /^(c|r)$/ ? "r" : "b";
+ WHAT: for my $what_tuple (@what) {
+ my($qmod,$reqtype,$optional) = @$what_tuple{qw(qmod reqtype optional)};
+ if ($reqtype eq "r"
+ &&
+ $inherit_reqtype eq "b"
+ ) {
+ $reqtype = "b";
+ }
+ my $jumped = 0;
+ for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
+ if ($All[$i]{qmod} eq $qmod) {
+ $jumped++;
+ }
+ }
+ # high jumped values are normal for popular modules when
+ # dealing with large bundles: XML::Simple,
+ # namespace::autoclean, UNIVERSAL::require
+ CPAN->debug("qmod[$qmod]jumped[$jumped]") if $CPAN::DEBUG;
+ my $obj = "$class\::Item"->new(
+ qmod => $qmod,
+ reqtype => $reqtype,
+ optional => !! $optional,
+ );
+ unshift @All, $obj;
+ }
+ CPAN->debug(sprintf("after jumpqueue All[%s]",
+ join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All)
+ )) if $CPAN::DEBUG;
+}
+
+# CPAN::Queue::exists ;
+sub exists {
+ my($self,$what) = @_;
+ my @all = map { $_->{qmod} } @All;
+ my $exists = grep { $_->{qmod} eq $what } @All;
+ # warn "in exists what[$what] all[@all] exists[$exists]";
+ $exists;
+}
+
+# CPAN::Queue::delete ;
+sub delete {
+ my($self,$mod) = @_;
+ @All = grep { $_->{qmod} ne $mod } @All;
+ CPAN->debug(sprintf("after delete mod[%s] All[%s]",
+ $mod,
+ join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All)
+ )) if $CPAN::DEBUG;
+}
+
+# CPAN::Queue::nullify_queue ;
+sub nullify_queue {
+ @All = ();
+}
+
+# CPAN::Queue::size ;
+sub size {
+ return scalar @All;
+}
+
+sub reqtype_of {
+ my($self,$mod) = @_;
+ my $best = "";
+ for my $item (grep { $_->{qmod} eq $mod } @All) {
+ my $c = $item->{reqtype};
+ if ($c eq "c") {
+ $best = $c;
+ last;
+ } elsif ($c eq "r") {
+ $best = $c;
+ } elsif ($c eq "b") {
+ if ($best eq "") {
+ $best = $c;
+ }
+ } else {
+ die "Panic: in reqtype_of: reqtype[$c] seen, should never happen";
+ }
+ }
+ return $best;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::Queue - internal queue support for CPAN.pm
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Shell.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Shell.pm
new file mode 100644
index 0000000000..423131cc2f
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Shell.pm
@@ -0,0 +1,2071 @@
+package CPAN::Shell;
+use strict;
+
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+
+use vars qw(
+ $ADVANCED_QUERY
+ $AUTOLOAD
+ $COLOR_REGISTERED
+ $Help
+ $autoload_recursion
+ $reload
+ @ISA
+ @relo
+ $VERSION
+ );
+@relo = (
+ "CPAN.pm",
+ "CPAN/Author.pm",
+ "CPAN/CacheMgr.pm",
+ "CPAN/Complete.pm",
+ "CPAN/Debug.pm",
+ "CPAN/DeferredCode.pm",
+ "CPAN/Distribution.pm",
+ "CPAN/Distroprefs.pm",
+ "CPAN/Distrostatus.pm",
+ "CPAN/Exception/RecursiveDependency.pm",
+ "CPAN/Exception/yaml_not_installed.pm",
+ "CPAN/FirstTime.pm",
+ "CPAN/FTP.pm",
+ "CPAN/FTP/netrc.pm",
+ "CPAN/HandleConfig.pm",
+ "CPAN/Index.pm",
+ "CPAN/InfoObj.pm",
+ "CPAN/Kwalify.pm",
+ "CPAN/LWP/UserAgent.pm",
+ "CPAN/Module.pm",
+ "CPAN/Prompt.pm",
+ "CPAN/Queue.pm",
+ "CPAN/Reporter/Config.pm",
+ "CPAN/Reporter/History.pm",
+ "CPAN/Reporter/PrereqCheck.pm",
+ "CPAN/Reporter.pm",
+ "CPAN/Shell.pm",
+ "CPAN/SQLite.pm",
+ "CPAN/Tarzip.pm",
+ "CPAN/Version.pm",
+ );
+$VERSION = "5.5007";
+# record the initial timestamp for reload.
+$reload = { map {$INC{$_} ? ($_,(stat $INC{$_})[9]) : ()} @relo };
+@CPAN::Shell::ISA = qw(CPAN::Debug);
+use Cwd qw(chdir);
+use Carp ();
+$COLOR_REGISTERED ||= 0;
+$Help = {
+ '?' => \"help",
+ '!' => "eval the rest of the line as perl",
+ a => "whois author",
+ autobundle => "write inventory into a bundle file",
+ b => "info about bundle",
+ bye => \"quit",
+ clean => "clean up a distribution's build directory",
+ # cvs_import
+ d => "info about a distribution",
+ # dump
+ exit => \"quit",
+ failed => "list all failed actions within current session",
+ fforce => "redo a command from scratch",
+ force => "redo a command",
+ get => "download a distribution",
+ h => \"help",
+ help => "overview over commands; 'help ...' explains specific commands",
+ hosts => "statistics about recently used hosts",
+ i => "info about authors/bundles/distributions/modules",
+ install => "install a distribution",
+ install_tested => "install all distributions tested OK",
+ is_tested => "list all distributions tested OK",
+ look => "open a subshell in a distribution's directory",
+ ls => "list distributions matching a fileglob",
+ m => "info about a module",
+ make => "make/build a distribution",
+ mkmyconfig => "write current config into a CPAN/MyConfig.pm file",
+ notest => "run a (usually install) command but leave out the test phase",
+ o => "'o conf ...' for config stuff; 'o debug ...' for debugging",
+ perldoc => "try to get a manpage for a module",
+ q => \"quit",
+ quit => "leave the cpan shell",
+ r => "review upgradable modules",
+ readme => "display the README of a distro with a pager",
+ recent => "show recent uploads to the CPAN",
+ # recompile
+ reload => "'reload cpan' or 'reload index'",
+ report => "test a distribution and send a test report to cpantesters",
+ reports => "info about reported tests from cpantesters",
+ # scripts
+ # smoke
+ test => "test a distribution",
+ u => "display uninstalled modules",
+ upgrade => "combine 'r' command with immediate installation",
+ };
+{
+ $autoload_recursion ||= 0;
+
+ #-> sub CPAN::Shell::AUTOLOAD ;
+ sub AUTOLOAD { ## no critic
+ $autoload_recursion++;
+ my($l) = $AUTOLOAD;
+ my $class = shift(@_);
+ # warn "autoload[$l] class[$class]";
+ $l =~ s/.*:://;
+ if ($CPAN::Signal) {
+ warn "Refusing to autoload '$l' while signal pending";
+ $autoload_recursion--;
+ return;
+ }
+ if ($autoload_recursion > 1) {
+ my $fullcommand = join " ", map { "'$_'" } $l, @_;
+ warn "Refusing to autoload $fullcommand in recursion\n";
+ $autoload_recursion--;
+ return;
+ }
+ if ($l =~ /^w/) {
+ # XXX needs to be reconsidered
+ if ($CPAN::META->has_inst('CPAN::WAIT')) {
+ CPAN::WAIT->$l(@_);
+ } else {
+ $CPAN::Frontend->mywarn(qq{
+Commands starting with "w" require CPAN::WAIT to be installed.
+Please consider installing CPAN::WAIT to use the fulltext index.
+For this you just need to type
+ install CPAN::WAIT
+});
+ }
+ } else {
+ $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
+ qq{Type ? for help.
+});
+ }
+ $autoload_recursion--;
+ }
+}
+
+
+#-> sub CPAN::Shell::h ;
+sub h {
+ my($class,$about) = @_;
+ if (defined $about) {
+ my $help;
+ if (exists $Help->{$about}) {
+ if (ref $Help->{$about}) { # aliases
+ $about = ${$Help->{$about}};
+ }
+ $help = $Help->{$about};
+ } else {
+ $help = "No help available";
+ }
+ $CPAN::Frontend->myprint("$about\: $help\n");
+ } else {
+ my $filler = " " x (80 - 28 - length($CPAN::VERSION));
+ $CPAN::Frontend->myprint(qq{
+Display Information $filler (ver $CPAN::VERSION)
+ command argument description
+ a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
+ i WORD or /REGEXP/ about any of the above
+ ls AUTHOR or GLOB about files in the author's directory
+ (with WORD being a module, bundle or author name or a distribution
+ name of the form AUTHOR/DISTRIBUTION)
+
+Download, Test, Make, Install...
+ get download clean make clean
+ make make (implies get) look open subshell in dist directory
+ test make test (implies make) readme display these README files
+ install make install (implies test) perldoc display POD documentation
+
+Upgrade installed modules
+ r WORDs or /REGEXP/ or NONE report updates for some/matching/all
+ upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules
+
+Pragmas
+ force CMD try hard to do command fforce CMD try harder
+ notest CMD skip testing
+
+Other
+ h,? display this menu ! perl-code eval a perl command
+ o conf [opt] set and query options q quit the cpan shell
+ reload cpan load CPAN.pm again reload index load newer indices
+ autobundle Snapshot recent latest CPAN uploads});
+}
+}
+
+*help = \&h;
+
+#-> sub CPAN::Shell::a ;
+sub a {
+ my($self,@arg) = @_;
+ # authors are always UPPERCASE
+ for (@arg) {
+ $_ = uc $_ unless /=/;
+ }
+ $CPAN::Frontend->myprint($self->format_result('Author',@arg));
+}
+
+#-> sub CPAN::Shell::globls ;
+sub globls {
+ my($self,$s,$pragmas) = @_;
+ # ls is really very different, but we had it once as an ordinary
+ # command in the Shell (up to rev. 321) and we could not handle
+ # force well then
+ my(@accept,@preexpand);
+ if ($s =~ /[\*\?\/]/) {
+ if ($CPAN::META->has_inst("Text::Glob")) {
+ if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
+ my $rau = Text::Glob::glob_to_regex(uc $au);
+ CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
+ if $CPAN::DEBUG;
+ push @preexpand, map { $_->id . "/" . $pathglob }
+ CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
+ } else {
+ my $rau = Text::Glob::glob_to_regex(uc $s);
+ push @preexpand, map { $_->id }
+ CPAN::Shell->expand_by_method('CPAN::Author',
+ ['id'],
+ "/$rau/");
+ }
+ } else {
+ $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
+ }
+ } else {
+ push @preexpand, uc $s;
+ }
+ for (@preexpand) {
+ unless (/^[A-Z0-9\-]+(\/|$)/i) {
+ $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
+ next;
+ }
+ push @accept, $_;
+ }
+ my $silent = @accept>1;
+ my $last_alpha = "";
+ my @results;
+ for my $a (@accept) {
+ my($author,$pathglob);
+ if ($a =~ m|(.*?)/(.*)|) {
+ my $a2 = $1;
+ $pathglob = $2;
+ $author = CPAN::Shell->expand_by_method('CPAN::Author',
+ ['id'],
+ $a2)
+ or $CPAN::Frontend->mydie("No author found for $a2\n");
+ } else {
+ $author = CPAN::Shell->expand_by_method('CPAN::Author',
+ ['id'],
+ $a)
+ or $CPAN::Frontend->mydie("No author found for $a\n");
+ }
+ if ($silent) {
+ my $alpha = substr $author->id, 0, 1;
+ my $ad;
+ if ($alpha eq $last_alpha) {
+ $ad = "";
+ } else {
+ $ad = "[$alpha]";
+ $last_alpha = $alpha;
+ }
+ $CPAN::Frontend->myprint($ad);
+ }
+ for my $pragma (@$pragmas) {
+ if ($author->can($pragma)) {
+ $author->$pragma();
+ }
+ }
+ CPAN->debug("author[$author]pathglob[$pathglob]silent[$silent]") if $CPAN::DEBUG;
+ push @results, $author->ls($pathglob,$silent); # silent if
+ # more than one
+ # author
+ for my $pragma (@$pragmas) {
+ my $unpragma = "un$pragma";
+ if ($author->can($unpragma)) {
+ $author->$unpragma();
+ }
+ }
+ }
+ @results;
+}
+
+#-> sub CPAN::Shell::local_bundles ;
+sub local_bundles {
+ my($self,@which) = @_;
+ my($incdir,$bdir,$dh);
+ foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
+ my @bbase = "Bundle";
+ while (my $bbase = shift @bbase) {
+ $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
+ CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
+ if ($dh = DirHandle->new($bdir)) { # may fail
+ my($entry);
+ for $entry ($dh->read) {
+ next if $entry =~ /^\./;
+ next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
+ if (-d File::Spec->catdir($bdir,$entry)) {
+ push @bbase, "$bbase\::$entry";
+ } else {
+ next unless $entry =~ s/\.pm(?!\n)\Z//;
+ $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
+ }
+ }
+ }
+ }
+ }
+}
+
+#-> sub CPAN::Shell::b ;
+sub b {
+ my($self,@which) = @_;
+ CPAN->debug("which[@which]") if $CPAN::DEBUG;
+ $self->local_bundles;
+ $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
+}
+
+#-> sub CPAN::Shell::d ;
+sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
+
+#-> sub CPAN::Shell::m ;
+sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
+ my $self = shift;
+ my @m = @_;
+ for (@m) {
+ if (m|(?:\w+/)*\w+\.pm$|) { # same regexp in expandany
+ s/.pm$//;
+ s|/|::|g;
+ }
+ }
+ $CPAN::Frontend->myprint($self->format_result('Module',@m));
+}
+
+#-> sub CPAN::Shell::i ;
+sub i {
+ my($self) = shift;
+ my(@args) = @_;
+ @args = '/./' unless @args;
+ my(@result);
+ for my $type (qw/Bundle Distribution Module/) {
+ push @result, $self->expand($type,@args);
+ }
+ # Authors are always uppercase.
+ push @result, $self->expand("Author", map { uc $_ } @args);
+
+ my $result = @result == 1 ?
+ $result[0]->as_string :
+ @result == 0 ?
+ "No objects found of any type for argument @args\n" :
+ join("",
+ (map {$_->as_glimpse} @result),
+ scalar @result, " items found\n",
+ );
+ $CPAN::Frontend->myprint($result);
+}
+
+#-> sub CPAN::Shell::o ;
+
+# CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
+# conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
+# probably have been called 'set' and 'o debug' maybe 'set debug' or
+# 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
+sub o {
+ my($self,$o_type,@o_what) = @_;
+ $o_type ||= "";
+ CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
+ if ($o_type eq 'conf') {
+ my($cfilter);
+ ($cfilter) = $o_what[0] =~ m|^/(.*)/$| if @o_what;
+ if (!@o_what or $cfilter) { # print all things, "o conf"
+ $cfilter ||= "";
+ my $qrfilter = eval 'qr/$cfilter/';
+ if ($@) {
+ $CPAN::Frontend->mydie("Cannot parse commandline: $@");
+ }
+ my($k,$v);
+ my $configpm = CPAN::HandleConfig->require_myconfig_or_config;
+ $CPAN::Frontend->myprint("\$CPAN::Config options from $configpm\:\n");
+ for $k (sort keys %CPAN::HandleConfig::can) {
+ next unless $k =~ /$qrfilter/;
+ $v = $CPAN::HandleConfig::can{$k};
+ $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
+ }
+ $CPAN::Frontend->myprint("\n");
+ for $k (sort keys %CPAN::HandleConfig::keys) {
+ next unless $k =~ /$qrfilter/;
+ CPAN::HandleConfig->prettyprint($k);
+ }
+ $CPAN::Frontend->myprint("\n");
+ } else {
+ if (CPAN::HandleConfig->edit(@o_what)) {
+ } else {
+ $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
+ qq{items\n\n});
+ }
+ }
+ } elsif ($o_type eq 'debug') {
+ my(%valid);
+ @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
+ if (@o_what) {
+ while (@o_what) {
+ my($what) = shift @o_what;
+ if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
+ $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
+ next;
+ }
+ if ( exists $CPAN::DEBUG{$what} ) {
+ $CPAN::DEBUG |= $CPAN::DEBUG{$what};
+ } elsif ($what =~ /^\d/) {
+ $CPAN::DEBUG = $what;
+ } elsif (lc $what eq 'all') {
+ my($max) = 0;
+ for (values %CPAN::DEBUG) {
+ $max += $_;
+ }
+ $CPAN::DEBUG = $max;
+ } else {
+ my($known) = 0;
+ for (keys %CPAN::DEBUG) {
+ next unless lc($_) eq lc($what);
+ $CPAN::DEBUG |= $CPAN::DEBUG{$_};
+ $known = 1;
+ }
+ $CPAN::Frontend->myprint("unknown argument [$what]\n")
+ unless $known;
+ }
+ }
+ } else {
+ my $raw = "Valid options for debug are ".
+ join(", ",sort(keys %CPAN::DEBUG), 'all').
+ qq{ or a number. Completion works on the options. }.
+ qq{Case is ignored.};
+ require Text::Wrap;
+ $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
+ $CPAN::Frontend->myprint("\n\n");
+ }
+ if ($CPAN::DEBUG) {
+ $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
+ my($k,$v);
+ for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
+ $v = $CPAN::DEBUG{$k};
+ $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
+ if $v & $CPAN::DEBUG;
+ }
+ } else {
+ $CPAN::Frontend->myprint("Debugging turned off completely.\n");
+ }
+ } else {
+ $CPAN::Frontend->myprint(qq{
+Known options:
+ conf set or get configuration variables
+ debug set or get debugging options
+});
+ }
+}
+
+# CPAN::Shell::paintdots_onreload
+sub paintdots_onreload {
+ my($ref) = shift;
+ sub {
+ if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
+ my($subr) = $1;
+ ++$$ref;
+ local($|) = 1;
+ # $CPAN::Frontend->myprint(".($subr)");
+ $CPAN::Frontend->myprint(".");
+ if ($subr =~ /\bshell\b/i) {
+ # warn "debug[$_[0]]";
+
+ # It would be nice if we could detect that a
+ # subroutine has actually changed, but for now we
+ # practically always set the GOTOSHELL global
+
+ $CPAN::GOTOSHELL=1;
+ }
+ return;
+ }
+ warn @_;
+ };
+}
+
+#-> sub CPAN::Shell::hosts ;
+sub hosts {
+ my($self) = @_;
+ my $fullstats = CPAN::FTP->_ftp_statistics();
+ my $history = $fullstats->{history} || [];
+ my %S; # statistics
+ while (my $last = pop @$history) {
+ my $attempts = $last->{attempts} or next;
+ my $start;
+ if (@$attempts) {
+ $start = $attempts->[-1]{start};
+ if ($#$attempts > 0) {
+ for my $i (0..$#$attempts-1) {
+ my $url = $attempts->[$i]{url} or next;
+ $S{no}{$url}++;
+ }
+ }
+ } else {
+ $start = $last->{start};
+ }
+ next unless $last->{thesiteurl}; # C-C? bad filenames?
+ $S{start} = $start;
+ $S{end} ||= $last->{end};
+ my $dltime = $last->{end} - $start;
+ my $dlsize = $last->{filesize} || 0;
+ my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
+ my $s = $S{ok}{$url} ||= {};
+ $s->{n}++;
+ $s->{dlsize} ||= 0;
+ $s->{dlsize} += $dlsize/1024;
+ $s->{dltime} ||= 0;
+ $s->{dltime} += $dltime;
+ }
+ my $res;
+ for my $url (sort keys %{$S{ok}}) {
+ next if $S{ok}{$url}{dltime} == 0; # div by zero
+ push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
+ $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
+ $url,
+ ];
+ }
+ for my $url (sort keys %{$S{no}}) {
+ push @{$res->{no}}, [$S{no}{$url},
+ $url,
+ ];
+ }
+ my $R = ""; # report
+ if ($S{start} && $S{end}) {
+ $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
+ $R .= sprintf "Log ends : %s\n", $S{end} ? scalar(localtime $S{end}) : "unknown";
+ }
+ if ($res->{ok} && @{$res->{ok}}) {
+ $R .= sprintf "\nSuccessful downloads:
+ N kB secs kB/s url\n";
+ my $i = 20;
+ for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
+ $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
+ last if --$i<=0;
+ }
+ }
+ if ($res->{no} && @{$res->{no}}) {
+ $R .= sprintf "\nUnsuccessful downloads:\n";
+ my $i = 20;
+ for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
+ $R .= sprintf "%4d %s\n", @$_;
+ last if --$i<=0;
+ }
+ }
+ $CPAN::Frontend->myprint($R);
+}
+
+# here is where 'reload cpan' is done
+#-> sub CPAN::Shell::reload ;
+sub reload {
+ my($self,$command,@arg) = @_;
+ $command ||= "";
+ $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
+ if ($command =~ /^cpan$/i) {
+ my $redef = 0;
+ chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
+ my $failed;
+ MFILE: for my $f (@relo) {
+ next unless exists $INC{$f};
+ my $p = $f;
+ $p =~ s/\.pm$//;
+ $p =~ s|/|::|g;
+ $CPAN::Frontend->myprint("($p");
+ local($SIG{__WARN__}) = paintdots_onreload(\$redef);
+ $self->_reload_this($f) or $failed++;
+ my $v = eval "$p\::->VERSION";
+ $CPAN::Frontend->myprint("v$v)");
+ }
+ $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
+ if ($failed) {
+ my $errors = $failed == 1 ? "error" : "errors";
+ $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
+ "this session.\n");
+ }
+ } elsif ($command =~ /^index$/i) {
+ CPAN::Index->force_reload;
+ } else {
+ $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN modules
+index re-reads the index files\n});
+ }
+}
+
+# reload means only load again what we have loaded before
+#-> sub CPAN::Shell::_reload_this ;
+sub _reload_this {
+ my($self,$f,$args) = @_;
+ CPAN->debug("f[$f]") if $CPAN::DEBUG;
+ return 1 unless $INC{$f}; # we never loaded this, so we do not
+ # reload but say OK
+ my $pwd = CPAN::anycwd();
+ CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
+ my($file);
+ for my $inc (@INC) {
+ $file = File::Spec->catfile($inc,split /\//, $f);
+ last if -f $file;
+ $file = "";
+ }
+ CPAN->debug("file[$file]") if $CPAN::DEBUG;
+ my @inc = @INC;
+ unless ($file && -f $file) {
+ # this thingy is not in the INC path, maybe CPAN/MyConfig.pm?
+ $file = $INC{$f};
+ unless (CPAN->has_inst("File::Basename")) {
+ @inc = File::Basename::dirname($file);
+ } else {
+ # do we ever need this?
+ @inc = substr($file,0,-length($f)-1); # bring in back to me!
+ }
+ }
+ CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
+ unless (-f $file) {
+ $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
+ return;
+ }
+ my $mtime = (stat $file)[9];
+ $reload->{$f} ||= -1;
+ my $must_reload = $mtime != $reload->{$f};
+ $args ||= {};
+ $must_reload ||= $args->{reloforce}; # o conf defaults needs this
+ if ($must_reload) {
+ my $fh = FileHandle->new($file) or
+ $CPAN::Frontend->mydie("Could not open $file: $!");
+ my $content;
+ {
+ local($/);
+ local $^W = 1;
+ $content = <$fh>;
+ }
+ CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
+ if $CPAN::DEBUG;
+ my $includefile;
+ if ($includefile = $INC{$f} and -e $includefile) {
+ $f = $includefile;
+ }
+ delete $INC{$f};
+ local @INC = @inc;
+ eval "require '$f'";
+ if ($@) {
+ warn $@;
+ return;
+ }
+ $reload->{$f} = $mtime;
+ } else {
+ $CPAN::Frontend->myprint("__unchanged__");
+ }
+ return 1;
+}
+
+#-> sub CPAN::Shell::mkmyconfig ;
+sub mkmyconfig {
+ my($self) = @_;
+ if ( my $configpm = $INC{'CPAN/MyConfig.pm'} ) {
+ $CPAN::Frontend->myprint(
+ "CPAN::MyConfig already exists as $configpm.\n" .
+ "Running configuration again...\n"
+ );
+ require CPAN::FirstTime;
+ CPAN::FirstTime::init($configpm);
+ }
+ else {
+ # force some missing values to be filled in with defaults
+ delete $CPAN::Config->{$_}
+ for qw/build_dir cpan_home keep_source_where histfile/;
+ CPAN::HandleConfig->load( make_myconfig => 1 );
+ }
+}
+
+#-> sub CPAN::Shell::_binary_extensions ;
+sub _binary_extensions {
+ my($self) = shift @_;
+ my(@result,$module,%seen,%need,$headerdone);
+ for $module ($self->expand('Module','/./')) {
+ my $file = $module->cpan_file;
+ next if $file eq "N/A";
+ next if $file =~ /^Contact Author/;
+ my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
+ next if $dist->isa_perl;
+ next unless $module->xs_file;
+ local($|) = 1;
+ $CPAN::Frontend->myprint(".");
+ push @result, $module;
+ }
+# print join " | ", @result;
+ $CPAN::Frontend->myprint("\n");
+ return @result;
+}
+
+#-> sub CPAN::Shell::recompile ;
+sub recompile {
+ my($self) = shift @_;
+ my($module,@module,$cpan_file,%dist);
+ @module = $self->_binary_extensions();
+ for $module (@module) { # we force now and compile later, so we
+ # don't do it twice
+ $cpan_file = $module->cpan_file;
+ my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
+ $pack->force;
+ $dist{$cpan_file}++;
+ }
+ for $cpan_file (sort keys %dist) {
+ $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
+ my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
+ $pack->install;
+ $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
+ # stop a package from recompiling,
+ # e.g. IO-1.12 when we have perl5.003_10
+ }
+}
+
+#-> sub CPAN::Shell::scripts ;
+sub scripts {
+ my($self, $arg) = @_;
+ $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
+
+ for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
+ unless ($CPAN::META->has_inst($req)) {
+ $CPAN::Frontend->mywarn(" $req not available\n");
+ }
+ }
+ my $p = HTML::LinkExtor->new();
+ my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
+ unless (-f $indexfile) {
+ $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
+ }
+ $p->parse_file($indexfile);
+ my @hrefs;
+ my $qrarg;
+ if ($arg =~ s|^/(.+)/$|$1|) {
+ $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
+ }
+ for my $l ($p->links) {
+ my $tag = shift @$l;
+ next unless $tag eq "a";
+ my %att = @$l;
+ my $href = $att{href};
+ next unless $href =~ s|^\.\./authors/id/./../||;
+ if ($arg) {
+ if ($qrarg) {
+ if ($href =~ $qrarg) {
+ push @hrefs, $href;
+ }
+ } else {
+ if ($href =~ /\Q$arg\E/) {
+ push @hrefs, $href;
+ }
+ }
+ } else {
+ push @hrefs, $href;
+ }
+ }
+ # now filter for the latest version if there is more than one of a name
+ my %stems;
+ for (sort @hrefs) {
+ my $href = $_;
+ s/-v?\d.*//;
+ my $stem = $_;
+ $stems{$stem} ||= [];
+ push @{$stems{$stem}}, $href;
+ }
+ for (sort keys %stems) {
+ my $highest;
+ if (@{$stems{$_}} > 1) {
+ $highest = List::Util::reduce {
+ Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
+ } @{$stems{$_}};
+ } else {
+ $highest = $stems{$_}[0];
+ }
+ $CPAN::Frontend->myprint("$highest\n");
+ }
+}
+
+sub _guess_manpage {
+ my($self,$d,$contains,$dist) = @_;
+ $dist =~ s/-/::/g;
+ my $module;
+ if (exists $contains->{$dist}) {
+ $module = $dist;
+ } elsif (1 == keys %$contains) {
+ ($module) = keys %$contains;
+ }
+ my $manpage;
+ if ($module) {
+ my $m = $self->expand("Module",$module);
+ $m->as_string; # called for side-effects, shame
+ $manpage = $m->{MANPAGE};
+ } else {
+ $manpage = "unknown";
+ }
+ return $manpage;
+}
+
+#-> sub CPAN::Shell::_specfile ;
+sub _specfile {
+ die "CPAN::Shell::_specfile() has been moved to CPAN::Plugin::Specfile::post_test()";
+}
+
+#-> sub CPAN::Shell::report ;
+sub report {
+ my($self,@args) = @_;
+ unless ($CPAN::META->has_inst("CPAN::Reporter")) {
+ $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
+ }
+ local $CPAN::Config->{test_report} = 1;
+ $self->force("test",@args); # force is there so that the test be
+ # re-run (as documented)
+}
+
+# compare with is_tested
+#-> sub CPAN::Shell::install_tested
+sub install_tested {
+ my($self,@some) = @_;
+ $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
+ return if @some;
+ CPAN::Index->reload;
+
+ for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
+ my $yaml = "$b.yml";
+ unless (-f $yaml) {
+ $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
+ next;
+ }
+ my $yaml_content = CPAN->_yaml_loadfile($yaml);
+ my $id = $yaml_content->[0]{distribution}{ID};
+ unless ($id) {
+ $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
+ next;
+ }
+ my $do = CPAN::Shell->expandany($id);
+ unless ($do) {
+ $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
+ next;
+ }
+ unless ($do->{build_dir}) {
+ $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
+ next;
+ }
+ unless ($do->{build_dir} eq $b) {
+ $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
+ next;
+ }
+ push @some, $do;
+ }
+
+ $CPAN::Frontend->mywarn("No tested distributions found.\n"),
+ return unless @some;
+
+ @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
+ $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
+ return unless @some;
+
+ # @some = grep { not $_->uptodate } @some;
+ # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
+ # return unless @some;
+
+ CPAN->debug("some[@some]");
+ for my $d (@some) {
+ my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
+ $CPAN::Frontend->myprint("install_tested: Running for $id\n");
+ $CPAN::Frontend->mysleep(1);
+ $self->install($d);
+ }
+}
+
+#-> sub CPAN::Shell::upgrade ;
+sub upgrade {
+ my($self,@args) = @_;
+ $self->install($self->r(@args));
+}
+
+#-> sub CPAN::Shell::_u_r_common ;
+sub _u_r_common {
+ my($self) = shift @_;
+ my($what) = shift @_;
+ CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
+ Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
+ $what && $what =~ /^[aru]$/;
+ my(@args) = @_;
+ @args = '/./' unless @args;
+ my(@result,$module,%seen,%need,$headerdone,
+ $version_undefs,$version_zeroes,
+ @version_undefs,@version_zeroes);
+ $version_undefs = $version_zeroes = 0;
+ my $sprintf = "%s%-25s%s %9s %9s %s\n";
+ my @expand = $self->expand('Module',@args);
+ if ($CPAN::DEBUG) { # Looks like noise to me, was very useful for debugging
+ # for metadata cache
+ my $expand = scalar @expand;
+ $CPAN::Frontend->myprint(sprintf "%d matches in the database, time[%d]\n", $expand, time);
+ }
+ my @sexpand;
+ if ($] < 5.008) {
+ # hard to believe that the more complex sorting can lead to
+ # stack curruptions on older perl
+ @sexpand = sort {$a->id cmp $b->id} @expand;
+ } else {
+ @sexpand = map {
+ $_->[1]
+ } sort {
+ $b->[0] <=> $a->[0]
+ ||
+ $a->[1]{ID} cmp $b->[1]{ID},
+ } map {
+ [$_->_is_representative_module,
+ $_
+ ]
+ } @expand;
+ }
+ if ($CPAN::DEBUG) {
+ $CPAN::Frontend->myprint(sprintf "sorted at time[%d]\n", time);
+ sleep 1;
+ }
+ MODULE: for $module (@sexpand) {
+ my $file = $module->cpan_file;
+ next MODULE unless defined $file; # ??
+ $file =~ s!^./../!!;
+ my($latest) = $module->cpan_version;
+ my($inst_file) = $module->inst_file;
+ CPAN->debug("file[$file]latest[$latest]") if $CPAN::DEBUG;
+ my($have);
+ return if $CPAN::Signal;
+ my($next_MODULE);
+ eval { # version.pm involved!
+ if ($inst_file) {
+ if ($what eq "a") {
+ $have = $module->inst_version;
+ } elsif ($what eq "r") {
+ $have = $module->inst_version;
+ local($^W) = 0;
+ if ($have eq "undef") {
+ $version_undefs++;
+ push @version_undefs, $module->as_glimpse;
+ } elsif (CPAN::Version->vcmp($have,0)==0) {
+ $version_zeroes++;
+ push @version_zeroes, $module->as_glimpse;
+ }
+ ++$next_MODULE unless CPAN::Version->vgt($latest, $have);
+ # to be pedantic we should probably say:
+ # && !($have eq "undef" && $latest ne "undef" && $latest gt "");
+ # to catch the case where CPAN has a version 0 and we have a version undef
+ } elsif ($what eq "u") {
+ ++$next_MODULE;
+ }
+ } else {
+ if ($what eq "a") {
+ ++$next_MODULE;
+ } elsif ($what eq "r") {
+ ++$next_MODULE;
+ } elsif ($what eq "u") {
+ $have = "-";
+ }
+ }
+ };
+ next MODULE if $next_MODULE;
+ if ($@) {
+ $CPAN::Frontend->mywarn
+ (sprintf("Error while comparing cpan/installed versions of '%s':
+INST_FILE: %s
+INST_VERSION: %s %s
+CPAN_VERSION: %s %s
+",
+ $module->id,
+ $inst_file || "",
+ (defined $have ? $have : "[UNDEFINED]"),
+ (ref $have ? ref $have : ""),
+ $latest,
+ (ref $latest ? ref $latest : ""),
+ ));
+ next MODULE;
+ }
+ return if $CPAN::Signal; # this is sometimes lengthy
+ $seen{$file} ||= 0;
+ if ($what eq "a") {
+ push @result, sprintf "%s %s\n", $module->id, $have;
+ } elsif ($what eq "r") {
+ push @result, $module->id;
+ next MODULE if $seen{$file}++;
+ } elsif ($what eq "u") {
+ push @result, $module->id;
+ next MODULE if $seen{$file}++;
+ next MODULE if $file =~ /^Contact/;
+ }
+ unless ($headerdone++) {
+ $CPAN::Frontend->myprint("\n");
+ $CPAN::Frontend->myprint(sprintf(
+ $sprintf,
+ "",
+ "Package namespace",
+ "",
+ "installed",
+ "latest",
+ "in CPAN file"
+ ));
+ }
+ my $color_on = "";
+ my $color_off = "";
+ if (
+ $COLOR_REGISTERED
+ &&
+ $CPAN::META->has_inst("Term::ANSIColor")
+ &&
+ $module->description
+ ) {
+ $color_on = Term::ANSIColor::color("green");
+ $color_off = Term::ANSIColor::color("reset");
+ }
+ $CPAN::Frontend->myprint(sprintf $sprintf,
+ $color_on,
+ $module->id,
+ $color_off,
+ $have,
+ $latest,
+ $file);
+ $need{$module->id}++;
+ }
+ unless (%need) {
+ if (!@expand || $what eq "u") {
+ $CPAN::Frontend->myprint("No modules found for @args\n");
+ } elsif ($what eq "r") {
+ $CPAN::Frontend->myprint("All modules are up to date for @args\n");
+ }
+ }
+ if ($what eq "r") {
+ if ($version_zeroes) {
+ my $s_has = $version_zeroes > 1 ? "s have" : " has";
+ $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
+ qq{a version number of 0\n});
+ if ($CPAN::Config->{show_zero_versions}) {
+ local $" = "\t";
+ $CPAN::Frontend->myprint(qq{ they are\n\t@version_zeroes\n});
+ $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 0' }.
+ qq{to hide them)\n});
+ } else {
+ $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 1' }.
+ qq{to show them)\n});
+ }
+ }
+ if ($version_undefs) {
+ my $s_has = $version_undefs > 1 ? "s have" : " has";
+ $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
+ qq{parsable version number\n});
+ if ($CPAN::Config->{show_unparsable_versions}) {
+ local $" = "\t";
+ $CPAN::Frontend->myprint(qq{ they are\n\t@version_undefs\n});
+ $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 0' }.
+ qq{to hide them)\n});
+ } else {
+ $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 1' }.
+ qq{to show them)\n});
+ }
+ }
+ }
+ @result;
+}
+
+#-> sub CPAN::Shell::r ;
+sub r {
+ shift->_u_r_common("r",@_);
+}
+
+#-> sub CPAN::Shell::u ;
+sub u {
+ shift->_u_r_common("u",@_);
+}
+
+#-> sub CPAN::Shell::failed ;
+sub failed {
+ my($self,$only_id,$silent) = @_;
+ my @failed = $self->find_failed($only_id);
+ my $scope;
+ if ($only_id) {
+ $scope = "this command";
+ } elsif ($CPAN::Index::HAVE_REANIMATED) {
+ $scope = "this or a previous session";
+ # it might be nice to have a section for previous session and
+ # a second for this
+ } else {
+ $scope = "this session";
+ }
+ if (@failed) {
+ my $print;
+ my $debug = 0;
+ if ($debug) {
+ $print = join "",
+ map { sprintf "%5d %-45s: %s %s\n", @$_ }
+ sort { $a->[0] <=> $b->[0] } @failed;
+ } else {
+ $print = join "",
+ map { sprintf " %-45s: %s %s\n", @$_[1..3] }
+ sort {
+ $a->[0] <=> $b->[0]
+ ||
+ $a->[4] <=> $b->[4]
+ } @failed;
+ }
+ $CPAN::Frontend->myprint("Failed during $scope:\n$print");
+ } elsif (!$only_id || !$silent) {
+ $CPAN::Frontend->myprint("Nothing failed in $scope\n");
+ }
+}
+
+sub find_failed {
+ my($self,$only_id) = @_;
+ my @failed;
+ DIST: for my $d (sort { $a->id cmp $b->id } $CPAN::META->all_objects("CPAN::Distribution")) {
+ my $failed = "";
+ NAY: for my $nosayer ( # order matters!
+ "unwrapped",
+ "writemakefile",
+ "signature_verify",
+ "make",
+ "make_test",
+ "install",
+ "make_clean",
+ ) {
+ next unless exists $d->{$nosayer};
+ next unless defined $d->{$nosayer};
+ next unless (
+ UNIVERSAL::can($d->{$nosayer},"failed") ?
+ $d->{$nosayer}->failed :
+ $d->{$nosayer} =~ /^NO/
+ );
+ next NAY if $only_id && $only_id != (
+ UNIVERSAL::can($d->{$nosayer},"commandid")
+ ?
+ $d->{$nosayer}->commandid
+ :
+ $CPAN::CurrentCommandId
+ );
+ $failed = $nosayer;
+ last;
+ }
+ next DIST unless $failed;
+ my $id = $d->id;
+ $id =~ s|^./../||;
+ ### XXX need to flag optional modules as '(optional)' if they are
+ # from recommends/suggests -- i.e. *show* failure, but make it clear
+ # it was failure of optional module -- xdg, 2012-04-01
+ $id = "(optional) $id" if ! $d->{mandatory};
+ #$print .= sprintf(
+ # " %-45s: %s %s\n",
+ push @failed,
+ (
+ UNIVERSAL::can($d->{$failed},"failed") ?
+ [
+ $d->{$failed}->commandid,
+ $id,
+ $failed,
+ $d->{$failed}->text,
+ $d->{$failed}{TIME}||0,
+ !! $d->{mandatory},
+ ] :
+ [
+ 1,
+ $id,
+ $failed,
+ $d->{$failed},
+ 0,
+ !! $d->{mandatory},
+ ]
+ );
+ }
+ return @failed;
+}
+
+sub mandatory_dist_failed {
+ my ($self) = @_;
+ return grep { $_->[5] } $self->find_failed($CPAN::CurrentCommandID);
+}
+
+# XXX intentionally undocumented because completely bogus, unportable,
+# useless, etc.
+
+#-> sub CPAN::Shell::status ;
+sub status {
+ my($self) = @_;
+ require Devel::Size;
+ my $ps = FileHandle->new;
+ open $ps, "/proc/$$/status";
+ my $vm = 0;
+ while (<$ps>) {
+ next unless /VmSize:\s+(\d+)/;
+ $vm = $1;
+ last;
+ }
+ $CPAN::Frontend->mywarn(sprintf(
+ "%-27s %6d\n%-27s %6d\n",
+ "vm",
+ $vm,
+ "CPAN::META",
+ Devel::Size::total_size($CPAN::META)/1024,
+ ));
+ for my $k (sort keys %$CPAN::META) {
+ next unless substr($k,0,4) eq "read";
+ warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
+ for my $k2 (sort keys %{$CPAN::META->{$k}}) {
+ warn sprintf " %-25s %6d (keys: %6d)\n",
+ $k2,
+ Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
+ scalar keys %{$CPAN::META->{$k}{$k2}};
+ }
+ }
+}
+
+# compare with install_tested
+#-> sub CPAN::Shell::is_tested
+sub is_tested {
+ my($self) = @_;
+ CPAN::Index->reload;
+ for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
+ my $time;
+ if ($CPAN::META->{is_tested}{$b}) {
+ $time = scalar(localtime $CPAN::META->{is_tested}{$b});
+ } else {
+ $time = scalar localtime;
+ $time =~ s/\S/?/g;
+ }
+ $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
+ }
+}
+
+#-> sub CPAN::Shell::autobundle ;
+sub autobundle {
+ my($self) = shift;
+ CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
+ my(@bundle) = $self->_u_r_common("a",@_);
+ my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
+ File::Path::mkpath($todir);
+ unless (-d $todir) {
+ $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
+ return;
+ }
+ my($y,$m,$d) = (localtime)[5,4,3];
+ $y+=1900;
+ $m++;
+ my($c) = 0;
+ my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
+ my($to) = File::Spec->catfile($todir,"$me.pm");
+ while (-f $to) {
+ $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
+ $to = File::Spec->catfile($todir,"$me.pm");
+ }
+ my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
+ $fh->print(
+ "package Bundle::$me;\n\n",
+ "\$","VERSION = '0.01';\n\n", # hide from perl-reversion
+ "1;\n\n",
+ "__END__\n\n",
+ "=head1 NAME\n\n",
+ "Bundle::$me - Snapshot of installation on ",
+ $Config::Config{'myhostname'},
+ " on ",
+ scalar(localtime),
+ "\n\n=head1 SYNOPSIS\n\n",
+ "perl -MCPAN -e 'install Bundle::$me'\n\n",
+ "=head1 CONTENTS\n\n",
+ join("\n", @bundle),
+ "\n\n=head1 CONFIGURATION\n\n",
+ Config->myconfig,
+ "\n\n=head1 AUTHOR\n\n",
+ "This Bundle has been generated automatically ",
+ "by the autobundle routine in CPAN.pm.\n",
+ );
+ $fh->close;
+ $CPAN::Frontend->myprint("\nWrote bundle file
+ $to\n\n");
+ return $to;
+}
+
+#-> sub CPAN::Shell::expandany ;
+sub expandany {
+ my($self,$s) = @_;
+ CPAN->debug("s[$s]") if $CPAN::DEBUG;
+ my $module_as_path = "";
+ if ($s =~ m|(?:\w+/)*\w+\.pm$|) { # same regexp in sub m
+ $module_as_path = $s;
+ $module_as_path =~ s/.pm$//;
+ $module_as_path =~ s|/|::|g;
+ }
+ if ($module_as_path) {
+ if ($module_as_path =~ m|^Bundle::|) {
+ $self->local_bundles;
+ return $self->expand('Bundle',$module_as_path);
+ } else {
+ return $self->expand('Module',$module_as_path)
+ if $CPAN::META->exists('CPAN::Module',$module_as_path);
+ }
+ } elsif ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
+ $s = CPAN::Distribution->normalize($s);
+ return $CPAN::META->instance('CPAN::Distribution',$s);
+ # Distributions spring into existence, not expand
+ } elsif ($s =~ m|^Bundle::|) {
+ $self->local_bundles; # scanning so late for bundles seems
+ # both attractive and crumpy: always
+ # current state but easy to forget
+ # somewhere
+ return $self->expand('Bundle',$s);
+ } else {
+ return $self->expand('Module',$s)
+ if $CPAN::META->exists('CPAN::Module',$s);
+ }
+ return;
+}
+
+#-> sub CPAN::Shell::expand ;
+sub expand {
+ my $self = shift;
+ my($type,@args) = @_;
+ CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
+ my $class = "CPAN::$type";
+ my $methods = ['id'];
+ for my $meth (qw(name)) {
+ next unless $class->can($meth);
+ push @$methods, $meth;
+ }
+ $self->expand_by_method($class,$methods,@args);
+}
+
+#-> sub CPAN::Shell::expand_by_method ;
+sub expand_by_method {
+ my $self = shift;
+ my($class,$methods,@args) = @_;
+ my($arg,@m);
+ for $arg (@args) {
+ my($regex,$command);
+ if ($arg =~ m|^/(.*)/$|) {
+ $regex = $1;
+# FIXME: there seem to be some ='s in the author data, which trigger
+# a failure here. This needs to be contemplated.
+# } elsif ($arg =~ m/=/) {
+# $command = 1;
+ }
+ my $obj;
+ CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
+ $class,
+ defined $regex ? $regex : "UNDEFINED",
+ defined $command ? $command : "UNDEFINED",
+ ) if $CPAN::DEBUG;
+ if (defined $regex) {
+ if (CPAN::_sqlite_running()) {
+ CPAN::Index->reload;
+ $CPAN::SQLite->search($class, $regex);
+ }
+ for $obj (
+ $CPAN::META->all_objects($class)
+ ) {
+ unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id) {
+ # BUG, we got an empty object somewhere
+ require Data::Dumper;
+ CPAN->debug(sprintf(
+ "Bug in CPAN: Empty id on obj[%s][%s]",
+ $obj,
+ Data::Dumper::Dumper($obj)
+ )) if $CPAN::DEBUG;
+ next;
+ }
+ for my $method (@$methods) {
+ my $match = eval {$obj->$method() =~ /$regex/i};
+ if ($@) {
+ my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
+ $err ||= $@; # if we were too restrictive above
+ $CPAN::Frontend->mydie("$err\n");
+ } elsif ($match) {
+ push @m, $obj;
+ last;
+ }
+ }
+ }
+ } elsif ($command) {
+ die "equal sign in command disabled (immature interface), ".
+ "you can set
+ ! \$CPAN::Shell::ADVANCED_QUERY=1
+to enable it. But please note, this is HIGHLY EXPERIMENTAL code
+that may go away anytime.\n"
+ unless $ADVANCED_QUERY;
+ my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
+ my($matchcrit) = $criterion =~ m/^~(.+)/;
+ for my $self (
+ sort
+ {$a->id cmp $b->id}
+ $CPAN::META->all_objects($class)
+ ) {
+ my $lhs = $self->$method() or next; # () for 5.00503
+ if ($matchcrit) {
+ push @m, $self if $lhs =~ m/$matchcrit/;
+ } else {
+ push @m, $self if $lhs eq $criterion;
+ }
+ }
+ } else {
+ my($xarg) = $arg;
+ if ( $class eq 'CPAN::Bundle' ) {
+ $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
+ } elsif ($class eq "CPAN::Distribution") {
+ $xarg = CPAN::Distribution->normalize($arg);
+ } else {
+ $xarg =~ s/:+/::/g;
+ }
+ if ($CPAN::META->exists($class,$xarg)) {
+ $obj = $CPAN::META->instance($class,$xarg);
+ } elsif ($CPAN::META->exists($class,$arg)) {
+ $obj = $CPAN::META->instance($class,$arg);
+ } else {
+ next;
+ }
+ push @m, $obj;
+ }
+ }
+ @m = sort {$a->id cmp $b->id} @m;
+ if ( $CPAN::DEBUG ) {
+ my $wantarray = wantarray;
+ my $join_m = join ",", map {$_->id} @m;
+ # $self->debug("wantarray[$wantarray]join_m[$join_m]");
+ my $count = scalar @m;
+ $self->debug("class[$class]wantarray[$wantarray]count m[$count]");
+ }
+ return wantarray ? @m : $m[0];
+}
+
+#-> sub CPAN::Shell::format_result ;
+sub format_result {
+ my($self) = shift;
+ my($type,@args) = @_;
+ @args = '/./' unless @args;
+ my(@result) = $self->expand($type,@args);
+ my $result = @result == 1 ?
+ $result[0]->as_string :
+ @result == 0 ?
+ "No objects of type $type found for argument @args\n" :
+ join("",
+ (map {$_->as_glimpse} @result),
+ scalar @result, " items found\n",
+ );
+ $result;
+}
+
+#-> sub CPAN::Shell::report_fh ;
+{
+ my $installation_report_fh;
+ my $previously_noticed = 0;
+
+ sub report_fh {
+ return $installation_report_fh if $installation_report_fh;
+ if ($CPAN::META->has_usable("File::Temp")) {
+ $installation_report_fh
+ = File::Temp->new(
+ dir => File::Spec->tmpdir,
+ template => 'cpan_install_XXXX',
+ suffix => '.txt',
+ unlink => 0,
+ );
+ }
+ unless ( $installation_report_fh ) {
+ warn("Couldn't open installation report file; " .
+ "no report file will be generated."
+ ) unless $previously_noticed++;
+ }
+ }
+}
+
+
+# The only reason for this method is currently to have a reliable
+# debugging utility that reveals which output is going through which
+# channel. No, I don't like the colors ;-)
+
+# to turn colordebugging on, write
+# cpan> o conf colorize_output 1
+
+#-> sub CPAN::Shell::colorize_output ;
+{
+ my $print_ornamented_have_warned = 0;
+ sub colorize_output {
+ my $colorize_output = $CPAN::Config->{colorize_output};
+ if ($colorize_output && $^O eq 'MSWin32' && !$CPAN::META->has_inst("Win32::Console::ANSI")) {
+ unless ($print_ornamented_have_warned++) {
+ # no myprint/mywarn within myprint/mywarn!
+ warn "Colorize_output is set to true but Win32::Console::ANSI is not
+installed. To activate colorized output, please install Win32::Console::ANSI.\n\n";
+ }
+ $colorize_output = 0;
+ }
+ if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
+ unless ($print_ornamented_have_warned++) {
+ # no myprint/mywarn within myprint/mywarn!
+ warn "Colorize_output is set to true but Term::ANSIColor is not
+installed. To activate colorized output, please install Term::ANSIColor.\n\n";
+ }
+ $colorize_output = 0;
+ }
+ return $colorize_output;
+ }
+}
+
+
+#-> sub CPAN::Shell::print_ornamented ;
+sub print_ornamented {
+ my($self,$what,$ornament) = @_;
+ return unless defined $what;
+
+ local $| = 1; # Flush immediately
+ if ( $CPAN::Be_Silent ) {
+ # WARNING: variable Be_Silent is poisoned and must be eliminated.
+ print {report_fh()} $what;
+ return;
+ }
+ my $swhat = "$what"; # stringify if it is an object
+ if ($CPAN::Config->{term_is_latin}) {
+ # note: deprecated, need to switch to $LANG and $LC_*
+ # courtesy jhi:
+ $swhat
+ =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
+ }
+ if ($self->colorize_output) {
+ if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
+ # if you want to have this configurable, please file a bug report
+ $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
+ }
+ my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
+ if ($@) {
+ print "Term::ANSIColor rejects color[$ornament]: $@\n
+Please choose a different color (Hint: try 'o conf init /color/')\n";
+ }
+ # GGOLDBACH/Test-GreaterVersion-0.008 broke without this
+ # $trailer construct. We want the newline be the last thing if
+ # there is a newline at the end ensuring that the next line is
+ # empty for other players
+ my $trailer = "";
+ $trailer = $1 if $swhat =~ s/([\r\n]+)\z//;
+ print $color_on,
+ $swhat,
+ Term::ANSIColor::color("reset"),
+ $trailer;
+ } else {
+ print $swhat;
+ }
+}
+
+#-> sub CPAN::Shell::myprint ;
+
+# where is myprint/mywarn/Frontend/etc. documented? Where to use what?
+# I think, we send everything to STDOUT and use print for normal/good
+# news and warn for news that need more attention. Yes, this is our
+# working contract for now.
+sub myprint {
+ my($self,$what) = @_;
+ $self->print_ornamented($what,
+ $CPAN::Config->{colorize_print}||'bold blue on_white',
+ );
+}
+
+my %already_printed;
+#-> sub CPAN::Shell::mywarnonce ;
+sub myprintonce {
+ my($self,$what) = @_;
+ $self->myprint($what) unless $already_printed{$what}++;
+}
+
+sub optprint {
+ my($self,$category,$what) = @_;
+ my $vname = $category . "_verbosity";
+ CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
+ if (!$CPAN::Config->{$vname}
+ || $CPAN::Config->{$vname} =~ /^v/
+ ) {
+ $CPAN::Frontend->myprint($what);
+ }
+}
+
+#-> sub CPAN::Shell::myexit ;
+sub myexit {
+ my($self,$what) = @_;
+ $self->myprint($what);
+ exit;
+}
+
+#-> sub CPAN::Shell::mywarn ;
+sub mywarn {
+ my($self,$what) = @_;
+ $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
+}
+
+my %already_warned;
+#-> sub CPAN::Shell::mywarnonce ;
+sub mywarnonce {
+ my($self,$what) = @_;
+ $self->mywarn($what) unless $already_warned{$what}++;
+}
+
+# only to be used for shell commands
+#-> sub CPAN::Shell::mydie ;
+sub mydie {
+ my($self,$what) = @_;
+ $self->mywarn($what);
+
+ # If it is the shell, we want the following die to be silent,
+ # but if it is not the shell, we would need a 'die $what'. We need
+ # to take care that only shell commands use mydie. Is this
+ # possible?
+
+ die "\n";
+}
+
+# sub CPAN::Shell::colorable_makemaker_prompt ;
+sub colorable_makemaker_prompt {
+ my($foo,$bar) = @_;
+ if (CPAN::Shell->colorize_output) {
+ my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
+ my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
+ print $color_on;
+ }
+ my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
+ if (CPAN::Shell->colorize_output) {
+ print Term::ANSIColor::color('reset');
+ }
+ return $ans;
+}
+
+# use this only for unrecoverable errors!
+#-> sub CPAN::Shell::unrecoverable_error ;
+sub unrecoverable_error {
+ my($self,$what) = @_;
+ my @lines = split /\n/, $what;
+ my $longest = 0;
+ for my $l (@lines) {
+ $longest = length $l if length $l > $longest;
+ }
+ $longest = 62 if $longest > 62;
+ for my $l (@lines) {
+ if ($l =~ /^\s*$/) {
+ $l = "\n";
+ next;
+ }
+ $l = "==> $l";
+ if (length $l < 66) {
+ $l = pack "A66 A*", $l, "<==";
+ }
+ $l .= "\n";
+ }
+ unshift @lines, "\n";
+ $self->mydie(join "", @lines);
+}
+
+#-> sub CPAN::Shell::mysleep ;
+sub mysleep {
+ return if $ENV{AUTOMATED_TESTING} || ! -t STDOUT;
+ my($self, $sleep) = @_;
+ if (CPAN->has_inst("Time::HiRes")) {
+ Time::HiRes::sleep($sleep);
+ } else {
+ sleep($sleep < 1 ? 1 : int($sleep + 0.5));
+ }
+}
+
+#-> sub CPAN::Shell::setup_output ;
+sub setup_output {
+ return if -t STDOUT;
+ my $odef = select STDERR;
+ $| = 1;
+ select STDOUT;
+ $| = 1;
+ select $odef;
+}
+
+#-> sub CPAN::Shell::rematein ;
+# RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
+sub rematein {
+ my $self = shift;
+ # this variable was global and disturbed programmers, so localize:
+ local $CPAN::Distrostatus::something_has_failed_at;
+ my($meth,@some) = @_;
+ my @pragma;
+ while($meth =~ /^(ff?orce|notest)$/) {
+ push @pragma, $meth;
+ $meth = shift @some or
+ $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
+ "cannot continue");
+ }
+ setup_output();
+ CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
+
+ # Here is the place to set "test_count" on all involved parties to
+ # 0. We then can pass this counter on to the involved
+ # distributions and those can refuse to test if test_count > X. In
+ # the first stab at it we could use a 1 for "X".
+
+ # But when do I reset the distributions to start with 0 again?
+ # Jost suggested to have a random or cycling interaction ID that
+ # we pass through. But the ID is something that is just left lying
+ # around in addition to the counter, so I'd prefer to set the
+ # counter to 0 now, and repeat at the end of the loop. But what
+ # about dependencies? They appear later and are not reset, they
+ # enter the queue but not its copy. How do they get a sensible
+ # test_count?
+
+ # With configure_requires, "get" is vulnerable in recursion.
+
+ my $needs_recursion_protection = "get|make|test|install";
+
+ # construct the queue
+ my($s,@s,@qcopy);
+ STHING: foreach $s (@some) {
+ my $obj;
+ if (ref $s) {
+ CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
+ $obj = $s;
+ } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
+ } elsif ($s =~ m|^/|) { # looks like a regexp
+ if (substr($s,-1,1) eq ".") {
+ $obj = CPAN::Shell->expandany($s);
+ } else {
+ my @obj;
+ CLASS: for my $class (qw(Distribution Bundle Module)) {
+ if (@obj = $self->expand($class,$s)) {
+ last CLASS;
+ }
+ }
+ if (@obj) {
+ if (1==@obj) {
+ $obj = $obj[0];
+ } else {
+ $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
+ "only supported when unambiguous.\nRejecting argument '$s'\n");
+ $CPAN::Frontend->mysleep(2);
+ next STHING;
+ }
+ }
+ }
+ } elsif ($meth eq "ls") {
+ $self->globls($s,\@pragma);
+ next STHING;
+ } else {
+ CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
+ $obj = CPAN::Shell->expandany($s);
+ }
+ if (0) {
+ } elsif (ref $obj) {
+ if ($meth =~ /^($needs_recursion_protection)$/) {
+ # it would be silly to check for recursion for look or dump
+ # (we are in CPAN::Shell::rematein)
+ CPAN->debug("Testing against recursion") if $CPAN::DEBUG;
+ eval { $obj->color_cmd_tmps(0,1); };
+ if ($@) {
+ if (ref $@
+ and $@->isa("CPAN::Exception::RecursiveDependency")) {
+ $CPAN::Frontend->mywarn($@);
+ } else {
+ if (0) {
+ require Carp;
+ Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
+ }
+ die;
+ }
+ }
+ }
+ CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c", optional => '');
+ push @qcopy, $obj;
+ } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
+ $obj = $CPAN::META->instance('CPAN::Author',uc($s));
+ if ($meth =~ /^(dump|ls|reports)$/) {
+ $obj->$meth();
+ } else {
+ $CPAN::Frontend->mywarn(
+ join "",
+ "Don't be silly, you can't $meth ",
+ $obj->fullname,
+ " ;-)\n"
+ );
+ $CPAN::Frontend->mysleep(2);
+ }
+ } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
+ CPAN::InfoObj->dump($s);
+ } else {
+ $CPAN::Frontend
+ ->mywarn(qq{Warning: Cannot $meth $s, }.
+ qq{don't know what it is.
+Try the command
+
+ i /$s/
+
+to find objects with matching identifiers.
+});
+ $CPAN::Frontend->mysleep(2);
+ }
+ }
+
+ # queuerunner (please be warned: when I started to change the
+ # queue to hold objects instead of names, I made one or two
+ # mistakes and never found which. I reverted back instead)
+ QITEM: while (my $q = CPAN::Queue->first) {
+ my $obj;
+ my $s = $q->as_string;
+ my $reqtype = $q->reqtype || "";
+ my $optional = $q->optional || "";
+ $obj = CPAN::Shell->expandany($s);
+ unless ($obj) {
+ # don't know how this can happen, maybe we should panic,
+ # but maybe we get a solution from the first user who hits
+ # this unfortunate exception?
+ $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
+ "to an object. Skipping.\n");
+ $CPAN::Frontend->mysleep(5);
+ CPAN::Queue->delete_first($s);
+ next QITEM;
+ }
+ $obj->{reqtype} ||= "";
+ my $type = ref $obj;
+ if ( $type eq 'CPAN::Distribution' || $type eq 'CPAN::Bundle' ) {
+ $obj->{mandatory} ||= ! $optional; # once mandatory, always mandatory
+ }
+ elsif ( $type eq 'CPAN::Module' ) {
+ $obj->{mandatory} ||= ! $optional; # once mandatory, always mandatory
+ if (my $d = $obj->distribution) {
+ $d->{mandatory} ||= ! $optional; # once mandatory, always mandatory
+ } elsif ($optional) {
+ # the queue object does not know who was recommending/suggesting us:(
+ # So we only vaguely write "optional".
+ $CPAN::Frontend->mywarn("Warning: optional module '$s' ".
+ "not known. Skipping.\n");
+ CPAN::Queue->delete_first($s);
+ next QITEM;
+ }
+ }
+ {
+ # force debugging because CPAN::SQLite somehow delivers us
+ # an empty object;
+
+ # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
+
+ CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
+ "q-reqtype[$reqtype]") if $CPAN::DEBUG;
+ }
+ if ($obj->{reqtype}) {
+ if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
+ $obj->{reqtype} = $reqtype;
+ if (
+ exists $obj->{install}
+ &&
+ (
+ UNIVERSAL::can($obj->{install},"failed") ?
+ $obj->{install}->failed :
+ $obj->{install} =~ /^NO/
+ )
+ ) {
+ delete $obj->{install};
+ $CPAN::Frontend->mywarn
+ ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
+ }
+ }
+ } else {
+ $obj->{reqtype} = $reqtype;
+ }
+
+ for my $pragma (@pragma) {
+ if ($pragma
+ &&
+ $obj->can($pragma)) {
+ $obj->$pragma($meth);
+ }
+ }
+ if (UNIVERSAL::can($obj, 'called_for')) {
+ $obj->called_for($s);
+ }
+ CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
+ qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
+
+ push @qcopy, $obj;
+ if ($meth =~ /^(report)$/) { # they came here with a pragma?
+ $self->$meth($obj);
+ } elsif (! UNIVERSAL::can($obj,$meth)) {
+ # Must never happen
+ my $serialized = "";
+ if (0) {
+ } elsif ($CPAN::META->has_inst("YAML::Syck")) {
+ $serialized = YAML::Syck::Dump($obj);
+ } elsif ($CPAN::META->has_inst("YAML")) {
+ $serialized = YAML::Dump($obj);
+ } elsif ($CPAN::META->has_inst("Data::Dumper")) {
+ $serialized = Data::Dumper::Dumper($obj);
+ } else {
+ require overload;
+ $serialized = overload::StrVal($obj);
+ }
+ CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
+ $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
+ } else {
+ my $upgraded_meth = $meth;
+ if ( $meth eq "make" and $obj->{reqtype} eq "b" ) {
+ # rt 86915
+ $upgraded_meth = "test";
+ }
+ if ($obj->$upgraded_meth()) {
+ CPAN::Queue->delete($s);
+ CPAN->debug("Succeeded and deleted from queue. pragma[@pragma]meth[$meth][s][$s]") if $CPAN::DEBUG;
+ } else {
+ CPAN->debug("Failed. pragma[@pragma]meth[$meth]s[$s]") if $CPAN::DEBUG;
+ }
+ }
+
+ $obj->undelay;
+ for my $pragma (@pragma) {
+ my $unpragma = "un$pragma";
+ if ($obj->can($unpragma)) {
+ $obj->$unpragma();
+ }
+ }
+ # if any failures occurred and the current object is mandatory, we
+ # still don't know if *it* failed or if it was another (optional)
+ # module, so we have to check that explicitly (and expensively)
+ if ( $CPAN::Config->{halt_on_failure}
+ && $obj->{mandatory}
+ && CPAN::Distrostatus::something_has_just_failed()
+ && $self->mandatory_dist_failed()
+ ) {
+ $CPAN::Frontend->mywarn("Stopping: '$meth' failed for '$s'.\n");
+ CPAN::Queue->nullify_queue;
+ last QITEM;
+ }
+ CPAN::Queue->delete_first($s);
+ }
+ if ($meth =~ /^($needs_recursion_protection)$/) {
+ for my $obj (@qcopy) {
+ $obj->color_cmd_tmps(0,0);
+ }
+ }
+}
+
+#-> sub CPAN::Shell::recent ;
+sub recent {
+ my($self) = @_;
+ if ($CPAN::META->has_inst("XML::LibXML")) {
+ my $url = $CPAN::Defaultrecent;
+ $CPAN::Frontend->myprint("Fetching '$url'\n");
+ unless ($CPAN::META->has_usable("LWP")) {
+ $CPAN::Frontend->mydie("LWP not installed; cannot continue");
+ }
+ CPAN::LWP::UserAgent->config;
+ my $Ua;
+ eval { $Ua = CPAN::LWP::UserAgent->new; };
+ if ($@) {
+ $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
+ }
+ my $resp = $Ua->get($url);
+ unless ($resp->is_success) {
+ $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
+ }
+ $CPAN::Frontend->myprint("DONE\n\n");
+ my $xml = XML::LibXML->new->parse_string($resp->content);
+ if (0) {
+ my $s = $xml->serialize(2);
+ $s =~ s/\n\s*\n/\n/g;
+ $CPAN::Frontend->myprint($s);
+ return;
+ }
+ my @distros;
+ if ($url =~ /winnipeg/) {
+ my $pubdate = $xml->findvalue("/rss/channel/pubDate");
+ $CPAN::Frontend->myprint(" pubDate: $pubdate\n\n");
+ for my $eitem ($xml->findnodes("/rss/channel/item")) {
+ my $distro = $eitem->findvalue("enclosure/\@url");
+ $distro =~ s|.*?/authors/id/./../||;
+ my $size = $eitem->findvalue("enclosure/\@length");
+ my $desc = $eitem->findvalue("description");
+ $desc =~ s/.+? - //;
+ $CPAN::Frontend->myprint("$distro [$size b]\n $desc\n");
+ push @distros, $distro;
+ }
+ } elsif ($url =~ /search.*uploads.rdf/) {
+ # xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+ # xmlns="http://purl.org/rss/1.0/"
+ # xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/"
+ # xmlns:dc="http://purl.org/dc/elements/1.1/"
+ # xmlns:syn="http://purl.org/rss/1.0/modules/syndication/"
+ # xmlns:admin="http://webns.net/mvcb/"
+
+
+ my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']");
+ $CPAN::Frontend->myprint(" dc:date: $dc_date\n\n");
+ my $finish_eitem = 0;
+ local $SIG{INT} = sub { $finish_eitem = 1 };
+ EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) {
+ my $distro = $eitem->findvalue("\@rdf:about");
+ $distro =~ s|.*~||; # remove up to the tilde before the name
+ $distro =~ s|/$||; # remove trailing slash
+ $distro =~ s|([^/]+)|\U$1\E|; # upcase the name
+ my $author = uc $1 or die "distro[$distro] without author, cannot continue";
+ my $desc = $eitem->findvalue("*[local-name(.) = 'description']");
+ my $i = 0;
+ SUBDIRTEST: while () {
+ last SUBDIRTEST if ++$i >= 6; # half a dozen must do!
+ if (my @ret = $self->globls("$distro*")) {
+ @ret = grep {$_->[2] !~ /meta/} @ret;
+ @ret = grep {length $_->[2]} @ret;
+ if (@ret) {
+ $distro = "$author/$ret[0][2]";
+ last SUBDIRTEST;
+ }
+ }
+ $distro =~ s|/|/*/|; # allow it to reside in a subdirectory
+ }
+
+ next EITEM if $distro =~ m|\*|; # did not find the thing
+ $CPAN::Frontend->myprint("____$desc\n");
+ push @distros, $distro;
+ last EITEM if $finish_eitem;
+ }
+ }
+ return \@distros;
+ } else {
+ # deprecated old version
+ $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n");
+ }
+}
+
+#-> sub CPAN::Shell::smoke ;
+sub smoke {
+ my($self) = @_;
+ my $distros = $self->recent;
+ DISTRO: for my $distro (@$distros) {
+ next if $distro =~ m|/Bundle-|; # XXX crude heuristic to skip bundles
+ $CPAN::Frontend->myprint(sprintf "Downloading and testing '$distro'\n");
+ {
+ my $skip = 0;
+ local $SIG{INT} = sub { $skip = 1 };
+ for (0..9) {
+ $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_);
+ sleep 1;
+ if ($skip) {
+ $CPAN::Frontend->myprint(" skipped\n");
+ next DISTRO;
+ }
+ }
+ }
+ $CPAN::Frontend->myprint("\r \n"); # leave the dirty line with a newline
+ $self->test($distro);
+ }
+}
+
+{
+ # set up the dispatching methods
+ no strict "refs";
+ for my $command (qw(
+ clean
+ cvs_import
+ dump
+ force
+ fforce
+ get
+ install
+ look
+ ls
+ make
+ notest
+ perldoc
+ readme
+ reports
+ test
+ )) {
+ *$command = sub { shift->rematein($command, @_); };
+ }
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Tarzip.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Tarzip.pm
new file mode 100644
index 0000000000..f585a01bf7
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Tarzip.pm
@@ -0,0 +1,474 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+package CPAN::Tarzip;
+use strict;
+use vars qw($VERSION @ISA $BUGHUNTING);
+use CPAN::Debug;
+use File::Basename qw(basename);
+$VERSION = "5.5012";
+# module is internal to CPAN.pm
+
+@ISA = qw(CPAN::Debug); ## no critic
+$BUGHUNTING ||= 0; # released code must have turned off
+
+# it's ok if file doesn't exist, it just matters if it is .gz or .bz2
+sub new {
+ my($class,$file) = @_;
+ $CPAN::Frontend->mydie("CPAN::Tarzip->new called without arg") unless defined $file;
+ my $me = { FILE => $file };
+ if ($file =~ /\.(bz2|gz|zip|tbz|tgz)$/i) {
+ $me->{ISCOMPRESSED} = 1;
+ } else {
+ $me->{ISCOMPRESSED} = 0;
+ }
+ if (0) {
+ } elsif ($file =~ /\.(?:bz2|tbz)$/i) {
+ unless ($me->{UNGZIPPRG} = $CPAN::Config->{bzip2}) {
+ my $bzip2 = _my_which("bzip2");
+ if ($bzip2) {
+ $me->{UNGZIPPRG} = $bzip2;
+ } else {
+ $CPAN::Frontend->mydie(qq{
+CPAN.pm needs the external program bzip2 in order to handle '$file'.
+Please install it now and run 'o conf init bzip2' from the
+CPAN shell prompt to register it as external program.
+});
+ }
+ }
+ } else {
+ $me->{UNGZIPPRG} = _my_which("gzip");
+ }
+ $me->{TARPRG} = _my_which("tar") || _my_which("gtar");
+ bless $me, $class;
+}
+
+sub _my_which {
+ my($what) = @_;
+ if ($CPAN::Config->{$what}) {
+ return $CPAN::Config->{$what};
+ }
+ if ($CPAN::META->has_inst("File::Which")) {
+ return File::Which::which($what);
+ }
+ my @cand = MM->maybe_command($what);
+ return $cand[0] if @cand;
+ require File::Spec;
+ my $component;
+ PATH_COMPONENT: foreach $component (File::Spec->path()) {
+ next unless defined($component) && $component;
+ my($abs) = File::Spec->catfile($component,$what);
+ if (MM->maybe_command($abs)) {
+ return $abs;
+ }
+ }
+ return;
+}
+
+sub gzip {
+ my($self,$read) = @_;
+ my $write = $self->{FILE};
+ if ($CPAN::META->has_inst("Compress::Zlib")) {
+ my($buffer,$fhw);
+ $fhw = FileHandle->new($read)
+ or $CPAN::Frontend->mydie("Could not open $read: $!");
+ my $cwd = `pwd`;
+ my $gz = Compress::Zlib::gzopen($write, "wb")
+ or $CPAN::Frontend->mydie("Cannot gzopen $write: $! (pwd is $cwd)\n");
+ binmode($fhw);
+ $gz->gzwrite($buffer)
+ while read($fhw,$buffer,4096) > 0 ;
+ $gz->gzclose() ;
+ $fhw->close;
+ return 1;
+ } else {
+ my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
+ system(qq{$command -c "$read" > "$write"})==0;
+ }
+}
+
+
+sub gunzip {
+ my($self,$write) = @_;
+ my $read = $self->{FILE};
+ if ($CPAN::META->has_inst("Compress::Zlib")) {
+ my($buffer,$fhw);
+ $fhw = FileHandle->new(">$write")
+ or $CPAN::Frontend->mydie("Could not open >$write: $!");
+ my $gz = Compress::Zlib::gzopen($read, "rb")
+ or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
+ binmode($fhw);
+ $fhw->print($buffer)
+ while $gz->gzread($buffer) > 0 ;
+ $CPAN::Frontend->mydie("Error reading from $read: $!\n")
+ if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
+ $gz->gzclose() ;
+ $fhw->close;
+ return 1;
+ } else {
+ my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
+ system(qq{$command -d -c "$read" > "$write"})==0;
+ }
+}
+
+
+sub gtest {
+ my($self) = @_;
+ return $self->{GTEST} if exists $self->{GTEST};
+ defined $self->{FILE} or $CPAN::Frontend->mydie("gtest called but no FILE specified");
+ my $read = $self->{FILE};
+ my $success;
+ if ($read=~/\.(?:bz2|tbz)$/ && $CPAN::META->has_inst("Compress::Bzip2")) {
+ my($buffer,$len);
+ $len = 0;
+ my $gz = Compress::Bzip2::bzopen($read, "rb")
+ or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
+ $read,
+ $Compress::Bzip2::bzerrno));
+ while ($gz->bzread($buffer) > 0 ) {
+ $len += length($buffer);
+ $buffer = "";
+ }
+ my $err = $gz->bzerror;
+ $success = ! $err || $err == Compress::Bzip2::BZ_STREAM_END();
+ if ($len == -s $read) {
+ $success = 0;
+ CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
+ }
+ $gz->gzclose();
+ CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
+ } elsif ( $read=~/\.(?:gz|tgz)$/ && $CPAN::META->has_inst("Compress::Zlib") ) {
+ # After I had reread the documentation in zlib.h, I discovered that
+ # uncompressed files do not lead to an gzerror (anymore?).
+ my($buffer,$len);
+ $len = 0;
+ my $gz = Compress::Zlib::gzopen($read, "rb")
+ or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
+ $read,
+ $Compress::Zlib::gzerrno));
+ while ($gz->gzread($buffer) > 0 ) {
+ $len += length($buffer);
+ $buffer = "";
+ }
+ my $err = $gz->gzerror;
+ $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
+ if ($len == -s $read) {
+ $success = 0;
+ CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
+ }
+ $gz->gzclose();
+ CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
+ } elsif (!$self->{ISCOMPRESSED}) {
+ $success = 0;
+ } else {
+ my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
+ $success = 0==system(qq{$command -qdt "$read"});
+ }
+ return $self->{GTEST} = $success;
+}
+
+
+sub TIEHANDLE {
+ my($class,$file) = @_;
+ my $ret;
+ $class->debug("file[$file]");
+ my $self = $class->new($file);
+ if (0) {
+ } elsif (!$self->gtest) {
+ my $fh = FileHandle->new($file)
+ or $CPAN::Frontend->mydie("Could not open file[$file]: $!");
+ binmode $fh;
+ $self->{FH} = $fh;
+ $class->debug("via uncompressed FH");
+ } elsif ($file =~ /\.(?:bz2|tbz)$/ && $CPAN::META->has_inst("Compress::Bzip2")) {
+ my $gz = Compress::Bzip2::bzopen($file,"rb") or
+ $CPAN::Frontend->mydie("Could not bzopen $file");
+ $self->{GZ} = $gz;
+ $class->debug("via Compress::Bzip2");
+ } elsif ($file =~/\.(?:gz|tgz)$/ && $CPAN::META->has_inst("Compress::Zlib")) {
+ my $gz = Compress::Zlib::gzopen($file,"rb") or
+ $CPAN::Frontend->mydie("Could not gzopen $file");
+ $self->{GZ} = $gz;
+ $class->debug("via Compress::Zlib");
+ } else {
+ my $gzip = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
+ my $pipe = "$gzip -d -c $file |";
+ my $fh = FileHandle->new($pipe) or $CPAN::Frontend->mydie("Could not pipe[$pipe]: $!");
+ binmode $fh;
+ $self->{FH} = $fh;
+ $class->debug("via external $gzip");
+ }
+ $self;
+}
+
+
+sub READLINE {
+ my($self) = @_;
+ if (exists $self->{GZ}) {
+ my $gz = $self->{GZ};
+ my($line,$bytesread);
+ $bytesread = $gz->gzreadline($line);
+ return undef if $bytesread <= 0;
+ return $line;
+ } else {
+ my $fh = $self->{FH};
+ return scalar <$fh>;
+ }
+}
+
+
+sub READ {
+ my($self,$ref,$length,$offset) = @_;
+ $CPAN::Frontend->mydie("read with offset not implemented") if defined $offset;
+ if (exists $self->{GZ}) {
+ my $gz = $self->{GZ};
+ my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
+ return $byteread;
+ } else {
+ my $fh = $self->{FH};
+ return read($fh,$$ref,$length);
+ }
+}
+
+
+sub DESTROY {
+ my($self) = @_;
+ if (exists $self->{GZ}) {
+ my $gz = $self->{GZ};
+ $gz->gzclose() if defined $gz; # hard to say if it is allowed
+ # to be undef ever. AK, 2000-09
+ } else {
+ my $fh = $self->{FH};
+ $fh->close if defined $fh;
+ }
+ undef $self;
+}
+
+sub untar {
+ my($self) = @_;
+ my $file = $self->{FILE};
+ my($prefer) = 0;
+
+ my $exttar = $self->{TARPRG} || "";
+ $exttar = "" if $exttar =~ /^\s+$/; # user refuses to use it
+ my $extgzip = $self->{UNGZIPPRG} || "";
+ $extgzip = "" if $extgzip =~ /^\s+$/; # user refuses to use it
+
+ if (0) { # makes changing order easier
+ } elsif ($BUGHUNTING) {
+ $prefer=2;
+ } elsif ($CPAN::Config->{prefer_external_tar}) {
+ $prefer = 1;
+ } elsif (
+ $CPAN::META->has_usable("Archive::Tar")
+ &&
+ $CPAN::META->has_inst("Compress::Zlib") ) {
+ my $prefer_external_tar = $CPAN::Config->{prefer_external_tar};
+ unless (defined $prefer_external_tar) {
+ if ($^O =~ /(MSWin32|solaris)/) {
+ $prefer_external_tar = 0;
+ } else {
+ $prefer_external_tar = 1;
+ }
+ }
+ $prefer = $prefer_external_tar ? 1 : 2;
+ } elsif ($exttar && $extgzip) {
+ # no modules and not bz2
+ $prefer = 1;
+ # but solaris binary tar is a problem
+ if ($^O eq 'solaris' && qx($exttar --version 2>/dev/null) !~ /gnu/i) {
+ $CPAN::Frontend->mywarn(<< 'END_WARN');
+
+WARNING: Many CPAN distributions were archived with GNU tar and some of
+them may be incompatible with Solaris tar. We respectfully suggest you
+configure CPAN to use a GNU tar instead ("o conf init tar") or install
+a recent Archive::Tar instead;
+
+END_WARN
+ }
+ } else {
+ my $foundtar = $exttar ? "'$exttar'" : "nothing";
+ my $foundzip = $extgzip ? "'$extgzip'" : $foundtar ? "nothing" : "also nothing";
+ my $foundAT;
+ if ($CPAN::META->has_usable("Archive::Tar")) {
+ $foundAT = sprintf "'%s'", "Archive::Tar::"->VERSION;
+ } else {
+ $foundAT = "nothing";
+ }
+ my $foundCZ;
+ if ($CPAN::META->has_inst("Compress::Zlib")) {
+ $foundCZ = sprintf "'%s'", "Compress::Zlib::"->VERSION;
+ } elsif ($foundAT) {
+ $foundCZ = "nothing";
+ } else {
+ $foundCZ = "also nothing";
+ }
+ $CPAN::Frontend->mydie(qq{
+
+CPAN.pm needs either the external programs tar and gzip -or- both
+modules Archive::Tar and Compress::Zlib installed.
+
+For tar I found $foundtar, for gzip $foundzip.
+
+For Archive::Tar I found $foundAT, for Compress::Zlib $foundCZ;
+
+Can't continue cutting file '$file'.
+});
+ }
+ my $tar_verb = "v";
+ if (defined $CPAN::Config->{tar_verbosity}) {
+ $tar_verb = $CPAN::Config->{tar_verbosity} eq "none" ? "" :
+ $CPAN::Config->{tar_verbosity};
+ }
+ if ($prefer==1) { # 1 => external gzip+tar
+ my($system);
+ my $is_compressed = $self->gtest();
+ my $tarcommand = CPAN::HandleConfig->safe_quote($exttar);
+ if ($is_compressed) {
+ my $command = CPAN::HandleConfig->safe_quote($extgzip);
+ $system = qq{$command -d -c }.
+ qq{< "$file" | $tarcommand x${tar_verb}f -};
+ } else {
+ $system = qq{$tarcommand x${tar_verb}f "$file"};
+ }
+ if (system($system) != 0) {
+ # people find the most curious tar binaries that cannot handle
+ # pipes
+ if ($is_compressed) {
+ (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
+ $ungzf = basename $ungzf;
+ my $ct = CPAN::Tarzip->new($file);
+ if ($ct->gunzip($ungzf)) {
+ $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
+ } else {
+ $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
+ }
+ $file = $ungzf;
+ }
+ $system = qq{$tarcommand x${tar_verb}f "$file"};
+ $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
+ my $ret = system($system);
+ if ($ret==0) {
+ $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
+ } else {
+ if ($? == -1) {
+ $CPAN::Frontend->mydie(sprintf qq{Couldn\'t untar %s: '%s'\n},
+ $file, $!);
+ } elsif ($? & 127) {
+ $CPAN::Frontend->mydie(sprintf qq{Couldn\'t untar %s: child died with signal %d, %s coredump\n},
+ $file, ($? & 127), ($? & 128) ? 'with' : 'without');
+ } else {
+ $CPAN::Frontend->mydie(sprintf qq{Couldn\'t untar %s: child exited with value %d\n},
+ $file, $? >> 8);
+ }
+ }
+ return 1;
+ } else {
+ return 1;
+ }
+ } elsif ($prefer==2) { # 2 => modules
+ unless ($CPAN::META->has_usable("Archive::Tar")) {
+ $CPAN::Frontend->mydie("Archive::Tar not installed, please install it to continue");
+ }
+ # Make sure AT does not use uid/gid/permissions in the archive
+ # This leaves it to the user's umask instead
+ local $Archive::Tar::CHMOD = 1;
+ local $Archive::Tar::SAME_PERMISSIONS = 0;
+ # Make sure AT leaves current user as owner
+ local $Archive::Tar::CHOWN = 0;
+ my $tar = Archive::Tar->new($file,1);
+ my $af; # archive file
+ my @af;
+ if ($BUGHUNTING) {
+ # RCS 1.337 had this code, it turned out unacceptable slow but
+ # it revealed a bug in Archive::Tar. Code is only here to hunt
+ # the bug again. It should never be enabled in published code.
+ # GDGraph3d-0.53 was an interesting case according to Larry
+ # Virden.
+ warn(">>>Bughunting code enabled<<< " x 20);
+ for $af ($tar->list_files) {
+ if ($af =~ m!^(/|\.\./)!) {
+ $CPAN::Frontend->mydie("ALERT: Archive contains ".
+ "illegal member [$af]");
+ }
+ $CPAN::Frontend->myprint("$af\n");
+ $tar->extract($af); # slow but effective for finding the bug
+ return if $CPAN::Signal;
+ }
+ } else {
+ for $af ($tar->list_files) {
+ if ($af =~ m!^(/|\.\./)!) {
+ $CPAN::Frontend->mydie("ALERT: Archive contains ".
+ "illegal member [$af]");
+ }
+ if ($tar_verb eq "v" || $tar_verb eq "vv") {
+ $CPAN::Frontend->myprint("$af\n");
+ }
+ push @af, $af;
+ return if $CPAN::Signal;
+ }
+ $tar->extract(@af) or
+ $CPAN::Frontend->mydie("Could not untar with Archive::Tar.");
+ }
+
+ Mac::BuildTools::convert_files([$tar->list_files], 1)
+ if ($^O eq 'MacOS');
+
+ return 1;
+ }
+}
+
+sub unzip {
+ my($self) = @_;
+ my $file = $self->{FILE};
+ if ($CPAN::META->has_inst("Archive::Zip")) {
+ # blueprint of the code from Archive::Zip::Tree::extractTree();
+ my $zip = Archive::Zip->new();
+ my $status;
+ $status = $zip->read($file);
+ $CPAN::Frontend->mydie("Read of file[$file] failed\n")
+ if $status != Archive::Zip::AZ_OK();
+ $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
+ my @members = $zip->members();
+ for my $member ( @members ) {
+ my $af = $member->fileName();
+ if ($af =~ m!^(/|\.\./)!) {
+ $CPAN::Frontend->mydie("ALERT: Archive contains ".
+ "illegal member [$af]");
+ }
+ $status = $member->extractToFileNamed( $af );
+ $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
+ $CPAN::Frontend->mydie("Extracting of file[$af] from zipfile[$file] failed\n") if
+ $status != Archive::Zip::AZ_OK();
+ return if $CPAN::Signal;
+ }
+ return 1;
+ } elsif ( my $unzip = $CPAN::Config->{unzip} ) {
+ my @system = ($unzip, $file);
+ return system(@system) == 0;
+ }
+ else {
+ $CPAN::Frontend->mydie(<<"END");
+
+Can't unzip '$file':
+
+You have not configured an 'unzip' program and do not have Archive::Zip
+installed. Please either install Archive::Zip or else configure 'unzip'
+by running the command 'o conf init unzip' from the CPAN shell prompt.
+
+END
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::Tarzip - internal handling of tar archives for CPAN.pm
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/URL.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/URL.pm
new file mode 100644
index 0000000000..52b42eec88
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/URL.pm
@@ -0,0 +1,31 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
+# vim: ts=4 sts=4 sw=4:
+package CPAN::URL;
+use overload '""' => "as_string", fallback => 1;
+# accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
+# planned are things like age or quality
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5";
+
+sub new {
+ my($class,%args) = @_;
+ bless {
+ %args
+ }, $class;
+}
+sub as_string {
+ my($self) = @_;
+ $self->text;
+}
+sub text {
+ my($self,$set) = @_;
+ if (defined $set) {
+ $self->{TEXT} = $set;
+ }
+ $self->{TEXT};
+}
+
+1;
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Version.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Version.pm
new file mode 100644
index 0000000000..fa75221d9d
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Version.pm
@@ -0,0 +1,177 @@
+package CPAN::Version;
+
+use strict;
+use vars qw($VERSION);
+$VERSION = "5.5003";
+
+# CPAN::Version::vcmp courtesy Jost Krieger
+sub vcmp {
+ my($self,$l,$r) = @_;
+ local($^W) = 0;
+ CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
+
+ # treat undef as zero
+ $l = 0 if $l eq 'undef';
+ $r = 0 if $r eq 'undef';
+
+ return 0 if $l eq $r; # short circuit for quicker success
+
+ for ($l,$r) {
+ s/_//g;
+ }
+ CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
+ for ($l,$r) {
+ next unless tr/.// > 1 || /^v/;
+ s/^v?/v/;
+ 1 while s/\.0+(\d)/.$1/; # remove leading zeroes per group
+ }
+ CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
+ if ($l=~/^v/ <=> $r=~/^v/) {
+ for ($l,$r) {
+ next if /^v/;
+ $_ = $self->float2vv($_);
+ }
+ }
+ CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
+ my $lvstring = "v0";
+ my $rvstring = "v0";
+ if ($] >= 5.006
+ && $l =~ /^v/
+ && $r =~ /^v/) {
+ $lvstring = $self->vstring($l);
+ $rvstring = $self->vstring($r);
+ CPAN->debug(sprintf "lv[%vd] rv[%vd]", $lvstring, $rvstring) if $CPAN::DEBUG;
+ }
+
+ return (
+ ($l ne "undef") <=> ($r ne "undef")
+ ||
+ $lvstring cmp $rvstring
+ ||
+ $l <=> $r
+ ||
+ $l cmp $r
+ );
+}
+
+sub vgt {
+ my($self,$l,$r) = @_;
+ $self->vcmp($l,$r) > 0;
+}
+
+sub vlt {
+ my($self,$l,$r) = @_;
+ $self->vcmp($l,$r) < 0;
+}
+
+sub vge {
+ my($self,$l,$r) = @_;
+ $self->vcmp($l,$r) >= 0;
+}
+
+sub vle {
+ my($self,$l,$r) = @_;
+ $self->vcmp($l,$r) <= 0;
+}
+
+sub vstring {
+ my($self,$n) = @_;
+ $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
+ pack "U*", split /\./, $n;
+}
+
+# vv => visible vstring
+sub float2vv {
+ my($self,$n) = @_;
+ my($rev) = int($n);
+ $rev ||= 0;
+ my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
+ # architecture influence
+ $mantissa ||= 0;
+ $mantissa .= "0" while length($mantissa)%3;
+ my $ret = "v" . $rev;
+ while ($mantissa) {
+ $mantissa =~ s/(\d{1,3})// or
+ die "Panic: length>0 but not a digit? mantissa[$mantissa]";
+ $ret .= ".".int($1);
+ }
+ # warn "n[$n]ret[$ret]";
+ $ret =~ s/(\.0)+/.0/; # v1.0.0 => v1.0
+ $ret;
+}
+
+sub readable {
+ my($self,$n) = @_;
+ $n =~ /^([\w\-\+\.]+)/;
+
+ return $1 if defined $1 && length($1)>0;
+ # if the first user reaches version v43, he will be treated as "+".
+ # We'll have to decide about a new rule here then, depending on what
+ # will be the prevailing versioning behavior then.
+
+ if ($] < 5.006) { # or whenever v-strings were introduced
+ # we get them wrong anyway, whatever we do, because 5.005 will
+ # have already interpreted 0.2.4 to be "0.24". So even if he
+ # indexer sends us something like "v0.2.4" we compare wrongly.
+
+ # And if they say v1.2, then the old perl takes it as "v12"
+
+ if (defined $CPAN::Frontend) {
+ $CPAN::Frontend->mywarn("Suspicious version string seen [$n]\n");
+ } else {
+ warn("Suspicious version string seen [$n]\n");
+ }
+ return $n;
+ }
+ my $better = sprintf "v%vd", $n;
+ CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
+ return $better;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::Version - utility functions to compare CPAN versions
+
+=head1 SYNOPSIS
+
+ use CPAN::Version;
+
+ CPAN::Version->vgt("1.1","1.1.1"); # 1 bc. 1.1 > 1.001001
+
+ CPAN::Version->vlt("1.1","1.1"); # 0 bc. 1.1 not < 1.1
+
+ CPAN::Version->vcmp("1.1","1.1.1"); # 1 bc. first is larger
+
+ CPAN::Version->vcmp("1.1.1","1.1"); # -1 bc. first is smaller
+
+ CPAN::Version->readable(v1.2.3); # "v1.2.3"
+
+ CPAN::Version->vstring("v1.2.3"); # v1.2.3
+
+ CPAN::Version->float2vv(1.002003); # "v1.2.3"
+
+=head1 DESCRIPTION
+
+This module mediates between some version that perl sees in a package
+and the version that is published by the CPAN indexer.
+
+It's only written as a helper module for both CPAN.pm and CPANPLUS.pm.
+
+As it stands it predates version.pm but has the same goal: make
+version strings visible and comparable.
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# End: