From e0c6872cf40896c7be36b11dcc744620f10adf1d Mon Sep 17 00:00:00 2001 From: Norbert Preining Date: Mon, 2 Sep 2019 13:46:59 +0900 Subject: Initial commit --- .../tlnet/tlpkg/tlperl/lib/CPAN/API/HOWTO.pod | 44 + .../texlive/tlnet/tlpkg/tlperl/lib/CPAN/Author.pm | 236 ++ .../texlive/tlnet/tlpkg/tlperl/lib/CPAN/Bundle.pm | 300 ++ .../tlnet/tlpkg/tlperl/lib/CPAN/CacheMgr.pm | 249 ++ .../tlnet/tlpkg/tlperl/lib/CPAN/Complete.pm | 175 + .../texlive/tlnet/tlpkg/tlperl/lib/CPAN/Debug.pm | 83 + .../tlnet/tlpkg/tlperl/lib/CPAN/DeferredCode.pm | 16 + .../tlnet/tlpkg/tlperl/lib/CPAN/Distribution.pm | 4476 ++++++++++++++++++++ .../tlnet/tlpkg/tlperl/lib/CPAN/Distroprefs.pm | 481 +++ .../tlnet/tlpkg/tlperl/lib/CPAN/Distrostatus.pm | 45 + .../lib/CPAN/Exception/RecursiveDependency.pm | 113 + .../tlperl/lib/CPAN/Exception/blocked_urllist.pm | 46 + .../lib/CPAN/Exception/yaml_not_installed.pm | 23 + .../lib/CPAN/Exception/yaml_process_error.pm | 53 + systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/FTP.pm | 1146 +++++ .../tlnet/tlpkg/tlperl/lib/CPAN/FTP/netrc.pm | 62 + .../tlnet/tlpkg/tlperl/lib/CPAN/FirstTime.pm | 2117 +++++++++ .../tlnet/tlpkg/tlperl/lib/CPAN/HTTP/Client.pm | 254 ++ .../tlpkg/tlperl/lib/CPAN/HTTP/Credentials.pm | 91 + .../tlnet/tlpkg/tlperl/lib/CPAN/HandleConfig.pm | 800 ++++ .../texlive/tlnet/tlpkg/tlperl/lib/CPAN/Index.pm | 626 +++ .../texlive/tlnet/tlpkg/tlperl/lib/CPAN/InfoObj.pm | 224 + .../texlive/tlnet/tlpkg/tlperl/lib/CPAN/Kwalify.pm | 136 + .../tlpkg/tlperl/lib/CPAN/Kwalify/distroprefs.dd | 150 + .../tlpkg/tlperl/lib/CPAN/Kwalify/distroprefs.yml | 92 + .../tlnet/tlpkg/tlperl/lib/CPAN/LWP/UserAgent.pm | 62 + .../texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta.pm | 1176 +++++ .../tlnet/tlpkg/tlperl/lib/CPAN/Meta/Converter.pm | 1657 ++++++++ .../tlnet/tlpkg/tlperl/lib/CPAN/Meta/Feature.pm | 153 + .../tlnet/tlpkg/tlperl/lib/CPAN/Meta/History.pm | 320 ++ .../tlperl/lib/CPAN/Meta/History/Meta_1_0.pod | 247 ++ .../tlperl/lib/CPAN/Meta/History/Meta_1_1.pod | 309 ++ .../tlperl/lib/CPAN/Meta/History/Meta_1_2.pod | 712 ++++ .../tlperl/lib/CPAN/Meta/History/Meta_1_3.pod | 741 ++++ .../tlperl/lib/CPAN/Meta/History/Meta_1_4.pod | 765 ++++ .../tlnet/tlpkg/tlperl/lib/CPAN/Meta/Merge.pm | 351 ++ .../tlnet/tlpkg/tlperl/lib/CPAN/Meta/Prereqs.pm | 481 +++ .../tlpkg/tlperl/lib/CPAN/Meta/Requirements.pm | 1194 ++++++ .../tlnet/tlpkg/tlperl/lib/CPAN/Meta/Spec.pm | 1244 ++++++ .../tlnet/tlpkg/tlperl/lib/CPAN/Meta/Validator.pm | 1214 ++++++ .../tlnet/tlpkg/tlperl/lib/CPAN/Meta/YAML.pm | 951 +++++ .../texlive/tlnet/tlpkg/tlperl/lib/CPAN/Mirrors.pm | 589 +++ .../texlive/tlnet/tlpkg/tlperl/lib/CPAN/Module.pm | 702 +++ systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Nox.pm | 52 + .../texlive/tlnet/tlpkg/tlperl/lib/CPAN/Plugin.pm | 145 + .../tlnet/tlpkg/tlperl/lib/CPAN/Plugin/Specfile.pm | 258 ++ .../texlive/tlnet/tlpkg/tlperl/lib/CPAN/Prompt.pm | 29 + .../texlive/tlnet/tlpkg/tlperl/lib/CPAN/Queue.pm | 223 + .../texlive/tlnet/tlpkg/tlperl/lib/CPAN/Shell.pm | 2071 +++++++++ .../texlive/tlnet/tlpkg/tlperl/lib/CPAN/Tarzip.pm | 474 +++ systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/URL.pm | 31 + .../texlive/tlnet/tlpkg/tlperl/lib/CPAN/Version.pm | 177 + 52 files changed, 28366 insertions(+) create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/API/HOWTO.pod create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Author.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Bundle.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/CacheMgr.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Complete.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Debug.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/DeferredCode.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Distribution.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Distroprefs.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Distrostatus.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Exception/RecursiveDependency.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Exception/blocked_urllist.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Exception/yaml_not_installed.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Exception/yaml_process_error.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/FTP.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/FTP/netrc.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/FirstTime.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/HTTP/Client.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/HTTP/Credentials.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/HandleConfig.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Index.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/InfoObj.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Kwalify.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Kwalify/distroprefs.dd create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Kwalify/distroprefs.yml create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/LWP/UserAgent.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Converter.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Feature.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_0.pod create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_1.pod create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_2.pod create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_3.pod create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/History/Meta_1_4.pod create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Merge.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Prereqs.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Requirements.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Spec.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/Validator.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Meta/YAML.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Mirrors.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Module.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Nox.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Plugin.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Plugin/Specfile.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Prompt.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Queue.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Shell.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Tarzip.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/URL.pm create mode 100644 systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN/Version.pm (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/CPAN') 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 + +=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(<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 () { + 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 " +}); + 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 $/; + ; + }; + 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 () { + $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 () { + $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_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 = ; + 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 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 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 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, indicating that no prefs files remain to be found + +=back + +=head1 RESULTS + +L|/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, C, or C + +=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 results from C. + +=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) + +currently: C + +=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 (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" 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 $/; + }; + if ($content =~ /^<.*([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: -- cgit v1.2.3