summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/CPAN
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 12:20:49 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 12:20:49 +0000
commit316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch)
treecb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl/lib/CPAN
parentcd0f87b5d39480d85ad9bd4ee37f520f75bed560 (diff)
Moving old tlperl prior to committing new one
git-svn-id: svn://tug.org/texlive/trunk@21422 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPAN')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/API/HOWTO.pod44
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Admin.pm230
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Author.pm236
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Bundle.pm287
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/CacheMgr.pm246
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Checksums.pm432
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Complete.pm175
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Config.pm87
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Debug.pm79
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/DeferredCode.pm16
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/DistnameInfo.pm194
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Distribution.pm3879
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Distroprefs.pm451
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Distrostatus.pm45
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Exception/RecursiveDependency.pm85
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Exception/blocked_urllist.pm46
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Exception/yaml_not_installed.pm73
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/FTP.pm1074
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/FTP/netrc.pm63
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/FirstTime.pm1797
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/HandleConfig.pm735
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Index.pm619
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/InfoObj.pm224
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Inject.pm514
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Kwalify.pm136
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Kwalify/distroprefs.dd150
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Kwalify/distroprefs.yml92
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/LWP/UserAgent.pm135
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Mirrors.pm260
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Module.pm688
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Nox.pm51
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Prompt.pm29
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Queue.pm198
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/SQLite.pm323
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/SQLite/DBI.pm169
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/SQLite/DBI/Index.pm237
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/SQLite/DBI/Search.pm283
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/SQLite/Index.pm264
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/SQLite/Info.pm338
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/SQLite/META.pm480
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/SQLite/Populate.pm958
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/SQLite/Search.pm520
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/SQLite/State.pm410
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/SQLite/Util.pm367
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Shell.pm1974
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Tarzip.pm442
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/URL.pm31
-rwxr-xr-xMaster/tlpkg/tlperl/lib/CPAN/Version.pm173
48 files changed, 0 insertions, 20339 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPAN/API/HOWTO.pod b/Master/tlpkg/tlperl/lib/CPAN/API/HOWTO.pod
deleted file mode 100755
index e65a4bc9313..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/API/HOWTO.pod
+++ /dev/null
@@ -1,44 +0,0 @@
-=head1 NAME
-
-CPAN::API::HOWTO - a recipe book for programming with CPAN.pm
-
-=head1 RECIPES
-
-All of these recipes assume that you have put "use CPAN" at the top of
-your program.
-
-=head2 What distribution contains a particular module?
-
- my $distribution = CPAN::Shell->expand(
- "Module", "Data::UUID"
- )->distribution()->pretty_id();
-
-This returns a string of the form "AUTHORID/TARBALL". If you want the
-full path and filename to this distribution on a CPAN mirror, then it is
-C<.../authors/id/A/AU/AUTHORID/TARBALL>.
-
-=head2 What modules does a particular distribution contain?
-
- CPAN::Index->reload();
- my @modules = CPAN::Shell->expand(
- "Distribution", "JHI/Graph-0.83.tar.gz"
- )->containsmods();
-
-You may also refer to a distribution in the form A/AU/AUTHORID/TARBALL.
-
-=head1 SEE ALSO
-
-the main CPAN.pm documentation
-
-=head1 LICENSE
-
-This program is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-See L<http://www.perl.com/perl/misc/Artistic.html>
-
-=head1 AUTHOR
-
-David Cantrell
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Admin.pm b/Master/tlpkg/tlperl/lib/CPAN/Admin.pm
deleted file mode 100755
index de8d7001840..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Admin.pm
+++ /dev/null
@@ -1,230 +0,0 @@
-package CPAN::Admin;
-use base CPAN;
-use CPAN; # old base.pm did not load CPAN on previous line
-use strict;
-use vars qw(@EXPORT $VERSION);
-use constant PAUSE_IP => "pause.perl.org";
-
-@EXPORT = qw(shell);
-$VERSION = "5.5";
-push @CPAN::Complete::COMMANDS, qw(register modsearch);
-$CPAN::Shell::COLOR_REGISTERED = 1;
-
-sub shell {
- CPAN::shell($_[0]||"admin's cpan> ",$_[1]);
-}
-
-sub CPAN::Shell::register {
- my($self,$mod,@rest) = @_;
- unless ($mod) {
- print "register called without argument\n";
- return;
- }
- if ($CPAN::META->has_inst("URI::Escape")) {
- require URI::Escape;
- } else {
- print "register requires URI::Escape installed, otherwise it cannot work\n";
- return;
- }
- print "Got request for mod[$mod]\n";
- if (@rest) {
- my $modline = join " ", $mod, @rest;
- print "Sending to PAUSE [$modline]\n";
- my $emodline = URI::Escape::uri_escape($modline, '^\w ');
- $emodline =~ s/ /+/g;
- my $url =
- sprintf("https://%s/pause/authenquery?pause99_add_mod_modid=".
- "%s;SUBMIT_pause99_add_mod_hint=hint",
- PAUSE_IP,
- $emodline,
- );
- print "url[$url]\n\n";
- print ">>>>Trying to open a netscape window<<<<\n";
- sleep 1;
- system("netscape","-remote","openURL($url)");
- return;
- }
- my $m = CPAN::Shell->expand("Module",$mod);
- unless (ref $m) {
- print "Could not determine the object for $mod\n";
- return;
- }
- my $id = $m->id;
- print "Found module id[$id] in database\n";
-
- if (exists $m->{RO} && $m->{RO}{chapterid}) {
- print "$id is already registered\n";
- return;
- }
-
- my(@namespace) = split /::/, $id;
- my $rootns = $namespace[0];
-
- # Tk, XML and Apache need special treatment
- if ($rootns=~/^(Bundle)\b/) {
- print "Bundles are not yet ready for registering\n";
- return;
- }
-
- # make a good suggestion for the chapter
- my(@simile) = CPAN::Shell->expand("Module","/^$rootns(:|\$)/");
- print "Found within this namespace ", join(", ", map { $_->id } @simile), "\n";
- my(%seench);
- for my $ch (map { exists $_->{RO} ? $_->{RO}{chapterid} : ""} @simile) {
- next unless $ch;
- $seench{$ch}=undef;
- }
- my(@seench) = sort grep {length($_)} keys %seench;
- my $reco_ch = "";
- if (@seench>1) {
- print "Found rootnamespace[$rootns] in the chapters [", join(", ", @seench), "]\n";
- $reco_ch = $seench[0];
- print "Picking $reco_ch\n";
- } elsif (@seench==1) {
- print "Found rootnamespace[$rootns] in the chapter[$seench[0]]\n";
- $reco_ch = $seench[0];
- } else {
- print "The new rootnamespace[$rootns] needs to be introduced. Oh well.\n";
- }
-
- # Look closer at the dist
- my $d = CPAN::Shell->expand("Distribution", $m->cpan_file);
- printf "Module comes with dist[%s]\n", $d->id;
- for my $contm ($d->containsmods) {
- if ($CPAN::META->exists("CPAN::Module",$contm)) {
- my $contm_obj = CPAN::Shell->expand("Module",$contm) or next;
- my $is_reg = exists $contm_obj->{RO} && $contm_obj->{RO}{description};
- printf(" in same dist: %s%s\n",
- $contm,
- $is_reg ? " already in modulelist" : "",
- );
- }
- }
-
- # get it so that m is better and we can inspect for XS
- CPAN::Shell->get($id);
- CPAN::Shell->m($id);
- CPAN::Shell->d($d->id);
-
- my $has_xs = 0;
- {
- my($mani,@mani);
- local $/ = "\n";
- open $mani, "$d->{build_dir}/MANIFEST" and @mani = <$mani>;
- my @xs = grep /\.xs\b/, @mani;
- if (@xs) {
- print "Found XS files: @xs";
- $has_xs=1;
- }
- }
- my $emodid = URI::Escape::uri_escape($id, '\W');
- my $ech = $reco_ch;
- $ech =~ s/ /+/g;
- my $description = $m->{MANPAGE} || "";
- $description =~ s/[A-Z]<//; # POD markup (and maybe more)
- $description =~ s/^\s+//; # leading spaces
- $description =~ s/>//; # POD
- $description =~ s/^\Q$id\E//; # usually this line starts with the modid
- $description =~ s/^[ \-]+//; # leading spaces and dashes
- substr($description,44) = "" if length($description)>44;
- $description = ucfirst($description);
- my $edescription = URI::Escape::uri_escape($description, '^\w ');
- $edescription =~ s/ /+/g;
- my $url =
- sprintf("https://%s/pause/authenquery?pause99_add_mod_modid=".
- "%s;pause99_add_mod_chapterid=%s;pause99_add_mod_statd=%s;".
- "pause99_add_mod_stats=%s;pause99_add_mod_statl=%s;".
- "pause99_add_mod_stati=%s;pause99_add_mod_description=%s;".
- "pause99_add_mod_userid=%s;SUBMIT_pause99_add_mod_preview=preview",
- PAUSE_IP,
- $emodid,
- $ech,
- "R",
- "d",
- $has_xs ? "c" : "p",
- "O",
- $edescription,
- $m->{RO}{CPAN_USERID},
- );
- print "$url\n\n";
- print ">>>>Trying to open a netscape window<<<<\n";
- system("netscape","-remote","openURL($url)");
-}
-
-sub CPAN::Shell::modsearch {
- my($self,@line) = @_;
- unless (@line) {
- print "modsearch called without argument\n";
- return;
- }
- my $request = join " ", @line;
- print "Got request[$request]\n";
- my $erequest = URI::Escape::uri_escape($request, '^\w ');
- $erequest =~ s/ /+/g;
- my $url =
- sprintf("http://www.xray.mpe.mpg.de/cgi-bin/w3glimpse/modules?query=%s".
- "&errors=0&case=on&maxfiles=100&maxlines=30",
- $erequest,
- );
- print "$url\n\n";
- print ">>>>Trying to open a netscape window<<<<\n";
- system("netscape","-remote","openURL('$url')");
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
- CPAN::Admin - A CPAN Shell for CPAN admins
-
-=head1 SYNOPSIS
-
- perl -MCPAN::Admin -e shell
-
-=head1 STATUS
-
-Note: this module is currently not maintained. If you need it and fix
-it for your needs, please submit patches.
-
-=head1 DESCRIPTION
-
-CPAN::Admin is a subclass of CPAN that adds the commands C<register>
-and C<modsearch> to the CPAN shell.
-
-C<register> calls C<get> on the named module, assembles a couple of
-informations (description, language), and calls Netscape with the
--remote argument so that a form is filled with all the assembled
-informations and the registration can be performed with a single
-click. If the command line has more than one argument, register does
-not run a C<get>, instead it interprets the rest of the line as DSLI
-status, description, and userid and sends them to netscape such that
-the form is again mostly filled and can be edited or confirmed with a
-single click. CPAN::Admin never performs the submission click for you,
-it is only intended to fill in the form on PAUSE and leave the
-confirmation to you.
-
-C<modsearch> simply passes the arguments to the search engine for the
-modules@perl.org mailing list at http://www.xray.mpe.mpg.de where all
-registration requests are stored. It does so in the same way as
-register, namely with the C<netscape -remote> command.
-
-An experimental feature has also been added, namely to color already
-registered modules in listings. If you have Term::ANSIColor installed,
-the u, r, and m commands will show already registered modules in
-green.
-
-=head1 PREREQISITES
-
-URI::Escape, netscape browser available in the path, netscape must
-understand the -remote switch (as far as I know, this is only
-available on UNIX); coloring of registered modules is only available
-if Term::ANSIColor is installed.
-
-=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/Master/tlpkg/tlperl/lib/CPAN/Author.pm b/Master/tlpkg/tlperl/lib/CPAN/Author.pm
deleted file mode 100755
index e9e9226be5d..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Author.pm
+++ /dev/null
@@ -1,236 +0,0 @@
-# -*- 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.5";
-
-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, wy 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/Master/tlpkg/tlperl/lib/CPAN/Bundle.pm b/Master/tlpkg/tlperl/lib/CPAN/Bundle.pm
deleted file mode 100755
index e7360f80485..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Bundle.pm
+++ /dev/null
@@ -1,287 +0,0 @@
-# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
-# vim: ts=4 sts=4 sw=4:
-package CPAN::Bundle;
-use strict;
-use CPAN::Module;
-@CPAN::Bundle::ISA = qw(CPAN::Module);
-
-use vars qw(
- $VERSION
-);
-$VERSION = "5.5";
-
-sub look {
- my $self = shift;
- $CPAN::Frontend->myprint($self->as_string);
-}
-
-#-> CPAN::Bundle::undelay
-sub undelay {
- my $self = shift;
- delete $self->{later};
- for my $c ( $self->contains ) {
- my $obj = CPAN::Shell->expandany($c) or next;
- $obj->undelay;
- }
-}
-
-# mark as dirty/clean
-#-> sub CPAN::Bundle::color_cmd_tmps ;
-sub color_cmd_tmps {
- my($self) = shift;
- my($depth) = shift || 0;
- my($color) = shift || 0;
- my($ancestors) = shift || [];
- # a module needs to recurse to its cpan_file, a distribution needs
- # to recurse into its prereq_pms, a bundle needs to recurse into its modules
-
- return if exists $self->{incommandcolor}
- && $color==1
- && $self->{incommandcolor}==$color;
- if ($depth>=$CPAN::MAX_RECURSION) {
- die(CPAN::Exception::RecursiveDependency->new($ancestors));
- }
- # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
-
- for my $c ( $self->contains ) {
- my $obj = CPAN::Shell->expandany($c) or next;
- CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
- $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
- }
- # never reached code?
- #if ($color==0) {
- #delete $self->{badtestcnt};
- #}
- $self->{incommandcolor} = $color;
-}
-
-#-> sub CPAN::Bundle::as_string ;
-sub as_string {
- my($self) = @_;
- $self->contains;
- # following line must be "=", not "||=" because we have a moving target
- $self->{INST_VERSION} = $self->inst_version;
- return $self->SUPER::as_string;
-}
-
-#-> sub CPAN::Bundle::contains ;
-sub contains {
- my($self) = @_;
- my($inst_file) = $self->inst_file || "";
- my($id) = $self->id;
- $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
- if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
- undef $inst_file;
- }
- unless ($inst_file) {
- # Try to get at it in the cpan directory
- $self->debug("no inst_file") if $CPAN::DEBUG;
- my $cpan_file;
- $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
- $cpan_file = $self->cpan_file;
- if ($cpan_file eq "N/A") {
- $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
- Maybe stale symlink? Maybe removed during session? Giving up.\n");
- }
- my $dist = $CPAN::META->instance('CPAN::Distribution',
- $self->cpan_file);
- $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
- $dist->get;
- $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
- my($todir) = $CPAN::Config->{'cpan_home'};
- my(@me,$from,$to,$me);
- @me = split /::/, $self->id;
- $me[-1] .= ".pm";
- $me = File::Spec->catfile(@me);
- $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
- $to = File::Spec->catfile($todir,$me);
- File::Path::mkpath(File::Basename::dirname($to));
- File::Copy::copy($from, $to)
- or Carp::confess("Couldn't copy $from to $to: $!");
- $inst_file = $to;
- }
- my @result;
- my $fh = FileHandle->new;
- local $/ = "\n";
- open($fh,$inst_file) or die "Could not open '$inst_file': $!";
- my $in_cont = 0;
- $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
- while (<$fh>) {
- $in_cont = m/^=(?!head1\s+(?i-xsm:CONTENTS))/ ? 0 :
- m/^=head1\s+(?i-xsm:CONTENTS)/ ? 1 : $in_cont;
- next unless $in_cont;
- next if /^=/;
- s/\#.*//;
- next if /^\s+$/;
- chomp;
- push @result, (split " ", $_, 2)[0];
- }
- close $fh;
- delete $self->{STATUS};
- $self->{CONTAINS} = \@result;
- $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
- unless (@result) {
- $CPAN::Frontend->mywarn(qq{
-The bundle file "$inst_file" may be a broken
-bundlefile. It seems not to contain any bundle definition.
-Please check the file and if it is bogus, please delete it.
-Sorry for the inconvenience.
-});
- }
- @result;
-}
-
-#-> sub CPAN::Bundle::find_bundle_file
-# $where is in local format, $what is in unix format
-sub find_bundle_file {
- my($self,$where,$what) = @_;
- $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
-### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
-### my $bu = File::Spec->catfile($where,$what);
-### return $bu if -f $bu;
- my $manifest = File::Spec->catfile($where,"MANIFEST");
- unless (-f $manifest) {
- require ExtUtils::Manifest;
- my $cwd = CPAN::anycwd();
- $self->safe_chdir($where);
- ExtUtils::Manifest::mkmanifest();
- $self->safe_chdir($cwd);
- }
- my $fh = FileHandle->new($manifest)
- or Carp::croak("Couldn't open $manifest: $!");
- local($/) = "\n";
- my $bundle_filename = $what;
- $bundle_filename =~ s|Bundle.*/||;
- my $bundle_unixpath;
- while (<$fh>) {
- next if /^\s*\#/;
- my($file) = /(\S+)/;
- if ($file =~ m|\Q$what\E$|) {
- $bundle_unixpath = $file;
- # return File::Spec->catfile($where,$bundle_unixpath); # bad
- last;
- }
- # retry if she managed to have no Bundle directory
- $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
- }
- return File::Spec->catfile($where, split /\//, $bundle_unixpath)
- if $bundle_unixpath;
- Carp::croak("Couldn't find a Bundle file in $where");
-}
-
-# needs to work quite differently from Module::inst_file because of
-# cpan_home/Bundle/ directory and the possibility that we have
-# shadowing effect. As it makes no sense to take the first in @INC for
-# Bundles, we parse them all for $VERSION and take the newest.
-
-#-> sub CPAN::Bundle::inst_file ;
-sub inst_file {
- my($self) = @_;
- my($inst_file);
- my(@me);
- @me = split /::/, $self->id;
- $me[-1] .= ".pm";
- my($incdir,$bestv);
- foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
- my $parsefile = File::Spec->catfile($incdir, @me);
- CPAN->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
- next unless -f $parsefile;
- my $have = eval { MM->parse_version($parsefile); };
- if ($@) {
- $CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n");
- }
- if (!$bestv || CPAN::Version->vgt($have,$bestv)) {
- $self->{INST_FILE} = $parsefile;
- $self->{INST_VERSION} = $bestv = $have;
- }
- }
- $self->{INST_FILE};
-}
-
-#-> sub CPAN::Bundle::inst_version ;
-sub inst_version {
- my($self) = @_;
- $self->inst_file; # finds INST_VERSION as side effect
- $self->{INST_VERSION};
-}
-
-#-> sub CPAN::Bundle::rematein ;
-sub rematein {
- my($self,$meth) = @_;
- $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
- my($id) = $self->id;
- Carp::croak( "Can't $meth $id, don't have an associated bundle file. :-(\n" )
- unless $self->inst_file || $self->cpan_file;
- my($s,%fail);
- for $s ($self->contains) {
- my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
- $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
- if ($type eq 'CPAN::Distribution') {
- $CPAN::Frontend->mywarn(qq{
-The Bundle }.$self->id.qq{ contains
-explicitly a file '$s'.
-Going to $meth that.
-});
- $CPAN::Frontend->mysleep(5);
- }
- # possibly noisy action:
- $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
- my $obj = $CPAN::META->instance($type,$s);
- $obj->{reqtype} = $self->{reqtype};
- $obj->$meth();
- }
-}
-
-# If a bundle contains another that contains an xs_file we have here,
-# we just don't bother I suppose
-#-> sub CPAN::Bundle::xs_file
-sub xs_file {
- return 0;
-}
-
-#-> sub CPAN::Bundle::force ;
-sub fforce { shift->rematein('fforce',@_); }
-#-> sub CPAN::Bundle::force ;
-sub force { shift->rematein('force',@_); }
-#-> sub CPAN::Bundle::notest ;
-sub notest { shift->rematein('notest',@_); }
-#-> sub CPAN::Bundle::get ;
-sub get { shift->rematein('get',@_); }
-#-> sub CPAN::Bundle::make ;
-sub make { shift->rematein('make',@_); }
-#-> sub CPAN::Bundle::test ;
-sub test {
- my $self = shift;
- # $self->{badtestcnt} ||= 0;
- $self->rematein('test',@_);
-}
-#-> sub CPAN::Bundle::install ;
-sub install {
- my $self = shift;
- $self->rematein('install',@_);
-}
-#-> sub CPAN::Bundle::clean ;
-sub clean { shift->rematein('clean',@_); }
-
-#-> sub CPAN::Bundle::uptodate ;
-sub uptodate {
- my($self) = @_;
- return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
- my $c;
- foreach $c ($self->contains) {
- my $obj = CPAN::Shell->expandany($c);
- return 0 unless $obj->uptodate;
- }
- return 1;
-}
-
-#-> sub CPAN::Bundle::readme ;
-sub readme {
- my($self) = @_;
- my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
-No File found for bundle } . $self->id . qq{\n}), return;
- $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
- $CPAN::META->instance('CPAN::Distribution',$file)->readme;
-}
-
-1;
diff --git a/Master/tlpkg/tlperl/lib/CPAN/CacheMgr.pm b/Master/tlpkg/tlperl/lib/CPAN/CacheMgr.pm
deleted file mode 100755
index 827baeaefdb..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/CacheMgr.pm
+++ /dev/null
@@ -1,246 +0,0 @@
-# -*- 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.5";
-
-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;
- }
-}
-
-#-> 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, otherise 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 = shift;
- 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
- };
- File::Path::mkpath($self->{ID});
- my $dh = DirHandle->new($self->{ID});
- bless $self, $class;
- $self->scan_cache;
- $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 = shift;
- return if $self->{SCAN} eq 'never';
- $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
- unless $self->{SCAN} eq 'atstart';
- 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/Master/tlpkg/tlperl/lib/CPAN/Checksums.pm b/Master/tlpkg/tlperl/lib/CPAN/Checksums.pm
deleted file mode 100755
index 9f8e779cd2a..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Checksums.pm
+++ /dev/null
@@ -1,432 +0,0 @@
-package CPAN::Checksums;
-
-use strict;
-use vars qw(
- $CAUTION
- $DIRNAME
- $IGNORE_MATCH
- $MIN_MTIME_CHECKSUMS
- $SIGNING_KEY
- $SIGNING_PROGRAM
- $TRY_SHORTNAME
- $VERSION
- @EXPORT_OK
- @ISA
- );
-
-require Exporter;
-
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(updatedir);
-$VERSION = "2.05";
-$VERSION =~ s/_//;
-$CAUTION ||= 0;
-$TRY_SHORTNAME ||= 0;
-$SIGNING_PROGRAM ||= 'gpg --clearsign --default-key ';
-$SIGNING_KEY ||= '';
-$MIN_MTIME_CHECKSUMS ||= 0;
-$IGNORE_MATCH = qr{(?i-xsm:readme$)};
-
-use DirHandle ();
-use IO::File ();
-use Digest::MD5 ();
-use Compress::Bzip2();
-use Compress::Zlib ();
-use File::Spec ();
-use File::Temp;
-use Data::Dumper ();
-use Data::Compare ();
-use Digest::SHA ();
-
-sub _dir_to_dref {
- my($dirname,$old_dref) = @_;
- my($dref) = {};
- my($dh)= DirHandle->new;
- my($fh) = new IO::File;
- $dh->open($dirname) or die "Couldn't opendir $dirname\: $!";
- my(%shortnameseen);
- DIRENT: for my $de ($dh->read) {
- next if $de =~ /^\./;
- next if substr($de,0,9) eq "CHECKSUMS";
- next if $IGNORE_MATCH && $de =~ $IGNORE_MATCH;
-
- my $abs = File::Spec->catfile($dirname,$de);
-
- #
- # SHORTNAME offers an 8.3 name, probably not needed but it was
- # always there,,,
- #
- if ($TRY_SHORTNAME) {
- my $shortname = lc $de;
- $shortname =~ s/\.tar[._-]gz$/\.tgz/;
- my $suffix;
- ($suffix = $shortname) =~ s/.*\.//;
- substr($suffix,3) = "" if length($suffix) > 3;
- my @p;
- if ($shortname =~ /\-/) {
- @p = $shortname =~ /(.{1,16})-.*?([\d\.]{2,8})/;
- } else {
- @p = $shortname =~ /(.{1,8}).*?([\d\.]{2,8})/;
- }
- $p[0] ||= lc $de;
- $p[0] =~ s/[^a-z0-9]//g;
- $p[1] ||= 0;
- $p[1] =~ s/\D//g;
- my $counter = 7;
- while (length($p[0]) + length($p[1]) > 8) {
- substr($p[0], $counter) = "" if length($p[0]) > $counter;
- substr($p[1], $counter) = "" if length($p[1]) > $counter--;
- }
- my $dot = $suffix ? "." : "";
- $shortname = "$p[0]$p[1]$dot$suffix";
- while (exists $shortnameseen{$shortname}) {
- my($modi) = $shortname =~ /([a-z\d]+)/;
- $modi++;
- $shortname = "$modi$dot$suffix";
- if (++$counter > 1000){ # avoid endless loops and accept the buggy choice
- warn "Warning: long loop on shortname[$shortname]de[$de]";
- last;
- }
- }
- $dref->{$de}->{shortname} = $shortname;
- $shortnameseen{$shortname} = undef; # for exists check good enough
- }
-
- #
- # STAT facts
- #
- if (-l File::Spec->catdir($dirname,$de)){
- # Symlinks are a mess on a replicated, database driven system,
- # but as they are not forbidden, we cannot ignore them. We do
- # have a directory with nothing but a symlink in it. When we
- # ignored the symlink, we did not write a CHECKSUMS file and
- # CPAN.pm issued lots of warnings:-(
- $dref->{$de}{issymlink} = 1;
- }
- if (-d File::Spec->catdir($dirname,$de)){
- $dref->{$de}{isdir} = 1;
- } else {
- my @stat = stat $abs or next DIRENT;
- $dref->{$de}{size} = $stat[7];
- my(@gmtime) = gmtime $stat[9];
- $gmtime[4]++;
- $gmtime[5]+=1900;
- $dref->{$de}{mtime} = sprintf "%04d-%02d-%02d", @gmtime[5,4,3];
- _add_digests($de,$dref,"Digest::SHA",[256],"sha256",$abs,$old_dref);
- my $can_reuse_old_md5 = 1;
- COMPARE: for my $param (qw(size mtime sha256)) {
- if (!exists $old_dref->{$de}{$param} ||
- $dref->{$de}{$param} ne $old_dref->{$de}{$param}) {
- $can_reuse_old_md5 = 0;
- last COMPARE;
- }
- }
- if ( $can_reuse_old_md5 ) {
- for my $param (qw(md5 md5-ungz md5-unbz2)) {
- next unless exists $old_dref->{$de}{$param};
- $dref->{$de}{$param} = $old_dref->{$de}{$param};
- }
- } else {
- _add_digests($de,$dref,"Digest::MD5",[],"md5",$abs,$old_dref);
- }
-
- } # ! -d
- }
- $dh->close;
- $dref;
-}
-
-sub _read_old_ddump {
- my($ckfn) = @_;
- my $is_signed = 0;
- my($fh) = new IO::File;
- my $old_ddump = "";
- if ($fh->open($ckfn)) {
- local $/ = "\n";
- while (<$fh>) {
- next if /^\#/;
- $is_signed = 1 if /SIGNED MESSAGE/;
- $old_ddump .= $_;
- }
- close $fh;
- }
- return($old_ddump,$is_signed);
-}
-
-sub updatedir ($) {
- my($dirname) = @_;
- my $ckfn = File::Spec->catfile($dirname, "CHECKSUMS"); # checksum-file-name
- my($old_ddump,$is_signed) = _read_old_ddump($ckfn);
- my($old_dref) = makehashref($old_ddump);
- my $dref = _dir_to_dref($dirname,$old_dref);
- local $Data::Dumper::Indent = 1;
- local $Data::Dumper::Quotekeys = 1;
- local $Data::Dumper::Sortkeys = 1;
- my $ddump = Data::Dumper->new([$dref],["cksum"])->Dump;
- my @ckfnstat = stat $ckfn;
- if ($old_ddump) {
- local $DIRNAME = $dirname;
- if ( !!$SIGNING_KEY == !!$is_signed ) { # either both or neither
- if (!$MIN_MTIME_CHECKSUMS || $ckfnstat[9] > $MIN_MTIME_CHECKSUMS ) {
- # recent enough
- return 1 if $old_ddump eq $ddump;
- return 1 if ckcmp($old_dref,$dref);
- }
- }
- if ($CAUTION) {
- my $report = investigate($old_dref,$dref);
- warn $report if $report;
- }
- }
- my $ft = File::Temp->new(
- DIR => $dirname,
- TEMPLATE => "CHECKSUMS.XXXX",
- CLEANUP => 0,
- ) or die;
- my $tckfn = $ft->filename;
- close $ft;
- my($fh) = new IO::File;
- open $fh, ">$tckfn\0" or die "Couldn't open >$tckfn\: $!";
-
- local $\;
- if ($SIGNING_KEY) {
- print $fh "0&&<<''; # this PGP-signed message is also valid perl\n";
- close $fh;
- open $fh, "| $SIGNING_PROGRAM $SIGNING_KEY >> $tckfn"
- or die "Could not call gpg: $!";
- $ddump .= "__END__\n";
- }
-
- my $message = sprintf "# CHECKSUMS file written on %s GMT by CPAN::Checksums (v%s)\n%s",
- scalar gmtime, $VERSION, $ddump;
- print $fh $message;
- my $success = close $fh;
- if ($SIGNING_KEY && !$success) {
- warn "Couldn't run '$SIGNING_PROGRAM $SIGNING_KEY'!
-Writing to $tckfn directly";
- open $fh, ">$tckfn\0" or die "Couldn't open >$tckfn\: $!";
- print $fh $message;
- close $fh or warn "Couldn't close $tckfn: $!";
- }
- chmod 0644, $ckfn or die "Couldn't chmod to 0644 for $ckfn\: $!" if -f $ckfn;
- rename $tckfn, $ckfn or die "Could not rename: $!";
- chmod 0444, $ckfn or die "Couldn't chmod to 0444 for $ckfn\: $!";
- return 2;
-}
-
-sub _add_digests ($$$$$$$) {
- my($de,$dref,$module,$constructor_args,$keyname,$abs,$old_dref) = @_;
- my($fh) = new IO::File;
- my $dig = $module->new(@$constructor_args);
- $fh->open("$abs\0") or die "Couldn't open $abs: $!";
- binmode($fh); # make sure it's called as a function, solaris with
- # perl 5.8.4 complained about missing method in
- # IO::File
- $dig->addfile($fh);
- $fh->close;
- my $digest = $dig->hexdigest;
- $dref->{$de}{$keyname} = $digest;
- $dig = $module->new(@$constructor_args);
- if ($de =~ /\.gz$/) {
- my($buffer, $zip);
- if (exists $old_dref->{$de}{$keyname} &&
- $dref->{$de}{$keyname} eq $old_dref->{$de}{$keyname} &&
- exists $old_dref->{$de}{"$keyname-ungz"}
- ) {
- $dref->{$de}{"$keyname-ungz"} = $old_dref->{$de}{"$keyname-ungz"};
- return;
- }
- if ($zip = Compress::Zlib::gzopen($abs, "rb")) {
- $dig->add($buffer)
- while $zip->gzread($buffer) > 0;
- $dref->{$de}{"$keyname-ungz"} = $dig->hexdigest;
- $zip->gzclose;
- }
- } elsif ($de =~ /\.bz2$/) {
- my($buffer, $zip);
- if (exists $old_dref->{$de}{$keyname} &&
- $dref->{$de}{$keyname} eq $old_dref->{$de}{$keyname} &&
- exists $old_dref->{$de}{"$keyname-unbz2"}
- ) {
- $dref->{$de}{"$keyname-unbz2"} = $old_dref->{$de}{"$keyname-unbz2"};
- return;
- }
- if ($zip = Compress::Bzip2::bzopen($abs, "rb")) {
- $dig->add($buffer)
- while $zip->bzread($buffer) > 0;
- $dref->{$de}{"$keyname-unbz2"} = $dig->hexdigest;
- $zip->bzclose;
- }
- }
-}
-
-sub ckcmp ($$) {
- my($old,$new) = @_;
- for ($old,$new) {
- $_ = makehashref($_);
- }
- Data::Compare::Compare($old,$new);
-}
-
-# see if a file changed but the name not
-sub investigate ($$) {
- my($old,$new) = @_;
- for ($old,$new) {
- $_ = makehashref($_);
- }
- my $complain = "";
- for my $dist (sort keys %$new) {
- if (exists $old->{$dist}) {
- my $headersaid;
- for my $diff (qw/md5 sha256 size md5-ungz sha256-ungz mtime/) {
- next unless exists $old->{$dist}{$diff} &&
- exists $new->{$dist}{$diff};
- next if $old->{$dist}{$diff} eq $new->{$dist}{$diff};
- $complain .=
- scalar gmtime().
- " GMT:\ndiffering old/new version of same file $dist:\n"
- unless $headersaid++;
- $complain .=
- qq{\t$diff "$old->{$dist}{$diff}" -> "$new->{$dist}{$diff}"\n}; #};
- }
- }
- }
- $complain;
-}
-
-sub makehashref ($) {
- local($_) = shift;
- unless (ref $_ eq "HASH") {
- require Safe;
- my($comp) = Safe->new("CPAN::Checksums::reval");
- my $cksum; # used by Data::Dumper
- $_ = $comp->reval($_) || {};
- die "CPAN::Checksums: Caught error[$@] while checking $DIRNAME" if $@;
- }
- $_;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-CPAN::Checksums - Write a C<CHECKSUMS> file for a directory as on CPAN
-
-=head1 SYNOPSIS
-
- use CPAN::Checksums qw(updatedir);
- my $success = updatedir($directory);
-
-=head1 INCOMPATIBILITY ALERT
-
-Since version 1.0 the generation of the attribute C<shortname> is
-turned off by default. It was too slow and was not used as far as I
-know, and above all, it could fail on large directories. The shortname
-feature can still be turned on by setting the global variable
-$TRY_SHORTNAME to a true value.
-
-=head1 DESCRIPTION
-
-=over 2
-
-=item $success = updatedir($dir)
-
-C<updatedir()> takes a directory name as argument and writes a typical
-C<CHECKSUMS> file in that directory as used on CPAN unless a previously
-written C<CHECKSUMS> file is there that is still valid. Returns 2 if a
-new C<CHECKSUMS> file has been written, 1 if a valid C<CHECKSUMS> file is
-already there, otherwise dies.
-
-Note: since version 2.0 updatedir on empty directories behaves just
-the same. In older versions it silently did nothing.
-
-=back
-
-=head2 Global Variables in package CPAN::Checksums
-
-=over
-
-=item $IGNORE_MATCH
-
-If the global variable $IGNORE_MATCH is set, then all files matching
-this expression will be completely ignored and will not be included in
-the CPAN C<CHECKSUMS> files. Per default this variable is set to
-
- qr{(?i-xsm:readme$)}
-
-=item $CAUTION
-
-Setting the global variable $CAUTION causes updatedir() to report
-changes of files in the attributes C<size>, C<mtime>, C<md5>, or
-C<md5-ungz> to STDERR.
-
-=item $TRY_SHORTNAME
-
-By setting the global variable $TRY_SHORTNAME to a true value, you can
-tell updatedir() to include an attribute C<shortname> in the resulting
-hash that is 8.3-compatible. Please note, that updatedir() in this
-case may be slow and may even fail on large directories, because it
-will always only try 1000 iterations to find a name that is not yet
-taken and then give up.
-
-=item $SIGNING_KEY
-
-Setting the global variable $SIGNING_KEY makes the generated C<CHECKSUMS>
-file to be clear-signed by the command specified in $SIGNING_PROGRAM
-(defaults to C<gpg --clearsign --default-key >), passing the signing
-key as an extra argument. The resulting C<CHECKSUMS> file should look like:
-
- 0&&<<''; # this PGP-signed message is also valid perl
- -----BEGIN PGP SIGNED MESSAGE-----
- Hash: SHA1
-
- # CHECKSUMS file written on ... by CPAN::Checksums (v...)
- $cksum = {
- ...
- };
-
- __END__
- -----BEGIN PGP SIGNATURE-----
- ...
- -----END PGP SIGNATURE-----
-
-note that the actual data remains intact, but two extra lines are
-added to make it legal for both OpenPGP and perl syntax.
-
-=item $MIN_MTIME_CHECKSUMS
-
-If the global variable $MIN_MTIME_CHECKSUMS is set, then updatedir
-will renew signatures on checksum files that have an older mtime than
-the given value.
-
-=back
-
-=head1 PREREQUISITES
-
-DirHandle, IO::File, Digest::MD5, Digest::SHA, Compress::Bzip2,
-Compress::Zlib, File::Spec, Data::Dumper, Data::Compare, File::Temp
-
-=head1 BUGS
-
-If updatedir is interrupted, it may leave a temporary file lying
-around. These files have the File::Temp template C<CHECKSUMS.XXXX> and
-should be harvested by a cronjob.
-
-=head1 AUTHOR
-
-Andreas Koenig, andreas.koenig@anima.de; GnuPG support by Autrijus Tang
-
-=head1 COPYRIGHT & LICENSE
-
-Copyright (c) 2002-2008 Andreas Koenig, Audrey Tang, Steve Peters.
-
-This program is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-=head1 SEE ALSO
-
-perl(1).
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Complete.pm b/Master/tlpkg/tlperl/lib/CPAN/Complete.pm
deleted file mode 100755
index e1fe896d4a5..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Complete.pm
+++ /dev/null
@@ -1,175 +0,0 @@
-# -*- 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: svn diff -r 1048:1049 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.5";
-
-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/Master/tlpkg/tlperl/lib/CPAN/Config.pm b/Master/tlpkg/tlperl/lib/CPAN/Config.pm
deleted file mode 100755
index 6fbca32afc8..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Config.pm
+++ /dev/null
@@ -1,87 +0,0 @@
-
-# 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. The user-config file is being looked for as
-# ~/.cpan/CPAN/MyConfig.pm.
-
-my @urllist = (
- q[http://cpan.strawberryperl.com/],
-);
-if ( -d 'C:\\strawberry\\minicpan' ) {
- # If we are on fake Hotel/Airport wireless,
- # prefer the minicpan to the poisoned wireless.
- eval { require LWP::Online; };
- unless ( $@ ) {
- if ( LWP::Online::online() ) {
- push @urllist, q[file:///C:/strawberry/minicpan/];
- } else {
- unshift @urllist, q[file:///C:/strawberry/minicpan/];
- }
- }
-}
-
-$CPAN::Config = {
- applypatch => q[],
- auto_commit => q[1],
- build_cache => q[10],
- build_dir => qq[C:\\strawberry\\cpan\\build],
- build_dir_reuse => q[0],
- build_requires_install_policy => q[yes],
- bzip2 => q[],
- cache_metadata => q[0],
- check_sigs => q[0],
- colorize_output => q[0],
- colorize_print => q[bold blue on_white],
- colorize_warn => q[bold red on_white],
- commandnumber_in_prompt => q[0],
- cpan_home => q[C:\\strawberry\\cpan],
- curl => q[],
- ftp => q[C:\\WINDOWS\\system32\\ftp.EXE],
- ftp_passive => q[1],
- ftp_proxy => q[],
- getcwd => q[cwd],
- gpg => q[],
- gzip => q[ ], #will use perl module if it is ' '
- histfile => q[C:\\strawberry\\cpan\\histfile],
- histsize => q[100],
- http_proxy => q[],
- inactivity_timeout => q[0],
- index_expire => q[1],
- inhibit_startup_message => q[0],
- keep_source_where => q[C:\\strawberry\\cpan\\sources],
- load_module_verbosity => q[none],
- lynx => q[],
- make => q[C:\\strawberry\\c\\bin\\dmake.EXE],
- make_arg => q[],
- make_install_arg => q[UNINST=1],
- makepl_arg => q[],
- mbuild_arg => q[],
- mbuild_install_arg => q[--uninst 1],
- mbuildpl_arg => q[],
- ncftp => q[],
- ncftpget => q[],
- no_proxy => q[],
- pager => q[C:\\WINDOWS\\system32\\more.COM],
- patch => q[C:\\strawberry\\c\\bin\\patch.exe],
- prefer_installer => q[MB],
- prefs_dir => q[C:\\strawberry\\cpan\\prefs],
- prerequisites_policy => q[follow],
- scan_cache => q[atstart],
- shell => q[C:\\WINDOWS\\system32\\cmd.exe],
- show_unparsable_versions => q[0],
- show_upload_date => q[1],
- show_zero_versions => q[0],
- tar => q[ ], #will use perl module if it is ' '
- tar_verbosity => q[none],
- term_is_latin => q[0],
- term_ornaments => q[0],
- test_report => q[0],
- unzip => q[],
- urllist => \@urllist,
- use_sqlite => q[1],
- wget => q[],
- yaml_load_code => q[0],
- yaml_module => q[YAML],
-};
-
-1;
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Debug.pm b/Master/tlpkg/tlperl/lib/CPAN/Debug.pm
deleted file mode 100755
index 926b0d79b41..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Debug.pm
+++ /dev/null
@@ -1,79 +0,0 @@
-# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
-package CPAN::Debug;
-use strict;
-use vars qw($VERSION);
-
-$VERSION = "5.5";
-# 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($arg->as_string);
- } else {
- $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
- }
- } else {
- my $outer = "";
- local $" = ",";
- if (@caller>1) {
- $outer = ",[@{$caller[1]}]";
- }
- $CPAN::Frontend->myprint("Debug(@{$caller[0]}$outer): $arg\n");
- }
- }
-}
-
-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
diff --git a/Master/tlpkg/tlperl/lib/CPAN/DeferredCode.pm b/Master/tlpkg/tlperl/lib/CPAN/DeferredCode.pm
deleted file mode 100755
index 0db37a64853..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/DeferredCode.pm
+++ /dev/null
@@ -1,16 +0,0 @@
-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/Master/tlpkg/tlperl/lib/CPAN/DistnameInfo.pm b/Master/tlpkg/tlperl/lib/CPAN/DistnameInfo.pm
deleted file mode 100755
index 808cf2ba40d..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/DistnameInfo.pm
+++ /dev/null
@@ -1,194 +0,0 @@
-
-package CPAN::DistnameInfo;
-
-$VERSION = "0.09";
-use strict;
-
-sub distname_info {
- my $file = shift or return;
-
- my ($dist, $version) = $file =~ /^
- ((?:[-+.]*(?:[A-Za-z0-9]+|(?<=\D)_|_(?=\D))*
- (?:
- [A-Za-z](?=[^A-Za-z]|$)
- |
- \d(?=-)
- )(?<![._-][vV])
- )+)(.*)
- $/xs or return ($file,undef,undef);
-
- if ($dist =~ /-undef\z/ and ! length $version) {
- $dist =~ s/-undef\z//;
- }
-
- if ($version =~ /^(-[Vv].*)-(\d.*)/) {
-
- # Catch names like Unicode-Collate-Standard-V3_1_1-0.1
- # where the V3_1_1 is part of the distname
- $dist .= $1;
- $version = $2;
- }
-
- # Normalize the Dist.pm-1.23 convention which CGI.pm and
- # a few others use.
- $dist =~ s{\.pm$}{};
-
- $version = $1
- if !length $version and $dist =~ s/-(\d+\w)$//;
-
- $version = $1 . $version
- if $version =~ /^\d+$/ and $dist =~ s/-(\w+)$//;
-
- if ($version =~ /\d\.\d/) {
- $version =~ s/^[-_.]+//;
- }
- else {
- $version =~ s/^[-_]+//;
- }
-
- my $dev;
- if (length $version) {
- if ($file =~ /^perl-?\d+\.(\d+)(?:\D(\d+))?(-(?:TRIAL|RC)\d+)?$/) {
- $dev = 1 if (($1 > 6 and $1 & 1) or ($2 and $2 >= 50)) or $3;
- }
- elsif ($version =~ /\d\D\d+_\d/) {
- $dev = 1;
- }
- }
- else {
- $version = undef;
- }
-
- ($dist, $version, $dev);
-}
-
-sub new {
- my $class = shift;
- my $distfile = shift;
-
- $distfile =~ s,//+,/,g;
-
- my %info = ( pathname => $distfile );
-
- ($info{filename} = $distfile) =~ s,^(((.*?/)?authors/)?id/)?([A-Z])/(\4[A-Z])/(\5[-A-Z0-9]*)/,,
- and $info{cpanid} = $6;
-
- if ($distfile =~ m,([^/]+)\.(tar\.(?:g?z|bz2)|zip|tgz)$,i) { # support more ?
- $info{distvname} = $1;
- $info{extension} = $2;
- }
-
- @info{qw(dist version beta)} = distname_info($info{distvname});
- $info{maturity} = delete $info{beta} ? 'developer' : 'released';
-
- return bless \%info, $class;
-}
-
-sub dist { shift->{dist} }
-sub version { shift->{version} }
-sub maturity { shift->{maturity} }
-sub filename { shift->{filename} }
-sub cpanid { shift->{cpanid} }
-sub distvname { shift->{distvname} }
-sub extension { shift->{extension} }
-sub pathname { shift->{pathname} }
-
-sub properties { %{ $_[0] } }
-
-1;
-
-__END__
-
-=head1 NAME
-
-CPAN::DistnameInfo - Extract distribution name and version from a distribution filename
-
-=head1 SYNOPSIS
-
- my $pathname = "authors/id/G/GB/GBARR/CPAN-DistnameInfo-0.02.tar.gz";
-
- 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 $extension = $d->extension; # "tar.gz"
- my $pathname = $d->pathname; # "authors/id/G/GB/GBARR/..."
-
- my %prop = $d->properties;
-
-=head1 DESCRIPTION
-
-Many online services that are centered around CPAN attempt to
-associate multiple uploads by extracting a distribution name from
-the filename of the upload. For most distributions this is easy as
-they have used ExtUtils::MakeMaker or Module::Build to create the
-distribution, which results in a uniform name. But sadly not all
-uploads are created in this way.
-
-C<CPAN::DistnameInfo> uses heuristics that have been learnt by
-L<http://search.cpan.org/> to extract the distribution name and
-version from filenames and also report if the version is to be
-treated as a developer release
-
-The constructor takes a single pathname, returning an object with the following methods
-
-=over
-
-=item cpanid
-
-If the path given looked like a CPAN authors directory path, then this will be the
-the CPAN id of the author.
-
-=item dist
-
-The name of the distribution
-
-=item distvname
-
-The file name with any suffix and leading directory names removed
-
-=item filename
-
-If the path given looked like a CPAN authors directory path, then this will be the
-path to the file relative to the detected CPAN author directory. Otherwise it is the path
-that was passed in.
-
-=item maturity
-
-The maturity of the distribution. This will be either C<released> or C<developer>
-
-=item extension
-
-The extension of the distribution, often used to denote the archive type (e.g. 'tar.gz')
-
-=item pathname
-
-The pathname that was passed to the constructor when creating the object.
-
-=item properties
-
-This will return a list of key-value pairs, suitable for assigning to a hash,
-for the known properties.
-
-=item version
-
-The extracted version
-
-=back
-
-=head1 AUTHOR
-
-Graham Barr <gbarr@pobox.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 2003 Graham Barr. All rights reserved. This program is
-free software; you can redistribute it and/or modify it under the same
-terms as Perl itself.
-
-=cut
-
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Distribution.pm b/Master/tlpkg/tlperl/lib/CPAN/Distribution.pm
deleted file mode 100755
index 22d3f0640b3..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Distribution.pm
+++ /dev/null
@@ -1,3879 +0,0 @@
-package CPAN::Distribution;
-use strict;
-use Cwd qw(chdir);
-use CPAN::Distroprefs;
-use CPAN::InfoObj;
-@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
-use vars qw($VERSION);
-$VERSION = "1.94";
-
-# 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-]{2}/[A-Z-]{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
-
- return if exists $self->{incommandcolor}
- && $color==1
- && $self->{incommandcolor}==$color;
- if ($depth>=$CPAN::MAX_RECURSION) {
- die(CPAN::Exception::RecursiveDependency->new($ancestors));
- }
- # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
- my $prereq_pm = $self->prereq_pm;
- if (defined $prereq_pm) {
- PREREQ: for my $pre (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(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 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;
- }
- 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::get ;
-sub get {
- my($self) = @_;
- $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
- if (my $goto = $self->prefs->{goto}) {
- $CPAN::Frontend->mywarn
- (sprintf(
- "delegating to '%s' as specified in prefs file '%s' doc %d\n",
- $goto,
- $self->{prefs_file},
- $self->{prefs_file_doc},
- ));
- return $self->goto($goto);
- }
- local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
- ? $ENV{PERL5LIB}
- : ($ENV{PERLLIB} || "");
- local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
- $CPAN::META->set_perl5lib;
- local $ENV{MAKEFLAGS}; # protect us from outer make calls
-
- EXCUSE: {
- my @e;
- my $goodbye_message;
- $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
- if ($self->prefs->{disabled} && ! $self->{force_update}) {
- my $why = sprintf(
- "Disabled via prefs file '%s' doc %d",
- $self->{prefs_file},
- $self->{prefs_file_doc},
- );
- push @e, $why;
- $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
- $goodbye_message = "[disabled] -- NA $why";
- # note: not intended to be persistent but at least visible
- # during this session
- } else {
- if (exists $self->{build_dir} && -d $self->{build_dir}
- && ($self->{modulebuild}||$self->{writemakefile})
- ) {
- # this deserves print, not warn:
- $CPAN::Frontend->myprint(" Has already been unwrapped into directory ".
- "$self->{build_dir}\n"
- );
- return 1;
- }
-
- # although we talk about 'force' we shall not test on
- # force directly. New model of force tries to refrain from
- # direct checking of force.
- exists $self->{unwrapped} and (
- UNIVERSAL::can($self->{unwrapped},"failed") ?
- $self->{unwrapped}->failed :
- $self->{unwrapped} =~ /^NO/
- )
- and push @e, "Unwrapping had some problem, won't try again without force";
- }
- if (@e) {
- $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e);
- if ($goodbye_message) {
- $self->goodbye($goodbye_message);
- }
- return;
- }
- }
- my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
-
- my($local_file);
- 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;
- if (exists $self->{writemakefile} && ref $self->{writemakefile}
- && $self->{writemakefile}->can("failed") &&
- $self->{writemakefile}->failed) {
- return;
- }
- $packagedir ||= $self->{build_dir};
- $self->{build_dir} = $packagedir;
- }
-
- if ($CPAN::Signal) {
- $self->safe_chdir($sub_wd);
- return;
- }
- return $self->choose_MM_or_MB($local_file);
-}
-
-#-> CPAN::Distribution::get_file_onto_local_disk
-sub get_file_onto_local_disk {
- my($self) = @_;
-
- return if $self->is_dot_dist;
- my($local_file);
- my($local_wanted) =
- File::Spec->catfile(
- $CPAN::Config->{keep_source_where},
- "authors",
- "id",
- split(/\//,$self->id)
- );
-
- $self->debug("Doing localize") if $CPAN::DEBUG;
- unless ($local_file =
- CPAN::FTP->localize("authors/id/$self->{ID}",
- $local_wanted)) {
- my $note = "";
- if ($CPAN::Index::DATE_OF_02) {
- $note = "Note: Current database in memory was generated ".
- "on $CPAN::Index::DATE_OF_02\n";
- }
- $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
- }
-
- $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
- $self->{localfile} = $local_file;
-}
-
-
-#-> CPAN::Distribution::check_integrity
-sub check_integrity {
- my($self) = @_;
-
- return if $self->is_dot_dist;
- if ($CPAN::META->has_inst("Digest::SHA")) {
- $self->debug("Digest::SHA is installed, verifying");
- $self->verifyCHECKSUM;
- } else {
- $self->debug("Digest::SHA is NOT installed");
- }
-}
-
-#-> CPAN::Distribution::run_preps_on_packagedir
-sub run_preps_on_packagedir {
- my($self) = @_;
- return if $self->is_dot_dist;
-
- $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
- my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
- $self->safe_chdir($builddir);
- $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
- File::Path::rmtree("tmp-$$");
- unless (mkdir "tmp-$$", 0755) {
- $CPAN::Frontend->unrecoverable_error(<<EOF);
-Couldn't mkdir '$builddir/tmp-$$': $!
-
-Cannot continue: Please find the reason why I cannot make the
-directory
-$builddir/tmp-$$
-and fix the problem, then retry.
-
-EOF
- }
- if ($CPAN::Signal) {
- return;
- }
- $self->safe_chdir("tmp-$$");
-
- #
- # Unpack the goods
- #
- my $local_file = $self->{localfile};
- my $ct = eval{CPAN::Tarzip->new($local_file)};
- unless ($ct) {
- $self->{unwrapped} = CPAN::Distrostatus->new("NO");
- delete $self->{build_dir};
- return;
- }
- if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i) {
- $self->{was_uncompressed}++ unless eval{$ct->gtest()};
- $self->untar_me($ct);
- } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
- $self->unzip_me($ct);
- } else {
- $self->{was_uncompressed}++ unless $ct->gtest();
- $local_file = $self->handle_singlefile($local_file);
- }
-
- # we are still in the tmp directory!
- # Let's check if the package has its own directory.
- my $dh = DirHandle->new(File::Spec->curdir)
- or Carp::croak("Couldn't opendir .: $!");
- my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
- if (grep { $_ eq "pax_global_header" } @readdir) {
- $CPAN::Frontend->mywarn("Your (un)tar seems to have extracted a file named 'pax_global_header'
-from the tarball '$local_file'.
-This is almost certainly an error. Please upgrade your tar.
-I'll ignore this file for now.
-See also http://rt.cpan.org/Ticket/Display.html?id=38932\n");
- $CPAN::Frontend->mysleep(5);
- @readdir = grep { $_ ne "pax_global_header" } @readdir;
- }
- $dh->close;
- my ($packagedir);
- # XXX here we want in each branch File::Temp to protect all build_dir directories
- if (CPAN->has_usable("File::Temp")) {
- 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;
- }
- $packagedir = File::Temp::tempdir(
- "$tdir_base-XXXXXX",
- DIR => $builddir,
- CLEANUP => 0,
- );
- chmod 0777 &~ umask, $packagedir; # may fail
- my $f;
- for $f (@dirents) { # is already without "." and ".."
- my $from = File::Spec->catdir($from_dir,$f);
- my $to = File::Spec->catdir($packagedir,$f);
- unless (File::Copy::move($from,$to)) {
- my $err = $!;
- $from = File::Spec->rel2abs($from);
- Carp::confess("Couldn't move $from to $to: $err");
- }
- }
- } else { # older code below, still better than nothing when there is no File::Temp
- my($distdir);
- if (@readdir == 1 && -d $readdir[0]) {
- $distdir = $readdir[0];
- $packagedir = File::Spec->catdir($builddir,$distdir);
- $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
- if $CPAN::DEBUG;
- -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
- "$packagedir\n");
- File::Path::rmtree($packagedir);
- unless (File::Copy::move($distdir,$packagedir)) {
- $CPAN::Frontend->unrecoverable_error(<<EOF);
-Couldn't move '$distdir' to '$packagedir': $!
-
-Cannot continue: Please find the reason why I cannot move
-$builddir/tmp-$$/$distdir
-to
-$packagedir
-and fix the problem, then retry
-
-EOF
- }
- $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
- $distdir,
- $packagedir,
- -e $packagedir,
- -d $packagedir,
- )) if $CPAN::DEBUG;
- } else {
- my $userid = $self->cpan_userid;
- CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
- if (!$userid or $userid eq "N/A") {
- $userid = "anon";
- }
- my $pragmatic_dir = $userid . '000';
- $pragmatic_dir =~ s/\W_//g;
- $pragmatic_dir++ while -d "../$pragmatic_dir";
- $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
- $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
- File::Path::mkpath($packagedir);
- my($f);
- for $f (@readdir) { # is already without "." and ".."
- my $to = File::Spec->catdir($packagedir,$f);
- File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
- }
- }
- }
- $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::parse_meta_yml ;
-sub parse_meta_yml {
- my($self) = @_;
- my $build_dir = $self->{build_dir} or die "PANIC: cannot parse yaml without a build_dir";
- my $yaml = File::Spec->catfile($build_dir,"META.yml");
- $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
- return unless -f $yaml;
- my $early_yaml;
- eval {
- require Parse::CPAN::Meta;
- $early_yaml = Parse::CPAN::Meta::LoadFile($yaml)->[0];
- };
- unless ($early_yaml) {
- eval { $early_yaml = CPAN->_yaml_loadfile($yaml)->[0]; };
- }
- unless ($early_yaml) {
- return;
- }
- return $early_yaml;
-}
-
-#-> sub CPAN::Distribution::satisfy_requires ;
-sub satisfy_requires {
- my ($self) = @_;
- if (my @prereq = $self->unsat_prereq("later")) {
- 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) {
- # signal success to the queuerunner
- return 1;
- } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
- $CPAN::Frontend->mywarn($@);
- die "[depend] -- NOT OK\n";
- }
- }
- }
-}
-
-#-> sub CPAN::Distribution::satisfy_configure_requires ;
-sub satisfy_configure_requires {
- my($self) = @_;
- 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") or return 1;
- if ($self->{configure_requires_later}) {
- for my $k (keys %{$self->{configure_requires_later_for}||{}}) {
- if ($self->{configure_requires_later_for}{$k}>1) {
- # we must not come here a second time
- $CPAN::Frontend->mywarn("Panic: Some prerequisites is not available, please investigate...");
- require YAML::Syck;
- $CPAN::Frontend->mydie
- (
- YAML::Syck::Dump
- ({self=>$self, prereq=>\@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;
- return $self->goodbye("[prereq] -- NOT OK");
- } else {
- my $follow = eval {
- $self->follow_prereqs("configure_requires_later", @prereq);
- };
- if (0) {
- } elsif ($follow) {
- return;
- } 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,$local_file) = @_;
- $self->satisfy_configure_requires() or return;
- 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";
- }
- }
- return unless $self->patch;
- 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;
-}
-
-#-> CPAN::Distribution::store_persistent_state
-sub store_persistent_state {
- my($self) = @_;
- my $dir = $self->{build_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 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->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
- "will not store persistent state\n");
- }
-}
-
-#-> CPAN::Distribution::try_download
-sub try_download {
- my($self,$patch) = @_;
- my $norm = $self->normalize($patch);
- my($local_wanted) =
- File::Spec->catfile(
- $CPAN::Config->{keep_source_where},
- "authors",
- "id",
- split(/\//,$norm),
- );
- $self->debug("Doing localize") if $CPAN::DEBUG;
- return CPAN::FTP->localize("authors/id/$norm",
- $local_wanted);
-}
-
-{
- my $stdpatchargs = "";
- #-> CPAN::Distribution::patch
- sub patch {
- my($self) = @_;
- $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
- my $patches = $self->prefs->{patches};
- $patches ||= "";
- $self->debug("patches[$patches]") if $CPAN::DEBUG;
- if ($patches) {
- return unless @$patches;
- $self->safe_chdir($self->{build_dir});
- CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
- my $patchbin = $CPAN::Config->{patch};
- unless ($patchbin && length $patchbin) {
- $CPAN::Frontend->mydie("No external patch command configured\n\n".
- "Please run 'o conf init /patch/'\n\n");
- }
- unless (MM->maybe_command($patchbin)) {
- $CPAN::Frontend->mydie("No external patch command available\n\n".
- "Please run 'o conf init /patch/'\n\n");
- }
- $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
- local $ENV{PATCH_GET} = 0; # formerly known as -g0
- unless ($stdpatchargs) {
- my $system = "$patchbin --version |";
- local *FH;
- open FH, $system or die "Could not fork '$system': $!";
- local $/ = "\n";
- my $pversion;
- PARSEVERSION: while (<FH>) {
- if (/^patch\s+([\d\.]+)/) {
- $pversion = $1;
- last PARSEVERSION;
- }
- }
- if ($pversion) {
- $stdpatchargs = "-N --fuzz=3";
- } else {
- $stdpatchargs = "-N";
- }
- }
- my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
- $CPAN::Frontend->myprint("Going to apply $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 = $self->_patch_p_parameter($readfh);
- if ($ppp eq "applypatch") {
- $pcommand = "$CPAN::Config->{applypatch} -verbose";
- } else {
- my $thispatchargs = join " ", $stdpatchargs, $ppp;
- $pcommand = "$patchbin $thispatchargs";
- }
-
- $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;
- }
-}
-
-sub _patch_p_parameter {
- my($self,$fh) = @_;
- my $cnt_files = 0;
- my $cnt_p0files = 0;
- local($_);
- while ($_ = $fh->READLINE) {
- if (
- $CPAN::Config->{applypatch}
- &&
- /\#\#\#\# ApplyPatch data follows \#\#\#\#/
- ) {
- return "applypatch"
- }
- next unless /^[\*\+]{3}\s(\S+)/;
- my $file = $1;
- $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;
- return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
-}
-
-#-> 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";
- # name parsen und 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 {
- $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
- }
-}
-
-# CPAN::Distribution::unzip_me ;
-sub unzip_me {
- my($self,$ct) = @_;
- $self->{archived} = "zip";
- if ($ct->unzip()) {
- $self->{unwrapped} = CPAN::Distrostatus->new("YES");
- } else {
- $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
- }
- return;
-}
-
-sub handle_singlefile {
- my($self,$local_file) = @_;
-
- if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ) {
- $self->{archived} = "pm";
- } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
- $self->{archived} = "patch";
- } else {
- $self->{archived} = "maybe_pl";
- }
-
- my $to = File::Basename::basename($local_file);
- if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
- if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
- $self->{unwrapped} = CPAN::Distrostatus->new("YES");
- } else {
- $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
- }
- } else {
- if (File::Copy::cp($local_file,".")) {
- $self->{unwrapped} = CPAN::Distrostatus->new("YES");
- } else {
- $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
- }
- }
- return $to;
-}
-
-#-> sub CPAN::Distribution::new ;
-sub new {
- my($class,%att) = @_;
-
- # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
-
- my $this = { %att };
- return bless $this, $class;
-}
-
-#-> sub CPAN::Distribution::look ;
-sub look {
- my($self) = @_;
-
- if ($^O eq 'MacOS') {
- $self->Mac::BuildTools::look;
- return;
- }
-
- if ( $CPAN::Config->{'shell'} ) {
- $CPAN::Frontend->myprint(qq{
-Trying to open a subshell in the build directory...
-});
- } else {
- $CPAN::Frontend->myprint(qq{
-Your configuration does not define a value for subshells.
-Please define it with "o conf shell <your shell>"
-});
- return;
- }
- my $dist = $self->id;
- my $dir;
- unless ($dir = $self->dir) {
- $self->get;
- }
- unless ($dir ||= $self->dir) {
- $CPAN::Frontend->mywarn(qq{
-Could not determine which directory to use for looking at $dist.
-});
- return;
- }
- my $pwd = CPAN::anycwd();
- $self->safe_chdir($dir);
- $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
- {
- local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
- $ENV{CPAN_SHELL_LEVEL} += 1;
- my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
-
- local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
- ? $ENV{PERL5LIB}
- : ($ENV{PERLLIB} || "");
-
- local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
- $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",
- "prereq_pm_detected",
- ],
- 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{3}(_[0-4][0-9])?
- |
- \d+\.\d+
- )
- \.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::make ;
-sub make {
- my($self) = @_;
- if (my $goto = $self->prefs->{goto}) {
- return $self->goto($goto);
- }
- my $make = $self->{modulebuild} ? "Build" : "make";
- # Emergency brake if they said install Pippi and get newest perl
- 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->id,
- ));
- $self->{make} = CPAN::Distrostatus->new("NO isa perl");
- $CPAN::Frontend->mysleep(1);
- return;
- }
- }
- $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
- $self->get;
- return if $self->prefs->{disabled} && ! $self->{force_update};
- if ($self->{configure_requires_later}) {
- return;
- }
- local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
- ? $ENV{PERL5LIB}
- : ($ENV{PERLLIB} || "");
- local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
- $CPAN::META->set_perl5lib;
- local $ENV{MAKEFLAGS}; # protect us from outer make calls
-
- if ($CPAN::Signal) {
- delete $self->{force_update};
- return;
- }
-
- my $builddir;
- EXCUSE: {
- my @e;
- if (!$self->{archived} || $self->{archived} eq "NO") {
- push @e, "Is neither a tar nor a zip archive.";
- }
-
- if (!$self->{unwrapped}
- || (
- UNIVERSAL::can($self->{unwrapped},"failed") ?
- $self->{unwrapped}->failed :
- $self->{unwrapped} =~ /^NO/
- )) {
- push @e, "Had problems unarchiving. Please build manually";
- }
-
- unless ($self->{force_update}) {
- exists $self->{signature_verify} and
- (
- UNIVERSAL::can($self->{signature_verify},"failed") ?
- $self->{signature_verify}->failed :
- $self->{signature_verify} =~ /^NO/
- )
- and push @e, "Did not pass the signature test.";
- }
-
- if (exists $self->{writemakefile} &&
- (
- 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 .= ", won't make";
- push @e, $err;
- }
-
- 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)
- } else {
- # introduced for turning recursion detection into a distrostatus
- my $error = length $self->{make}>3
- ? substr($self->{make},3) : "Unknown error";
- $CPAN::Frontend->mywarn("Could not make: $error\n");
- $self->store_persistent_state;
- return;
- }
- } else {
- push @e, "Has already been made";
- my $wait_for_prereqs = eval { $self->satisfy_requires };
- return 1 if $wait_for_prereqs; # tells queuerunner to continue
- return $self->goodbye($@) if $@; # tells queuerunner to stop
- }
- }
-
- my $later = $self->{later} || $self->{configure_requires_later};
- if ($later) { # see also undelay
- if ($later) {
- push @e, $later;
- }
- }
-
- $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
- $builddir = $self->dir or
- $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
- unless (chdir $builddir) {
- push @e, "Couldn't chdir to '$builddir': $!";
- }
- $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
- }
- if ($CPAN::Signal) {
- delete $self->{force_update};
- return;
- }
- $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
- $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
-
- if ($^O eq 'MacOS') {
- Mac::BuildTools::make($self);
- return;
- }
-
- my %env;
- while (my($k,$v) = each %ENV) {
- next unless defined $v;
- $env{$k} = $v;
- }
- local %ENV = %env;
- my $system;
- my $pl_commandline;
- if ($self->prefs->{pl}) {
- $pl_commandline = $self->prefs->{pl}{commandline};
- }
- 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";
- $system = "$perl Build.PL $CPAN::Config->{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};
- }
- if ($pl_env) {
- for my $e (keys %$pl_env) {
- $ENV{$e} = $pl_env->{$e};
- }
- }
- 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) = CPAN::Reporter::record_command($system);
- 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") {
- $self->{writemakefile} = CPAN::Distrostatus->new("YES");
- delete $self->{make_clean}; # if cleaned before, enable next
- } 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");
- }
- }
- if ($CPAN::Signal) {
- delete $self->{force_update};
- return;
- }
- my $wait_for_prereqs = eval { $self->satisfy_requires };
- return 1 if $wait_for_prereqs; # tells queuerunner to continue
- return $self->goodbye($@) if $@; # tells queuerunner to stop
- if ($CPAN::Signal) {
- delete $self->{force_update};
- return;
- }
- my $make_commandline;
- if ($self->prefs->{make}) {
- $make_commandline = $self->prefs->{make}{commandline};
- }
- if ($make_commandline) {
- $system = $make_commandline;
- $ENV{PERL} = CPAN::find_perl();
- } else {
- if ($self->{modulebuild}) {
- unless (-f "Build") {
- 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};
- }
- if ($make_env) { # overriding the local ENV of PL, not the outer
- # ENV, but unlikely to be a risk
- for my $e (keys %$make_env) {
- $ENV{$e} = $make_env->{$e};
- }
- }
- 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;
- 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 {
- $system_ok = system($system) == 0;
- }
- $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");
- }
- $self->store_persistent_state;
-}
-
-# CPAN::Distribution::goodbye ;
-sub goodbye {
- my($self,$goodbye) = @_;
- my $id = $self->pretty_id;
- $CPAN::Frontend->mywarn(" $id\n $goodbye\n");
- return;
-}
-
-# 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");
- }
- 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->mywarn("'$yaml_module' not installed, falling back ".
- "to @fallbacks to read prefs '$prefs_dir'\n");
- }
- } else {
- unless ($self->{have_complained_about_missing_yaml}++) {
- $CPAN::Frontend->mywarn("'$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 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) {
- # XXX watch out for foul ones
- push @good_prereq_tuples, $p;
- }
- 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 {" $_->[0] \[$map{$_->[1]}]\n"} @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;
- # color them as dirty
- for my $gp (@good_prereq_tuples) {
- # warn "calling color_cmd_tmps(0,1)";
- my $p = $gp->[0];
- my $any = CPAN::Shell->expandany($p);
- $self->{$slot . "_for"}{$any->id}++;
- if ($any) {
- $any->color_cmd_tmps(0,2);
- } else {
- $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
- $CPAN::Frontend->mysleep(2);
- }
- }
- # queue them and re-queue yourself
- CPAN::Queue->jumpqueue({qmod => $id, reqtype => $self->{reqtype}},
- map {+{qmod=>$_->[0],reqtype=>$_->[1]}} reverse @good_prereq_tuples);
- $self->{$slot} = "Delayed until after prerequisites";
- return 1; # signal success to the queuerunner
- }
- 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 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,$prereq_pm);
- my $prefs_depends = $self->prefs->{depends}||{};
- my $feature_depends = $self->_feature_depends();
- if ($slot eq "configure_requires_later") {
- my $meta_yml = $self->parse_meta_yml();
- if (defined $meta_yml && (! ref $meta_yml || ref $meta_yml ne "HASH")) {
- $CPAN::Frontend->mywarn("The content of META.yml is defined but not a HASH reference. Cannot use it.\n");
- $meta_yml = +{};
- }
- %merged = (
- %{$meta_yml->{configure_requires}||{}},
- %{$prefs_depends->{configure_requires}||{}},
- %{$feature_depends->{configure_requires}||{}},
- );
- $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)) {
- $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};
- }
- }
- }
- %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
- } else {
- die "Panic: illegal slot '$slot'";
- }
- my(@need);
- my @merged = %merged;
- CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
- NEED: while (my($need_module, $need_version) = each %merged) {
- 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);
- next if $nmo->uptodate;
- $inst_file = $nmo->inst_file || '';
- $available_file = $nmo->available_file || '';
-
- # if they have not specified a version, we accept any installed one
- if ( $available_file
- and ( # a few quick shortcurcuits
- not defined $need_version
- or $need_version eq '0' # "==" would trigger warning when not numeric
- or $need_version eq "undef"
- )) {
- next NEED;
- }
-
- $available_version = $nmo->available_version;
- }
-
- # 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 ) {
- if ( $inst_file && $available_file eq $inst_file && $nmo->inst_deprecated ) {
- # continue installing as a prereq
- }
- else {
- next NEED if $self->_fulfills_all_version_rqs(
- $need_module,$available_file,$available_version,$need_version
- );
- }
- }
-
- 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;
- }
- $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 = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
- push @need, [$need_module,$needed_as];
- }
- 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_yaml ;
-sub read_yaml {
- my($self) = @_;
- return $self->{yaml_content} if exists $self->{yaml_content};
- 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;
- }
- # if MYMETA.yml exists, that takes precedence over META.yml
- my $meta = File::Spec->catfile($build_dir,"META.yml");
- my $mymeta = File::Spec->catfile($build_dir,"MYMETA.yml");
- my $yaml = -f $mymeta ? $mymeta : $meta;
- $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
- return unless -f $yaml;
- eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
- if ($@) {
- $CPAN::Frontend->mywarn("Could not read ".
- "'$yaml'. Falling back to other ".
- "methods to determine prerequisites\n");
- return $self->{yaml_content} = undef; # if we die, then we
- # cannot read YAML's own
- # META.yml
- }
- # not "authoritative"
- for ($self->{yaml_content}) {
- if (defined $_ && (! ref $_ || ref $_ ne "HASH")) {
- $CPAN::Frontend->mywarn("META.yml does not seem to be conforming, cannot use it.\n");
- $self->{yaml_content} = +{};
- }
- }
- # MYMETA.yml is not dynamic by definition
- if ( $yaml ne $mymeta &&
- ( not exists $self->{yaml_content}{dynamic_config}
- or $self->{yaml_content}{dynamic_config}
- )
- ) {
- $self->{yaml_content} = undef;
- }
- $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
- if $CPAN::DEBUG;
- return $self->{yaml_content};
-}
-
-#-> sub CPAN::Distribution::prereq_pm ;
-sub prereq_pm {
- my($self) = @_;
- $self->{prereq_pm_detected} ||= 0;
- CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
- return $self->{prereq_pm} if $self->{prereq_pm_detected};
- 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($req,$breq);
- if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
- $req = $yaml->{requires} || {};
- $breq = $yaml->{build_requires} || {};
- 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;
- while (my($k,$v) = each %{$req||{}}) {
- 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;
- }
- }
- unless ($req || $breq) {
- my $build_dir;
- unless ( $build_dir = $self->{build_dir} ) {
- return;
- }
- my $makefile = File::Spec->catfile($build_dir,"Makefile");
- my $fh;
- if (-f $makefile
- and
- $fh = FileHandle->new("<$makefile\0")) {
- CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
- local($/) = "\n";
- while (<$fh>) {
- last if /MakeMaker post_initialize section/;
- my($p) = m{^[\#]
- \s+PREREQ_PM\s+=>\s+(.+)
- }x;
- next unless $p;
- # warn "Found prereq expr[$p]";
-
- # Regexp modified by A.Speer to remember actual version of file
- # PREREQ_PM hash key wants, then add to
- while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ) {
- my($m,$n) = ($1,$2);
- # When a prereq is mentioned twice: let the bigger
- # win; usual culprit is that they declared
- # build_requires separately from requires; see
- # rt.cpan.org #47774
- my($prevn);
- if ( defined $req->{$m} ) {
- $prevn = $req->{$m};
- }
- if ($n =~ /^q\[(.*?)\]$/) {
- $n = $1;
- }
- if (!$prevn || CPAN::Version->vlt($prevn, $n)){
- $req->{$m} = $n;
- }
- }
- last;
- }
- }
- }
- unless ($req || $breq) {
- my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
- my $buildfile = File::Spec->catfile($build_dir,"Build");
- if (-f $buildfile) {
- CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
- my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
- if (-f $build_prereqs) {
- CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
- my $content = do { local *FH;
- open FH, $build_prereqs
- or $CPAN::Frontend->mydie("Could not open ".
- "'$build_prereqs': $!");
- local $/;
- <FH>;
- };
- my $bphash = eval $content;
- if ($@) {
- } else {
- $req = $bphash->{requires} || +{};
- $breq = $bphash->{build_requires} || +{};
- }
- }
- }
- }
- if (-f "Build.PL"
- && ! -f "Makefile.PL"
- && ! exists $req->{"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);
- $req->{"Module::Build"} = 0;
- delete $self->{writemakefile};
- }
- if ($req || $breq) {
- $self->{prereq_pm_detected}++;
- return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
- }
-}
-
-#-> sub CPAN::Distribution::test ;
-sub test {
- my($self) = @_;
- if (my $goto = $self->prefs->{goto}) {
- return $self->goto($goto);
- }
- $self->make;
- return if $self->prefs->{disabled} && ! $self->{force_update};
- if ($CPAN::Signal) {
- delete $self->{force_update};
- return;
- }
- # warn "XDEBUG: checking for notest: $self->{notest} $self";
- if ($self->{notest}) {
- $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
- return 1;
- }
-
- my $make = $self->{modulebuild} ? "Build" : "make";
-
- local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
- ? $ENV{PERL5LIB}
- : ($ENV{PERLLIB} || "");
-
- local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
- $CPAN::META->set_perl5lib;
- local $ENV{MAKEFLAGS}; # protect us from outer make calls
-
- $CPAN::Frontend->myprint("Running $make test\n");
-
- EXCUSE: {
- my @e;
- if ($self->{make} or $self->{later}) {
- # go ahead
- } else {
- push @e,
- "Make had some problems, won't test";
- }
-
- exists $self->{make} and
- (
- UNIVERSAL::can($self->{make},"failed") ?
- $self->{make}->failed :
- $self->{make} =~ /^NO/
- ) and push @e, "Can't test without successful make";
- $self->{badtestcnt} ||= 0;
- if ($self->{badtestcnt} > 0) {
- require Data::Dumper;
- CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
- push @e, "Won't repeat unsuccessful test during this command";
- }
-
- push @e, $self->{later} if $self->{later};
- push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
-
- if (exists $self->{build_dir}) {
- if (exists $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
- ) {
- push @e, "Has already been tested within this command";
- }
- } else {
- push @e, "Has already been tested successfully";
- # 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});
- }
- }
- }
- } elsif (!@e) {
- push @e, "Has no own directory";
- }
- $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
- unless (chdir $self->{build_dir}) {
- push @e, "Couldn't chdir to '$self->{build_dir}': $!";
- }
- $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
- }
- $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") {
- 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 %env;
- while (my($k,$v) = each %ENV) {
- next unless defined $v;
- $env{$k} = $v;
- }
- local %ENV = %env;
- my $test_env;
- if ($self->prefs->{test}) {
- $test_env = $self->prefs->{test}{env};
- }
- if ($test_env) {
- for my $e (keys %$test_env) {
- $ENV{$e} = $test_env->{$e};
- }
- }
- 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;
- if ( $tests_ok ) {
- {
- my @prereq;
-
- # local $CPAN::DEBUG = 16; # Distribution
- for my $m (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 (@prereq) {
- my $cnt = @prereq;
- my $which = join ",", @prereq;
- my $but = $cnt == 1 ? "one dependency not OK ($which)" :
- "$cnt dependencies missing ($which)";
- $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 {
- $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;
-}
-
-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::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);
-}
-
-#-> sub CPAN::Distribution::install ;
-sub install {
- my($self) = @_;
- if (my $goto = $self->prefs->{goto}) {
- return $self->goto($goto);
- }
- unless ($self->{badtestcnt}) {
- $self->test;
- }
- if ($CPAN::Signal) {
- delete $self->{force_update};
- return;
- }
- my $make = $self->{modulebuild} ? "Build" : "make";
- $CPAN::Frontend->myprint("Running $make install\n");
- EXCUSE: {
- my @e;
- if ($self->{make} or $self->{later}) {
- # go ahead
- } else {
- push @e,
- "Make had some problems, won't install";
- }
-
- exists $self->{make} and
- (
- UNIVERSAL::can($self->{make},"failed") ?
- $self->{make}->failed :
- $self->{make} =~ /^NO/
- ) and
- push @e, "Make had returned bad status, install seems impossible";
-
- if (exists $self->{build_dir}) {
- } elsif (!@e) {
- push @e, "Has no own directory";
- }
-
- if (exists $self->{make_test} and
- (
- UNIVERSAL::can($self->{make_test},"failed") ?
- $self->{make_test}->failed :
- $self->{make_test} =~ /^NO/
- )) {
- if ($self->{force_update}) {
- $self->{make_test}->text("FAILED but failure ignored because ".
- "'force' in effect");
- } else {
- push @e, "make test had returned bad status, ".
- "won't install without force"
- }
- }
- if (exists $self->{install}) {
- if (UNIVERSAL::can($self->{install},"text") ?
- $self->{install}->text eq "YES" :
- $self->{install} =~ /^YES/
- ) {
- $CPAN::Frontend->myprint(" Already done\n");
- $CPAN::META->is_installed($self->{build_dir});
- return 1;
- } else {
- # comment in Todo on 2006-02-11; maybe retry?
- push @e, "Already tried without success";
- }
- }
-
- push @e, $self->{later} if $self->{later};
- push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
-
- $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
- unless (chdir $self->{build_dir}) {
- push @e, "Couldn't chdir to '$self->{build_dir}': $!";
- }
- $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
- }
- $self->debug("Changed directory to $self->{build_dir}")
- if $CPAN::DEBUG;
-
- 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();
- $system = sprintf("%s install %s",
- $mbuild_install_build_command,
- $CPAN::Config->{mbuild_install_arg},
- );
- } else {
- my($make_install_make_command) =
- CPAN::HandleConfig->prefs_lookup($self,
- q{make_install_make_command})
- || $self->_make_command();
- $system = sprintf("%s install %s",
- $make_install_make_command,
- $CPAN::Config->{make_install_arg},
- );
- }
-
- my($stderr) = $^O eq "MSWin32" ? "" : " 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'";
- $CPAN::Frontend->mywarn("Not installing because $is_only\n");
- $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
- delete $self->{force_update};
- return;
- }
- local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
- ? $ENV{PERL5LIB}
- : ($ENV{PERLLIB} || "");
-
- local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
- $CPAN::META->set_perl5lib;
- my($pipe) = FileHandle->new("$system $stderr |") || Carp::croak
-("Can't execute $system: $!");
- 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");
- } 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};
- $self->store_persistent_state;
-}
-
-sub introduce_myself {
- my($self) = @_;
- $CPAN::Frontend->myprint(sprintf(" %s\n",$self->pretty_id));
-}
-
-#-> sub CPAN::Distribution::dir ;
-sub dir {
- shift->{build_dir};
-}
-
-#-> sub CPAN::Distribution::perldoc ;
-sub perldoc {
- my($self) = @_;
-
- my($dist) = $self->id;
- my $package = $self->called_for;
-
- if ($CPAN::META->has_inst("Pod::Perldocs")) {
- my($perl) = $self->perl
- or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
- my @args = ($perl, q{-MPod::Perldocs}, q{-e},
- q{Pod::Perldocs->run()}, $package);
- my($wstatus);
- unless ( ($wstatus = system(@args)) == 0 ) {
- my $estatus = $wstatus >> 8;
- $CPAN::Frontend->myprint(qq{
- Function system("@args")
- returned status $estatus (wstat $wstatus)
- });
- }
- }
- else {
- $self->_display_url( $CPAN::Defaultdocs . $package );
- }
-}
-
-#-> sub CPAN::Distribution::_check_binary ;
-sub _check_binary {
- my ($dist,$shell,$binary) = @_;
- my ($pid,$out);
-
- $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
- if $CPAN::DEBUG;
-
- if ($CPAN::META->has_inst("File::Which")) {
- return File::Which::which($binary);
- } else {
- local *README;
- $pid = open README, "which $binary|"
- or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
- return unless $pid;
- while (<README>) {
- $out .= $_;
- }
- close README
- or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
- and return;
- }
-
- $CPAN::Frontend->myprint(qq{ + $out \n})
- if $CPAN::DEBUG && $out;
-
- return $out;
-}
-
-#-> sub CPAN::Distribution::_display_url ;
-sub _display_url {
- my($self,$url) = @_;
- my($res,$saved_file,$pid,$out);
-
- $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
- if $CPAN::DEBUG;
-
- # should we define it in the config instead?
- my $html_converter = "html2text.pl";
-
- my $web_browser = $CPAN::Config->{'lynx'} || undef;
- my $web_browser_out = $web_browser
- ? CPAN::Distribution->_check_binary($self,$web_browser)
- : undef;
-
- if ($web_browser_out) {
- # web browser found, run the action
- my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
- $CPAN::Frontend->myprint(qq{system[$browser $url]})
- if $CPAN::DEBUG;
- $CPAN::Frontend->myprint(qq{
-Displaying URL
- $url
-with browser $browser
-});
- $CPAN::Frontend->mysleep(1);
- system("$browser $url");
- if ($saved_file) { 1 while unlink($saved_file) }
- } else {
- # web browser not found, let's try text only
- my $html_converter_out =
- CPAN::Distribution->_check_binary($self,$html_converter);
- $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
-
- if ($html_converter_out ) {
- # html2text found, run it
- $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
- $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
- unless defined($saved_file);
-
- local *README;
- $pid = open README, "$html_converter $saved_file |"
- or $CPAN::Frontend->mydie(qq{
-Could not fork '$html_converter $saved_file': $!});
- my($fh,$filename);
- if ($CPAN::META->has_usable("File::Temp")) {
- $fh = File::Temp->new(
- dir => File::Spec->tmpdir,
- template => 'cpan_htmlconvert_XXXX',
- suffix => '.txt',
- unlink => 0,
- );
- $filename = $fh->filename;
- } else {
- $filename = "cpan_htmlconvert_$$.txt";
- $fh = FileHandle->new();
- open $fh, ">$filename" or die;
- }
- while (<README>) {
- $fh->print($_);
- }
- close README or
- $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
- my $tmpin = $fh->filename;
- $CPAN::Frontend->myprint(sprintf(qq{
-Run '%s %s' and
-saved output to %s\n},
- $html_converter,
- $saved_file,
- $tmpin,
- )) if $CPAN::DEBUG;
- close $fh;
- local *FH;
- open FH, $tmpin
- or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
- my $fh_pager = FileHandle->new;
- local($SIG{PIPE}) = "IGNORE";
- my $pager = $CPAN::Config->{'pager'} || "cat";
- $fh_pager->open("|$pager")
- or $CPAN::Frontend->mydie(qq{
-Could not open pager '$pager': $!});
- $CPAN::Frontend->myprint(qq{
-Displaying URL
- $url
-with pager "$pager"
-});
- $CPAN::Frontend->mysleep(1);
- $fh_pager->print(<FH>);
- $fh_pager->close;
- } else {
- # coldn't find the web browser or html converter
- $CPAN::Frontend->myprint(qq{
-You need to install lynx or $html_converter to use this feature.});
- }
- }
-}
-
-#-> sub CPAN::Distribution::_getsave_url ;
-sub _getsave_url {
- my($dist, $shell, $url) = @_;
-
- $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
- if $CPAN::DEBUG;
-
- my($fh,$filename);
- if ($CPAN::META->has_usable("File::Temp")) {
- $fh = File::Temp->new(
- dir => File::Spec->tmpdir,
- template => "cpan_getsave_url_XXXX",
- suffix => ".html",
- unlink => 0,
- );
- $filename = $fh->filename;
- } else {
- $fh = FileHandle->new;
- $filename = "cpan_getsave_url_$$.html";
- }
- my $tmpin = $filename;
- if ($CPAN::META->has_usable('LWP')) {
- $CPAN::Frontend->myprint("Fetching with LWP:
- $url
-");
- my $Ua;
- CPAN::LWP::UserAgent->config;
- eval { $Ua = CPAN::LWP::UserAgent->new; };
- if ($@) {
- $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
- return;
- } else {
- my($var);
- $Ua->proxy('http', $var)
- if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
- $Ua->no_proxy($var)
- if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
- }
-
- my $req = HTTP::Request->new(GET => $url);
- $req->header('Accept' => 'text/html');
- my $res = $Ua->request($req);
- if ($res->is_success) {
- $CPAN::Frontend->myprint(" + request successful.\n")
- if $CPAN::DEBUG;
- print $fh $res->content;
- close $fh;
- $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
- if $CPAN::DEBUG;
- return $tmpin;
- } else {
- $CPAN::Frontend->myprint(sprintf(
- "LWP failed with code[%s], message[%s]\n",
- $res->code,
- $res->message,
- ));
- return;
- }
- } else {
- $CPAN::Frontend->mywarn(" LWP not available\n");
- return;
- }
-}
-
-#-> sub CPAN::Distribution::_build_command
-sub _build_command {
- my($self) = @_;
- if ($^O eq "MSWin32") { # special code needed at least up to
- # Module::Build 0.2611 and 0.2706; a fix
- # in M:B has been promised 2006-01-30
- my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
- return "$perl ./Build";
- }
- 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->mywarn(
- "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;
- # was fuer ein Umweg!
- 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/Master/tlpkg/tlperl/lib/CPAN/Distroprefs.pm b/Master/tlpkg/tlperl/lib/CPAN/Distroprefs.pm
deleted file mode 100755
index e1be9cdf749..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Distroprefs.pm
+++ /dev/null
@@ -1,451 +0,0 @@
-# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
-# vim: ts=4 sts=4 sw=4:
-
-use strict;
-package CPAN::Distroprefs;
-
-use vars qw($VERSION);
-$VERSION = '6';
-
-package CPAN::Distroprefs::Result;
-
-use File::Spec;
-
-sub new { bless $_[1] || {} => $_[0] }
-
-sub abs { File::Spec->catfile($_[0]->dir, $_[0]->file) }
-
-sub __cloner {
- my ($class, $name, $newclass) = @_;
- $newclass = 'CPAN::Distroprefs::Result::' . $newclass;
- no strict 'refs';
- *{$class . '::' . $name} = sub {
- $newclass->new({
- %{ $_[0] },
- %{ $_[1] },
- });
- };
-}
-BEGIN { __PACKAGE__->__cloner(as_warning => 'Warning') }
-BEGIN { __PACKAGE__->__cloner(as_fatal => 'Fatal') }
-BEGIN { __PACKAGE__->__cloner(as_success => 'Success') }
-
-sub __accessor {
- my ($class, $key) = @_;
- no strict 'refs';
- *{$class . '::' . $key} = sub { $_[0]->{$key} };
-}
-BEGIN { __PACKAGE__->__accessor($_) for qw(type file ext dir) }
-
-sub is_warning { 0 }
-sub is_fatal { 0 }
-sub is_success { 0 }
-
-package CPAN::Distroprefs::Result::Error;
-use vars qw(@ISA);
-BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic
-BEGIN { __PACKAGE__->__accessor($_) for qw(msg) }
-
-sub as_string {
- my ($self) = @_;
- if ($self->msg) {
- return sprintf $self->fmt_reason, $self->file, $self->msg;
- } else {
- return sprintf $self->fmt_unknown, $self->file;
- }
-}
-
-package CPAN::Distroprefs::Result::Warning;
-use vars qw(@ISA);
-BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic
-sub is_warning { 1 }
-sub fmt_reason { "Error reading distroprefs file %s, skipping: %s" }
-sub fmt_unknown { "Unknown error reading distroprefs file %s, skipping." }
-
-package CPAN::Distroprefs::Result::Fatal;
-use vars qw(@ISA);
-BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic
-sub is_fatal { 1 }
-sub fmt_reason { "Error reading distroprefs file %s: %s" }
-sub fmt_unknown { "Unknown error reading distroprefs file %s." }
-
-package CPAN::Distroprefs::Result::Success;
-use vars qw(@ISA);
-BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic
-BEGIN { __PACKAGE__->__accessor($_) for qw(prefs extension) }
-sub is_success { 1 }
-
-package CPAN::Distroprefs::Iterator;
-
-sub new { bless $_[1] => $_[0] }
-
-sub next { $_[0]->() }
-
-package CPAN::Distroprefs;
-
-use Carp ();
-use DirHandle;
-
-sub _load_method {
- my ($self, $loader, $result) = @_;
- return '_load_yaml' if $loader eq 'CPAN' or $loader =~ /^YAML(::|$)/;
- return '_load_' . $result->ext;
-}
-
-sub _load_yaml {
- my ($self, $loader, $result) = @_;
- my $data = eval {
- $loader eq 'CPAN'
- ? $loader->_yaml_loadfile($result->abs)
- : [ $loader->can('LoadFile')->($result->abs) ]
- };
- if (my $err = $@) {
- die $result->as_warning({
- msg => $err,
- });
- } elsif (!$data) {
- die $result->as_warning;
- } else {
- return @$data;
- }
-}
-
-sub _load_dd {
- my ($self, $loader, $result) = @_;
- my @data;
- {
- package CPAN::Eval;
- # this caused a die in CPAN.pm, and I am leaving it 'fatal', though I'm
- # not sure why we wouldn't just skip the file as we do for all other
- # errors. -- hdp
- my $abs = $result->abs;
- open FH, "<$abs" or die $result->as_fatal(msg => "$!");
- local $/;
- my $eval = <FH>;
- close FH;
- no strict;
- eval $eval;
- if (my $err = $@) {
- die $result->as_warning({ msg => $err });
- }
- my $i = 1;
- while (${"VAR$i"}) {
- push @data, ${"VAR$i"};
- $i++;
- }
- }
- return @data;
-}
-
-sub _load_st {
- my ($self, $loader, $result) = @_;
- # eval because Storable is never forward compatible
- my @data = eval { @{scalar $loader->can('retrieve')->($result->abs) } };
- if (my $err = $@) {
- die $result->as_warning({ msg => $err });
- }
- return @data;
-}
-
-sub find {
- my ($self, $dir, $ext_map) = @_;
-
- my $dh = DirHandle->new($dir) or Carp::croak("Couldn't open '$dir': $!");
- my @files = sort $dh->read;
-
- # label the block so that we can use redo in the middle
- return CPAN::Distroprefs::Iterator->new(sub { LOOP: {
- return unless %$ext_map;
-
- local $_ = shift @files;
- return unless defined;
- redo if $_ eq '.' || $_ eq '..';
-
- my $possible_ext = join "|", map { quotemeta } keys %$ext_map;
- my ($ext) = /\.($possible_ext)$/ or redo;
- my $loader = $ext_map->{$ext};
-
- my $result = CPAN::Distroprefs::Result->new({
- file => $_, ext => $ext, dir => $dir
- });
- # copied from CPAN.pm; is this ever actually possible?
- redo unless -f $result->abs;
-
- my $load_method = $self->_load_method($loader, $result);
- my @prefs = eval { $self->$load_method($loader, $result) };
- if (my $err = $@) {
- if (ref($err) && eval { $err->isa('CPAN::Distroprefs::Result') }) {
- return $err;
- }
- # rethrow any exceptions that we did not generate
- die $err;
- } elsif (!@prefs) {
- # the loader should have handled this, but just in case:
- return $result->as_warning;
- }
- return $result->as_success({
- prefs => [
- map { CPAN::Distroprefs::Pref->new({ data => $_ }) } @prefs
- ],
- });
- } });
-}
-
-package CPAN::Distroprefs::Pref;
-
-use Carp ();
-
-sub new { bless $_[1] => $_[0] }
-
-sub data { shift->{data} }
-
-sub has_any_match { $_[0]->data->{match} ? 1 : 0 }
-
-sub has_match {
- my $match = $_[0]->data->{match} || return 0;
- exists $match->{$_[1]} || exists $match->{"not_$_[1]"}
-}
-
-sub has_valid_subkeys {
- grep { exists $_[0]->data->{match}{$_} }
- map { $_, "not_$_" }
- $_[0]->match_attributes
-}
-
-sub _pattern {
- my $re = shift;
- my $p = eval sprintf 'qr{%s}', $re;
- if ($@) {
- $@ =~ s/\n$//;
- die "Error in Distroprefs pattern qr{$re}\n$@";
- }
- return $p;
-}
-
-sub _match_scalar {
- my ($match, $data) = @_;
- my $qr = _pattern($match);
- return $data =~ /$qr/;
-}
-
-sub _match_hash {
- my ($match, $data) = @_;
- for my $mkey (keys %$match) {
- (my $dkey = $mkey) =~ s/^not_//;
- my $val = defined $data->{$dkey} ? $data->{$dkey} : '';
- if (_match_scalar($match->{$mkey}, $val)) {
- return 0 if $mkey =~ /^not_/;
- }
- else {
- return 0 if $mkey !~ /^not_/;
- }
- }
- return 1;
-}
-
-sub _match {
- my ($self, $key, $data, $matcher) = @_;
- my $m = $self->data->{match};
- if (exists $m->{$key}) {
- return 0 unless $matcher->($m->{$key}, $data);
- }
- if (exists $m->{"not_$key"}) {
- return 0 if $matcher->($m->{"not_$key"}, $data);
- }
- return 1;
-}
-
-sub _scalar_match {
- my ($self, $key, $data) = @_;
- return $self->_match($key, $data, \&_match_scalar);
-}
-
-sub _hash_match {
- my ($self, $key, $data) = @_;
- return $self->_match($key, $data, \&_match_hash);
-}
-
-# do not take the order of C<keys %$match> because "module" is by far the
-# slowest
-sub match_attributes { qw(env distribution perl perlconfig module) }
-
-sub match_module {
- my ($self, $modules) = @_;
- return $self->_match("module", $modules, sub {
- my($match, $data) = @_;
- my $qr = _pattern($match);
- for my $module (@$data) {
- return 1 if $module =~ /$qr/;
- }
- return 0;
- });
-}
-
-sub match_distribution { shift->_scalar_match(distribution => @_) }
-sub match_perl { shift->_scalar_match(perl => @_) }
-
-sub match_perlconfig { shift->_hash_match(perlconfig => @_) }
-sub match_env { shift->_hash_match(env => @_) }
-
-sub matches {
- my ($self, $arg) = @_;
-
- my $default_match = 0;
- for my $key (grep { $self->has_match($_) } $self->match_attributes) {
- unless (exists $arg->{$key}) {
- Carp::croak "Can't match pref: missing argument key $key";
- }
- $default_match = 1;
- my $val = $arg->{$key};
- # make it possible to avoid computing things until we have to
- if (ref($val) eq 'CODE') { $val = $val->() }
- my $meth = "match_$key";
- return 0 unless $self->$meth($val);
- }
-
- return $default_match;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-CPAN::Distroprefs -- read and match distroprefs
-
-=head1 SYNOPSIS
-
- use CPAN::Distroprefs;
-
- my %info = (... distribution/environment info ...);
-
- my $finder = CPAN::Distroprefs->find($prefs_dir, \%ext_map);
-
- while (my $result = $finder->next) {
-
- die $result->as_string if $result->is_fatal;
-
- warn($result->as_string), next if $result->is_warning;
-
- for my $pref (@{ $result->prefs }) {
- if ($pref->matches(\%info)) {
- return $pref;
- }
- }
- }
-
-
-=head1 DESCRIPTION
-
-This module encapsulates reading L<Distroprefs|CPAN> and matching them against CPAN distributions.
-
-=head1 INTERFACE
-
- my $finder = CPAN::Distroprefs->find($dir, \%ext_map);
-
- while (my $result = $finder->next) { ... }
-
-Build an iterator which finds distroprefs files in the given directory.
-
-C<%ext_map> is a hashref whose keys are file extensions and whose values are
-modules used to load matching files:
-
- {
- 'yml' => 'YAML::Syck',
- 'dd' => 'Data::Dumper',
- ...
- }
-
-Each time C<< $finder->next >> is called, the iterator returns one of two
-possible values:
-
-=over
-
-=item * a CPAN::Distroprefs::Result object
-
-=item * C<undef>, indicating that no prefs files remain to be found
-
-=back
-
-=head1 RESULTS
-
-L<C<find()>|/INTERFACE> returns CPAN::Distroprefs::Result objects to
-indicate success or failure when reading a prefs file.
-
-=head2 Common
-
-All results share some common attributes:
-
-=head3 type
-
-C<success>, C<warning>, or C<fatal>
-
-=head3 file
-
-the file from which these prefs were read, or to which this error refers (relative filename)
-
-=head3 ext
-
-the file's extension, which determines how to load it
-
-=head3 dir
-
-the directory the file was read from
-
-=head3 abs
-
-the absolute path to the file
-
-=head2 Errors
-
-Error results (warning and fatal) contain:
-
-=head3 msg
-
-the error message (usually either C<$!> or a YAML error)
-
-=head2 Successes
-
-Success results contain:
-
-=head3 prefs
-
-an arrayref of CPAN::Distroprefs::Pref objects
-
-=head1 PREFS
-
-CPAN::Distroprefs::Pref objects represent individual distroprefs documents.
-They are constructed automatically as part of C<success> results from C<find()>.
-
-=head3 data
-
-the pref information as a hashref, suitable for e.g. passing to Kwalify
-
-=head3 match_attributes
-
-returns a list of the valid match attributes (see the Distroprefs section in L<CPAN>)
-
-currently: C<env perl perlconfig distribution module>
-
-=head3 has_any_match
-
-true if this pref has a 'match' attribute at all
-
-=head3 has_valid_subkeys
-
-true if this pref has a 'match' attribute and at least one valid match attribute
-
-=head3 matches
-
- if ($pref->matches(\%arg)) { ... }
-
-true if this pref matches the passed-in hashref, which must have a value for
-each of the C<match_attributes> (above)
-
-=head1 LICENSE
-
-This program is free software; you can redistribute it and/or modify it under
-the same terms as Perl itself.
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Distrostatus.pm b/Master/tlpkg/tlperl/lib/CPAN/Distrostatus.pm
deleted file mode 100755
index 0cc6cc9a793..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Distrostatus.pm
+++ /dev/null
@@ -1,45 +0,0 @@
-# -*- 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/Master/tlpkg/tlperl/lib/CPAN/Exception/RecursiveDependency.pm b/Master/tlpkg/tlperl/lib/CPAN/Exception/RecursiveDependency.pm
deleted file mode 100755
index b928ad74e31..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Exception/RecursiveDependency.pm
+++ /dev/null
@@ -1,85 +0,0 @@
-# -*- 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.5";
-
-# 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;
- 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 || "N/A";
- 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)";
- } elsif ($xo->isa("CPAN::Distribution")) {
- $deps[$i]{display_as} = $xo->pretty_id;
- if ($in_loop) {
- $xo->{make} = CPAN::Distrostatus->new("NO cannot resolve circular dependency");
- } else {
- $xo->{make} = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency");
- }
- $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 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/Master/tlpkg/tlperl/lib/CPAN/Exception/blocked_urllist.pm b/Master/tlpkg/tlperl/lib/CPAN/Exception/blocked_urllist.pm
deleted file mode 100755
index 102c194e612..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Exception/blocked_urllist.pm
+++ /dev/null
@@ -1,46 +0,0 @@
-# -*- 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.0";
-
-
-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/Master/tlpkg/tlperl/lib/CPAN/Exception/yaml_not_installed.pm b/Master/tlpkg/tlperl/lib/CPAN/Exception/yaml_not_installed.pm
deleted file mode 100755
index e1259e5397d..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Exception/yaml_not_installed.pm
+++ /dev/null
@@ -1,73 +0,0 @@
-# -*- 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";
-}
-
-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/Master/tlpkg/tlperl/lib/CPAN/FTP.pm b/Master/tlpkg/tlperl/lib/CPAN/FTP.pm
deleted file mode 100755
index 268ca284678..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/FTP.pm
+++ /dev/null
@@ -1,1074 +0,0 @@
-# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
-# vim: ts=4 sts=4 sw=4:
-package CPAN::FTP;
-use strict;
-
-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.5004";
-
-#-> 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;
- $fh ||= FileHandle->new;
- my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
- mkpath dirname $file;
- open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
- my $sleep = 1;
- my $waitstart;
- while (!CPAN::_flock($fh, $locktype|LOCK_NB)) {
- $waitstart ||= localtime();
- if ($sleep>3) {
- $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
- }
- $CPAN::Frontend->mysleep($sleep);
- if ($sleep <= 3) {
- $sleep+=0.33;
- } elsif ($sleep <=6) {
- $sleep+=0.11;
- }
- }
- my $stats = eval { CPAN->_yaml_loadfile($file); };
- if ($@) {
- if (ref $@) {
- if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
- $CPAN::Frontend->myprint("Warning (usually harmless): $@\n");
- return;
- } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
- $CPAN::Frontend->mydie($@);
- }
- } else {
- $CPAN::Frontend->mydie($@);
- }
- }
- 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->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
- }
-}
-
-# Copy some stat information (owner, group, mode and) from one file to
-# another.
-# This is a utility function which might be moved to a utility repository.
-#-> sub CPAN::FTP::_copy_stat
-sub _copy_stat {
- my($src, $dest) = @_;
- my @stat = stat($src);
- if (!@stat) {
- $CPAN::Frontend->mywarn("Can't stat '$src': $!\n");
- return;
- }
-
- eval {
- chmod $stat[2], $dest
- or $CPAN::Frontend->mywarn("Can't chmod '$dest' to " . sprintf("0%o", $stat[2]) . ": $!\n");
- };
- warn $@ if $@;
- eval {
- chown $stat[4], $stat[5], $dest
- or do {
- my $save_err = $!; # otherwise it's lost in the get... calls
- $CPAN::Frontend->mywarn("Can't chown '$dest' to " .
- (getpwuid($stat[4]))[0] . "/" .
- (getgrgid($stat[5]))[0] . ": $save_err\n"
- );
- };
- };
- warn $@ if $@;
-}
-
-# if file is CHECKSUMS, suggest the place where we got the file to be
-# checked from, maybe only for young files?
-#-> sub CPAN::FTP::_recommend_url_for
-sub _recommend_url_for {
- my($self, $file, $urllist) = @_;
- if ($file =~ s|/CHECKSUMS(.gz)?$||) {
- my $fullstats = $self->_ftp_statistics();
- my $history = $fullstats->{history} || [];
- while (my $last = pop @$history) {
- last if $last->{end} - time > 3600; # only young results are interesting
- next unless $last->{file}; # dirname of nothing dies!
- next unless $file eq dirname($last->{file});
- return $last->{thesiteurl};
- }
- }
- if ($CPAN::Config->{randomize_urllist}
- &&
- rand(1) < $CPAN::Config->{randomize_urllist}
- ) {
- $urllist->[int rand scalar @$urllist];
- } else {
- return ();
- }
-}
-
-#-> sub CPAN::FTP::_get_urllist
-sub _get_urllist {
- my($self, $with_defaults) = @_;
- $with_defaults ||= 0;
- CPAN->debug("with_defaults[$with_defaults]") if $CPAN::DEBUG;
-
- $CPAN::Config->{urllist} ||= [];
- unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
- $CPAN::Frontend->mywarn("Malformed urllist; ignoring. Configuration file corrupt?\n");
- $CPAN::Config->{urllist} = [];
- }
- my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
- push @urllist, @CPAN::Defaultsites if $with_defaults;
- for my $u (@urllist) {
- CPAN->debug("u[$u]") if $CPAN::DEBUG;
- if (UNIVERSAL::can($u,"text")) {
- $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
- } else {
- $u .= "/" unless substr($u,-1) eq "/";
- $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
- }
- }
- \@urllist;
-}
-
-#-> sub CPAN::FTP::ftp_get ;
-sub ftp_get {
- my($class,$host,$dir,$file,$target) = @_;
- $class->debug(
- qq[Going to fetch file [$file] from dir [$dir]
- on host [$host] as local [$target]\n]
- ) if $CPAN::DEBUG;
- my $ftp = Net::FTP->new($host);
- unless ($ftp) {
- $CPAN::Frontend->mywarn(" Could not connect to host '$host' with Net::FTP\n");
- return;
- }
- return 0 unless defined $ftp;
- $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
- $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
- unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ) {
- my $msg = $ftp->message;
- $CPAN::Frontend->mywarn(" Couldn't login on $host: $msg\n");
- return;
- }
- unless ( $ftp->cwd($dir) ) {
- my $msg = $ftp->message;
- $CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg\n");
- return;
- }
- $ftp->binary;
- $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
- unless ( $ftp->get($file,$target) ) {
- my $msg = $ftp->message;
- $CPAN::Frontend->mywarn(" Couldn't fetch $file from $host: $msg\n");
- return;
- }
- $ftp->quit; # it's ok if this fails
- return 1;
-}
-
-# If more accuracy is wanted/needed, Chris Leach sent me this patch...
-
- # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
- # > --- /tmp/cp Wed Sep 24 13:26:40 1997
- # > ***************
- # > *** 1562,1567 ****
- # > --- 1562,1580 ----
- # > return 1 if substr($url,0,4) eq "file";
- # > return 1 unless $url =~ m|://([^/]+)|;
- # > my $host = $1;
- # > + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
- # > + if ($proxy) {
- # > + $proxy =~ m|://([^/:]+)|;
- # > + $proxy = $1;
- # > + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
- # > + if ($noproxy) {
- # > + if ($host !~ /$noproxy$/) {
- # > + $host = $proxy;
- # > + }
- # > + } else {
- # > + $host = $proxy;
- # > + }
- # > + }
- # > require Net::Ping;
- # > return 1 unless $Net::Ping::VERSION >= 2;
- # > my $p;
-
-
-#-> sub CPAN::FTP::localize ;
-sub localize {
- my($self,$file,$aslocal,$force,$with_defaults) = @_;
- $force ||= 0;
- Carp::croak( "Usage: ->localize(cpan_file,as_local_file[,\$force])" )
- unless defined $aslocal;
- if ($CPAN::DEBUG){
- require Carp;
- my $longmess = Carp::longmess();
- $self->debug("file[$file] aslocal[$aslocal] force[$force] carplongmess[$longmess]");
- }
- if ($^O eq 'MacOS') {
- # Comment by AK on 2000-09-03: Uniq short filenames would be
- # available in CHECKSUMS file
- my($name, $path) = File::Basename::fileparse($aslocal, '');
- if (length($name) > 31) {
- $name =~ s/(
- \.(
- readme(\.(gz|Z))? |
- (tar\.)?(gz|Z) |
- tgz |
- zip |
- pm\.(gz|Z)
- )
- )$//x;
- my $suf = $1;
- my $size = 31 - length($suf);
- while (length($name) > $size) {
- chop $name;
- }
- $name .= $suf;
- $aslocal = File::Spec->catfile($path, $name);
- }
- }
-
- if (-f $aslocal && -r _ && !($force & 1)) {
- my $size;
- if ($size = -s $aslocal) {
- $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
- return $aslocal;
- } else {
- # empty file from a previous unsuccessful attempt to download it
- unlink $aslocal or
- $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
- "could not remove.");
- }
- }
- my($maybe_restore) = 0;
- if (-f $aslocal) {
- rename $aslocal, "$aslocal.bak$$";
- $maybe_restore++;
- }
-
- my($aslocal_dir) = dirname($aslocal);
- # Inheritance is not easier to manage than a few if/else branches
- if ($CPAN::META->has_usable('LWP::UserAgent')) {
- unless ($Ua) {
- CPAN::LWP::UserAgent->config;
- eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
- if ($@) {
- $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
- if $CPAN::DEBUG;
- } else {
- my($var);
- $Ua->proxy('ftp', $var)
- if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
- $Ua->proxy('http', $var)
- if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
- $Ua->no_proxy($var)
- if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
- }
- }
- }
- for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
- $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
- }
-
- # Try the list of urls for each single object. We keep a record
- # where we did get a file from
- my(@reordered,$last);
- my $ccurllist = $self->_get_urllist($with_defaults);
- $last = $#$ccurllist;
- if ($force & 2) { # local cpans probably out of date, don't reorder
- @reordered = (0..$last);
- } else {
- @reordered =
- sort {
- (substr($ccurllist->[$b],0,4) eq "file")
- <=>
- (substr($ccurllist->[$a],0,4) eq "file")
- or
- defined($ThesiteURL)
- and
- ($ccurllist->[$b] eq $ThesiteURL)
- <=>
- ($ccurllist->[$a] eq $ThesiteURL)
- } 0..$last;
- }
- my(@levels);
- $Themethod ||= "";
- $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
- my @all_levels = (
- ["dleasy", "file"],
- ["dleasy"],
- ["dlhard"],
- ["dlhardest"],
- ["dleasy", "http","defaultsites"],
- ["dlhard", "http","defaultsites"],
- ["dleasy", "ftp", "defaultsites"],
- ["dlhard", "ftp", "defaultsites"],
- ["dlhardest","", "defaultsites"],
- );
- if ($Themethod) {
- @levels = grep {$_->[0] eq $Themethod} @all_levels;
- push @levels, grep {$_->[0] ne $Themethod} @all_levels;
- } else {
- @levels = @all_levels;
- }
- @levels = qw/dleasy/ if $^O eq 'MacOS';
- my($levelno);
- local $ENV{FTP_PASSIVE} =
- exists $CPAN::Config->{ftp_passive} ?
- $CPAN::Config->{ftp_passive} : 1;
- my $ret;
- my $stats = $self->_new_stats($file);
- for ($CPAN::Config->{connect_to_internet_ok}) {
- $connect_to_internet_ok = $_ if not defined $connect_to_internet_ok and defined $_;
- }
- LEVEL: for $levelno (0..$#levels) {
- my $level_tuple = $levels[$levelno];
- my($level,$scheme,$sitetag) = @$level_tuple;
- $self->mymkpath($aslocal_dir) unless $scheme && "file" eq $scheme;
- my $defaultsites = $sitetag && $sitetag eq "defaultsites" && !@$ccurllist;
- my @urllist;
- if ($defaultsites) {
- unless (defined $connect_to_internet_ok) {
- $CPAN::Frontend->myprint(sprintf qq{
-I would like to connect to one of the following sites to get '%s':
-
-%s
-},
- $file,
- join("",map { " ".$_->text."\n" } @CPAN::Defaultsites),
- );
- my $answer = CPAN::Shell::colorable_makemaker_prompt("Is it OK to try to connect to the Internet?", "yes");
- if ($answer =~ /^y/i) {
- $connect_to_internet_ok = 1;
- } else {
- $connect_to_internet_ok = 0;
- }
- }
- if ($connect_to_internet_ok) {
- @urllist = @CPAN::Defaultsites;
- } else {
- my $sleep = 2;
- # the tricky thing about dying here is that everybody
- # believes that calls to exists() or all_objects() are
- # safe.
- require CPAN::Exception::blocked_urllist;
- die CPAN::Exception::blocked_urllist->new;
- }
- } else { # ! $defaultsites
- my @host_seq = $level =~ /dleasy/ ?
- @reordered : 0..$last; # reordered has file and $Thesiteurl first
- @urllist = map { $ccurllist->[$_] } @host_seq;
- }
- $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
- my $aslocal_tempfile = $aslocal . ".tmp" . $$;
- if (my $recommend = $self->_recommend_url_for($file,\@urllist)) {
- @urllist = grep { $_ ne $recommend } @urllist;
- unshift @urllist, $recommend;
- }
- $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
- $ret = $self->hostdlxxx($level,$scheme,\@urllist,$file,$aslocal_tempfile,$stats);
- if ($ret) {
- CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
- if ($ret eq $aslocal_tempfile) {
- # if we got it exactly as we asked for, only then we
- # want to rename
- rename $aslocal_tempfile, $aslocal
- or $CPAN::Frontend->mydie("Error while trying to rename ".
- "'$ret' to '$aslocal': $!");
- $ret = $aslocal;
- }
- elsif (-f $ret && $scheme eq 'file' ) {
- # it's a local file, so there's nothing left to do, we
- # let them read from where it is
- }
- $Themethod = $level;
- my $now = time;
- # utime $now, $now, $aslocal; # too bad, if we do that, we
- # might alter a local mirror
- $self->debug("level[$level]") if $CPAN::DEBUG;
- last LEVEL;
- } else {
- unlink $aslocal_tempfile;
- last if $CPAN::Signal; # need to cleanup
- }
- }
- if ($ret) {
- $stats->{filesize} = -s $ret;
- }
- $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
- $self->_add_to_statistics($stats);
- $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
- if ($ret) {
- unlink "$aslocal.bak$$";
- return $ret;
- }
- unless ($CPAN::Signal) {
- my(@mess);
- local $" = " ";
- if (@{$CPAN::Config->{urllist}}) {
- push @mess,
- qq{Please check, if the URLs I found in your configuration file \(}.
- join(", ", @{$CPAN::Config->{urllist}}).
- qq{\) are valid.};
- } else {
- push @mess, qq{Your urllist is empty!};
- }
- push @mess, qq{The urllist can be edited.},
- qq{E.g. with 'o conf urllist push ftp://myurl/'};
- $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
- $CPAN::Frontend->mydie("Could not fetch $file\n");
- }
- if ($maybe_restore) {
- rename "$aslocal.bak$$", $aslocal;
- $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
- $self->ls($aslocal) . "\n");
- return $aslocal;
- }
- return;
-}
-
-sub mymkpath {
- my($self, $aslocal_dir) = @_;
- mkpath($aslocal_dir);
- $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
- qq{directory "$aslocal_dir".
- I\'ll continue, but if you encounter problems, they may be due
- to insufficient permissions.\n}) unless -w $aslocal_dir;
-}
-
-sub hostdlxxx {
- my $self = shift;
- my $level = shift;
- my $scheme = shift;
- my $h = shift;
- $h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme;
- my $method = "host$level";
- $self->$method($h, @_);
-}
-
-sub _set_attempt {
- my($self,$stats,$method,$url) = @_;
- push @{$stats->{attempts}}, {
- method => $method,
- start => _mytime,
- url => $url,
- };
-}
-
-# package CPAN::FTP;
-sub hostdleasy { #called from hostdlxxx
- my($self,$host_seq,$file,$aslocal,$stats) = @_;
- my($ro_url);
- HOSTEASY: for $ro_url (@$host_seq) {
- $self->_set_attempt($stats,"dleasy",$ro_url);
- my $url .= "$ro_url$file";
- $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
- if ($url =~ /^file:/) {
- my $l;
- if ($CPAN::META->has_inst('URI::URL')) {
- my $u = URI::URL->new($url);
- $l = $u->file;
- } else { # works only on Unix, is poorly constructed, but
- # hopefully better than nothing.
- # RFC 1738 says fileurl BNF is
- # fileurl = "file://" [ host | "localhost" ] "/" fpath
- # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
- # the code
- ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
- $l =~ s|^file:||; # assume they
- # meant
- # file://localhost
- $l =~ s|^/||s
- if ! -f $l && $l =~ m|^/\w:|; # e.g. /P:
- }
- $self->debug("local file[$l]") if $CPAN::DEBUG;
- if ( -f $l && -r _) {
- $ThesiteURL = $ro_url;
- return $l;
- }
- # If request is for a compressed file and we can find the
- # uncompressed file also, return the path of the uncompressed file
- # otherwise, decompress it and return the resulting path
- if ($l =~ /(.+)\.gz$/) {
- my $ungz = $1;
- if ( -f $ungz && -r _) {
- $ThesiteURL = $ro_url;
- return $ungz;
- }
- else {
- eval { CPAN::Tarzip->new($l)->gunzip($aslocal) };
- if ( -f $aslocal) {
- $ThesiteURL = $ro_url;
- return $aslocal;
- }
- else {
- $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.
- }
- } else {
- $CPAN::Frontend->mywarn(" LWP not available\n");
- }
- return if $CPAN::Signal;
- if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
- # that's the nice and easy way thanks to Graham
- $self->debug("recognized ftp") if $CPAN::DEBUG;
- my($host,$dir,$getfile) = ($1,$2,$3);
- if ($CPAN::META->has_usable('Net::FTP')) {
- $dir =~ s|/+|/|g;
- $CPAN::Frontend->myprint("Fetching with Net::FTP:\n$url\n");
- $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
- "aslocal[$aslocal]") if $CPAN::DEBUG;
- if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
- $ThesiteURL = $ro_url;
- return $aslocal;
- }
- if ($aslocal !~ /\.gz(?!\n)\Z/) {
- my $gz = "$aslocal.gz";
- $CPAN::Frontend->myprint("Fetching with Net::FTP\n$url.gz\n");
- if (CPAN::FTP->ftp_get($host,
- $dir,
- "$getfile.gz",
- $gz) &&
- eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
- ) {
- $ThesiteURL = $ro_url;
- return $aslocal;
- }
- }
- # next HOSTEASY;
- } else {
- CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
- }
- }
- if (
- UNIVERSAL::can($ro_url,"text")
- and
- $ro_url->{FROM} eq "USER"
- ) {
- ##address #17973: default URLs should not try to override
- ##user-defined URLs just because LWP is not available
- my $ret = $self->hostdlhard([$ro_url],$file,$aslocal,$stats);
- return $ret if $ret;
- }
- return if $CPAN::Signal;
- }
-}
-
-# package CPAN::FTP;
-sub hostdlhard {
- my($self,$host_seq,$file,$aslocal,$stats) = @_;
-
- # Came back if Net::FTP couldn't establish connection (or
- # failed otherwise) Maybe they are behind a firewall, but they
- # gave us a socksified (or other) ftp program...
-
- my($ro_url);
- my($devnull) = $CPAN::Config->{devnull} || "";
- # < /dev/null ";
- my($aslocal_dir) = dirname($aslocal);
- mkpath($aslocal_dir);
- my $some_dl_success = 0;
- my $any_attempt = 0;
- HOSTHARD: for $ro_url (@$host_seq) {
- $self->_set_attempt($stats,"dlhard",$ro_url);
- my $url = "$ro_url$file";
- my($proto,$host,$dir,$getfile);
-
- # Courtesy Mark Conty mark_conty@cargill.com change from
- # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
- # to
- if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
- # proto not yet used
- ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
- } else {
- next HOSTHARD; # who said, we could ftp anything except ftp?
- }
- next HOSTHARD if $proto eq "file"; # file URLs would have had
- # success above. Likely a bogus URL
-
- # making at least one attempt against a host
- $any_attempt++;
-
- $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
-
- # Try the most capable first and leave ncftp* for last as it only
- # does FTP.
- my $proxy_vars = $self->_proxy_vars($ro_url);
- DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
- my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
- next DLPRG unless defined $funkyftp;
- next DLPRG if $funkyftp =~ /^\s*$/;
-
- my($src_switch) = "";
- my($chdir) = "";
- my($stdout_redir) = " > \"$aslocal\"";
- if ($f eq "lynx") {
- $src_switch = " -source";
- } elsif ($f eq "ncftp") {
- next DLPRG unless $url =~ m{\Aftp://};
- $src_switch = " -c";
- } elsif ($f eq "wget") {
- $src_switch = " -O \"$aslocal\"";
- $stdout_redir = "";
- } elsif ($f eq 'curl') {
- $src_switch = ' -L -f -s -S --netrc-optional';
- if ($proxy_vars->{http_proxy}) {
- $src_switch .= qq{ -U "$proxy_vars->{proxy_user}:$proxy_vars->{proxy_pass}" -x "$proxy_vars->{http_proxy}"};
- }
- } elsif ($f eq "ncftpget") {
- next DLPRG unless $url =~ m{\Aftp://};
- $chdir = "cd $aslocal_dir && ";
- $stdout_redir = "";
- }
- $CPAN::Frontend->myprint(
- qq[
-Trying with
- $funkyftp$src_switch
-to get
- $url
-]);
- my($system) =
- "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
- $self->debug("system[$system]") if $CPAN::DEBUG;
- my($wstatus) = system($system);
- if ($f eq "lynx") {
- # lynx returns 0 when it fails somewhere
- if (-s $aslocal) {
- my $content = do { local *FH;
- open FH, $aslocal or die;
- local $/;
- <FH> };
- if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
- $CPAN::Frontend->mywarn(qq{
-No success, the file that lynx has downloaded looks like an error message:
-$content
-});
- $CPAN::Frontend->mysleep(1);
- next DLPRG;
- }
- $some_dl_success++;
- } else {
- $CPAN::Frontend->myprint(qq{
-No success, the file that lynx has downloaded is an empty file.
-});
- next DLPRG;
- }
- }
- if ($wstatus == 0) {
- if (-s $aslocal) {
- # Looks good
- $some_dl_success++;
- }
- $ThesiteURL = $ro_url;
- return $aslocal;
- } else {
- my $estatus = $wstatus >> 8;
- my $size = -f $aslocal ?
- ", left\n$aslocal with size ".-s _ :
- "\nWarning: expected file [$aslocal] doesn't exist";
- $CPAN::Frontend->myprint(qq{
- Function system("$system")
- returned status $estatus (wstat $wstatus)$size
- });
- }
- return if $CPAN::Signal;
- } # download/transfer programs (DLPRG)
- } # host
- return unless $any_attempt;
- if ($some_dl_success) {
- $CPAN::Frontend->mywarn("Warning: doesn't seem we had substantial success downloading '$aslocal'. Don't know how to proceed.\n");
- } else {
- $CPAN::Frontend->mywarn("Warning: no success downloading '$aslocal'. Giving up on it.\n");
- }
- return;
-}
-
-#-> CPAN::FTP::_proxy_vars
-sub _proxy_vars {
- my($self,$url) = @_;
- my $ret = +{};
- my $http_proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
- if ($http_proxy) {
- my($host) = $url =~ m|://([^/:]+)|;
- my $want_proxy = 1;
- my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'} || "";
- my @noproxy = split /\s*,\s*/, $noproxy;
- if ($host) {
- DOMAIN: for my $domain (@noproxy) {
- if ($host =~ /\Q$domain\E$/) { # cf. LWP::UserAgent
- $want_proxy = 0;
- last DOMAIN;
- }
- }
- } else {
- $CPAN::Frontend->mywarn(" Could not determine host from http_proxy '$http_proxy'\n");
- }
- if ($want_proxy) {
- my($user, $pass) =
- &CPAN::LWP::UserAgent::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
- Going to send 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
- Going to send 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/Master/tlpkg/tlperl/lib/CPAN/FTP/netrc.pm b/Master/tlpkg/tlperl/lib/CPAN/FTP/netrc.pm
deleted file mode 100755
index c05405e7ef6..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/FTP/netrc.pm
+++ /dev/null
@@ -1,63 +0,0 @@
-package CPAN::FTP::netrc;
-use strict;
-
-$CPAN::FTP::netrc::VERSION = $CPAN::FTP::netrc::VERSION = "1.00";
-
-# package CPAN::FTP::netrc;
-sub new {
- my($class) = @_;
- my $home = CPAN::HandleConfig::home();
- my $file = File::Spec->catfile($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/Master/tlpkg/tlperl/lib/CPAN/FirstTime.pm b/Master/tlpkg/tlperl/lib/CPAN/FirstTime.pm
deleted file mode 100755
index d1db0cdaf26..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/FirstTime.pm
+++ /dev/null
@@ -1,1797 +0,0 @@
-# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 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 $silent);
-$VERSION = "5.53";
-
-=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 safes 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 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.
-
-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
- backtickcwd external command cwd
-
-Preferred method for determining the current working directory?
-
-=item halt_on_failure
-
-Normaly, 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.
-
-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 RETURN 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
-
-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
-
-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 one 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'). 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 scan_cache
-
-By default, each time the CPAN module is started, cache scanning is
-performed to keep the cache size in sync. To prevent this, answer
-'never'.
-
-Perform cache scanning (atstart 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 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 (aka 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 email 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 email,
-you will need to configure CPAN::Reporter before sending reports.
-
-Email 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 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_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 = (
-
-manual_config => qq[
-CPAN is the world-wide archive of perl resources. It consists of about
-300 sites that all replicate the same contents around the globe. Many
-countries have at least one CPAN site already. The resources found on
-CPAN are easily accessible with the CPAN.pm module. If you want to use
-CPAN.pm, lots of things have to be configured. Fortunately, most of
-them can be determined automatically. If you prefer the automatic
-configuration, answer 'yes' below.
-
-If you prefer to enter a dialog instead, you can answer 'no' to this
-question and I'll let you configure in small steps one thing after the
-other. (Note: you can revisit this dialog anytime later by typing 'o
-conf init' at the cpan prompt.)
-
-],
-
-auto_pick => qq{
-Would you like me to automatically choose the best CPAN mirror
-sites for you? (This means connecting to the Internet and could
-take a couple minutes)},
-
-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 RETURN. 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
-RETURN. 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!
-
-},
-
- );
-
- 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 = 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
- #
-
- unless ($matcher) {
- $CPAN::Frontend->myprint($prompts{manual_config});
- }
-
- my $manual_conf;
-
- local *_real_prompt;
- if ( $args{autoconfig} ) {
- $manual_conf = "no";
- } elsif ($matcher) {
- $manual_conf = "yes";
- } else {
- my $_conf = prompt("Would you like me to configure as much as possible ".
- "automatically?", "yes");
- $manual_conf = ($_conf and $_conf =~ /^y/i) ? "no" : "yes";
- }
- CPAN->debug("manual_conf[$manual_conf]") if $CPAN::DEBUG;
- my $fastread;
- {
- if ($manual_conf =~ /^y/i) {
- $fastread = 0;
- } else {
- $fastread = 1;
- $silent = 1;
- $CPAN::Config->{urllist} ||= [];
- $CPAN::Config->{connect_to_internet_ok} ||= 1;
-
- 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] };
- }
- }
-
- if (!$matcher or q{
- build_dir
- build_dir_reuse
- cpan_home
- keep_source_where
- prefs_dir
- } =~ /$matcher/) {
- $CPAN::Frontend->myprint($prompts{config_intro}) unless $silent;
-
- 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|never');
-
- #
- #= 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 => 'ask', $matcher,
- 'follow|ask|ignore');
- my_prompt_loop(build_requires_install_policy => 'ask/yes', $matcher,
- 'yes|no|ask/yes|ask/no');
-
- #
- #= 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 (
- $CPAN::Config->{test_report} &&
- $CPAN::META->has_inst("CPAN::Reporter") &&
- CPAN::Reporter->can('configure')
- ) {
- local *_real_prompt;
- *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt;
- my $_conf = prompt("Would you like me configure CPAN::Reporter now?", $silent ? "no" : "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];
- unless ($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'};
- _init_external_progs($matcher,\@path);
-
- {
- 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);
- }
- }
-
- #
- # verbosity
- #
-
- my_prompt_loop(tar_verbosity => 'v', $matcher,
- 'none|v|vv');
- my_prompt_loop(load_module_verbosity => 'none', $matcher,
- 'none|v');
- my_prompt_loop(perl5lib_verbosity => 'v', $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_dflt_prompt(make_install_make_command => $CPAN::Config->{make} || "",
- $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_dflt_prompt(mbuild_install_build_command => "./Build", $matcher);
- }
-
- my_dflt_prompt(mbuild_install_arg => "", $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 $silent;
-
- 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 $silent;
-
- if ($CPAN::Config->{proxy_user} = prompt("Your proxy user id?",$default)) {
- $CPAN::Frontend->myprint($prompts{proxy_pass}) unless $silent;
-
- if ($CPAN::META->has_inst("Term::ReadKey")) {
- Term::ReadKey::ReadMode("noecho");
- } else {
- $CPAN::Frontend->myprint($prompts{password_warn}) unless $silent;
- }
- $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 $silent;
- }
- }
- }
-
- #
- #= how FTP works
- #
-
- my_yn_prompt(ftp_passive => 1, $matcher);
-
- #
- #= how cwd works
- #
-
- my_prompt_loop(getcwd => 'cwd', $matcher,
- 'cwd|getcwd|fastcwd|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 $silent;
- $CPAN::Frontend->myprint( " on_black on_red green ellow ".
- "on_blue genta on_cyan white\n") unless $silent;
-
- for my $FG ("", "bold",
- map {$_,"bold $_"} "black","red","green",
- "yellow","blue",
- "magenta",
- "cyan","white") {
- $CPAN::Frontend->myprint(sprintf( "%12s ", $FG)) unless $silent;
- 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 $silent;
- }
- $CPAN::Frontend->myprint( "\n" ) unless $silent;
- }
- $CPAN::Frontend->myprint( "\n" ) unless $silent;
- }
- 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 $silent;
- 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/
- ) {
- $CPAN::Frontend->myprint($prompts{show_unparsable_or_zero_versions_intro});
- my_yn_prompt(show_unparsable_versions => 0, $matcher);
- my_yn_prompt(show_zero_versions => 0, $matcher);
- }
-
- #
- #= MIRRORED.BY and conf_sites()
- #
-
- # remember, this is only triggered if no urllist is given, so 0 is
- # fair and protects the default site from being overloaded and
- # gives the user more chances to select his own urllist.
- my_yn_prompt("connect_to_internet_ok" => $fastread ? 1 : 0, $matcher);
- $CPAN::Config->{urllist} ||= [];
- if ($matcher) {
- if ("urllist" =~ $matcher) {
- $CPAN::Frontend->myprint($prompts{urls_intro});
-
- # conf_sites would go into endless loop with the smash prompt
- local *_real_prompt;
- *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt;
- my $_conf = prompt($prompts{auto_pick}, "yes");
-
- if ( $_conf =~ /^y/i ) {
- conf_sites( auto_pick => 1 ) or bring_your_own();
- }
- else {
- my $_conf = prompt(
- "Would you like to pick from the CPAN mirror list?", "yes"
- );
-
- if ( $_conf =~ /^y/i ) {
- conf_sites();
- }
- bring_your_own();
- }
- _print_urllist();
- }
- 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);
- }
- } elsif ($fastread) {
- $silent = 0;
- local *_real_prompt;
- *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt;
- if ( @{ $CPAN::Config->{urllist} } ) {
- $CPAN::Frontend->myprint(
- "\nYour 'urllist' is already configured. Type 'o conf init urllist' to change it.\n"
- );
- }
- else {
- $CPAN::Frontend->myprint(
- "Autoconfigured everything but 'urllist'.\n"
- );
-
- $CPAN::Frontend->myprint($prompts{urls_intro});
-
- my $_conf = prompt($prompts{auto_pick}, "yes");
-
- if ( $_conf =~ /^y/i ) {
- conf_sites( auto_pick => 1 ) or bring_your_own();
- }
- else {
- my $_conf = prompt(
- "Would you like to pick from the CPAN mirror list?", "yes"
- );
-
- if ( $_conf =~ /^y/i ) {
- conf_sites();
- }
- bring_your_own();
- }
- _print_urllist();
- }
- $CPAN::Frontend->myprint(
- "\nAutoconfiguration complete.\n"
- );
- }
-
- $silent = 0; # reset
-
- $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($configpm);
- }
-}
-
-sub _init_external_progs {
- my($matcher,$PATH) = @_;
- my @external_progs = qw/bzip2 gzip tar unzip
-
- make
-
- curl lynx wget ncftpget ncftp ftp
-
- gpg
-
- patch applypatch
- /;
- if (!$matcher or "@external_progs" =~ /$matcher/) {
- $CPAN::Frontend->myprint($prompts{external_progs}) unless $silent;
-
- 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 $silent;
- if ($progname eq "make") {
- $CPAN::Frontend->mywarn("ALERT: 'make' is an essential tool for ".
- "building perl Modules. Please make sure you ".
- "have 'make' (or some equivalent) ".
- "working.\n"
- );
- if ($^O eq "MSWin32") {
- $CPAN::Frontend->mywarn("
-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
-
-");
- }
- }
- }
- $prompts{$progname} = "Where is your $progname program?";
- my_dflt_prompt($progname,$path,$matcher);
- }
- }
-}
-
-sub init_cpan_home {
- my($matcher) = @_;
- if (!$matcher or 'cpan_home' =~ /$matcher/) {
- my $cpan_home = $CPAN::Config->{cpan_home}
- || File::Spec->catdir(CPAN::HandleConfig::home(), ".cpan");
-
- if (-d $cpan_home) {
- $CPAN::Frontend->myprint(qq{
-
-I see you already have a directory
- $cpan_home
-Shall we use it as the general CPAN build and cache directory?
-
-}) unless $silent;
- } else {
- # no cpan-home, must prompt and get one
- $CPAN::Frontend->myprint($prompts{cpan_home_where}) unless $silent;
- }
-
- my $default = $cpan_home;
- my $loop = 0;
- my($last_ans,$ans);
- $CPAN::Frontend->myprint(" <cpan_home>\n") unless $silent;
- 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) = @_;
- my $default = $CPAN::Config->{$item} || $dflt;
-
- if (!$silent && (!$m || $item =~ /$m/)) {
- if (my $intro = $prompts{$item . "_intro"}) {
- $CPAN::Frontend->myprint($intro);
- }
- $CPAN::Frontend->myprint(" <$item>\n");
- $CPAN::Config->{$item} = prompt($prompts{$item}, $default);
- } else {
- $CPAN::Config->{$item} = $default;
- }
-}
-
-sub my_yn_prompt {
- my ($item, $dflt, $m) = @_;
- my $default;
- defined($default = $CPAN::Config->{$item}) or $default = $dflt;
-
- # $DB::single = 1;
- if (!$silent && (!$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 (!$silent && (!$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) = @_;
- 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 RETURN" : "RETURN";
- $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("Searching for the best CPAN mirrors (please be patient) ...");
- my $mirrors = CPAN::Mirrors->new($local);
- my $cnt = 0;
- my @best = $mirrors->best_mirrors(
- how_many => 5,
- callback => sub { $CPAN::Frontend->myprint(".") },
- );
- my $urllist = [ map { $_->ftp } @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 RETURN 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 RETURN 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 {
- $CPAN::Frontend->myprint("New urllist\n");
- for ( @{$CPAN::Config->{urllist} || []} ) {
- $CPAN::Frontend->myprint(" $_\n")
- };
-}
-
-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");
-
- return $ans;
-}
-
-
-sub prompt_no_strip ($;$) {
- return _real_prompt(@_);
-}
-
-
-
-1;
diff --git a/Master/tlpkg/tlperl/lib/CPAN/HandleConfig.pm b/Master/tlpkg/tlperl/lib/CPAN/HandleConfig.pm
deleted file mode 100755
index 6a134bd755e..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/HandleConfig.pm
+++ /dev/null
@@ -1,735 +0,0 @@
-package CPAN::HandleConfig;
-use strict;
-use vars qw(%can %keys $loading $VERSION);
-
-$VERSION = "5.5";
-
-%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
-# A2: svn diff -r 985:986 # where andk added yaml_module
-# 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",
- "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",
- "prefer_installer",
- "prefs_dir",
- "prerequisites_policy",
- "proxy_pass",
- "proxy_user",
- "randomize_urllist",
- "scan_cache",
- "shell",
- "show_unparsable_versions",
- "show_upload_date",
- "show_zero_versions",
- "tar",
- "tar_verbosity",
- "term_is_latin",
- "term_ornaments",
- "test_report",
- "trust_test_report_history",
- "unzip",
- "urllist",
- "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)$/) {
-
- #
- # 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"
- } 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);
- }
-}
-
-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;
- if (@args) {
- if ($args[0] eq "args") {
- # we have not signed that contract
- } else {
- $configpm = $args[0];
- }
- }
- unless (defined $configpm) {
- $configpm ||= $INC{"CPAN/MyConfig.pm"};
- $configpm ||= $INC{"CPAN/Config.pm"};
- $configpm || Carp::confess(q{
-CPAN::Config::commit called without an argument.
-Please specify a filename where to save the configuration or try
-"o conf init" to have an interactive course through configing.
-});
- }
- my($mode);
- if (-f $configpm) {
- $mode = (stat $configpm)[2];
- if ($mode && ! -w _) {
- Carp::confess("$configpm is not writable");
- }
- }
-
- my $msg;
- my $home = home();
- $msg = <<EOF unless $configpm =~ /MyConfig/;
-
-# 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. The user-config file is being looked for as
-# $home/.cpan/CPAN/MyConfig.pm.
-
-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;
-
- #$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;
-}
-
-# 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, $key, $val);
- while (($key,$val) = each %$v) {
- last unless defined $key; # cautious programming in case (undef,undef) is true
- 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(doit => 1, @args);
- 1;
-}
-
-# This is a piece of repeated code that is abstracted here for
-# maintainability. RMB
-#
-sub _configpmtest {
- my($configpmdir, $configpmtest) = @_;
- if (-w $configpmtest) {
- return $configpmtest;
- } elsif (-w $configpmdir) {
- #_#_# following code dumped core on me with 5.003_11, a.k.
- my $configpm_bak = "$configpmtest.bak";
- unlink $configpm_bak if -f $configpm_bak;
- if( -f $configpmtest ) {
- if( rename $configpmtest, $configpm_bak ) {
- $CPAN::Frontend->mywarn(<<END);
-Old configuration file $configpmtest
- moved to $configpm_bak
-END
- }
- }
- my $fh = FileHandle->new;
- if ($fh->open(">$configpmtest")) {
- $fh->print("1;\n");
- return $configpmtest;
- } else {
- # Should never happen
- Carp::confess("Cannot open >$configpmtest");
- }
- } else { return }
-}
-
-sub require_myconfig_or_config () {
- return if $INC{"CPAN/MyConfig.pm"};
- local @INC = @INC;
- my $home = home();
- unshift @INC, File::Spec->catdir($home,'.cpan');
- eval { require CPAN::MyConfig };
- my $err_myconfig = $@;
- if ($err_myconfig and $err_myconfig !~ m#locate CPAN/MyConfig\.pm#) {
- die "Error while requiring CPAN::MyConfig:\n$err_myconfig";
- }
- unless ($INC{"CPAN/MyConfig.pm"}) { # this guy has settled his needs already
- eval {require CPAN::Config;}; # not everybody has one
- my $err_config = $@;
- if ($err_config and $err_config !~ m#locate CPAN/Config\.pm#) {
- die "Error while requiring CPAN::Config:\n$err_config";
- }
- }
-}
-
-sub home () {
- my $home;
- # Suppress load messages until we load the config and know whether
- # load messages are desired. Otherwise, it's unexpected and odd
- # why one load message pops up even when verbosity is turned off.
- # This means File::HomeDir load messages are never seen, but I
- # think that's probably OK -- DAGOLDEN
-
- # 5.6.2 seemed to segfault localizing a value in a hashref
- # so do it manually instead
- my $old_v = $CPAN::Config->{load_module_verbosity};
- $CPAN::Config->{load_module_verbosity} = q[none];
- if ($CPAN::META->has_usable("File::HomeDir")) {
- if ($^O eq 'darwin') {
- $home = File::HomeDir->my_home; # my_data is ~/Library/Application Support on darwin,
- # which causes issues in the toolchain.
- }
- else {
- $home = File::HomeDir->my_data || File::HomeDir->my_home;
- }
- }
- unless (defined $home) {
- $home = $ENV{HOME};
- }
- $CPAN::Config->{load_module_verbosity} = $old_v;
- $home;
-}
-
-sub load {
- my($self, %args) = @_;
- $CPAN::Be_Silent++ if $args{be_silent};
- my $doit;
- $doit = delete $args{doit};
-
- use Carp;
- require_myconfig_or_config;
- my @miss = $self->missing_config_data;
- CPAN->debug("doit[$doit]loading[$loading]miss[@miss]") if $CPAN::DEBUG;
- return unless $doit || @miss;
- return if $loading;
- local $loading = ($loading||0) + 1;
-
- require CPAN::FirstTime;
- my($redo,$configpm,$fh);
- if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
- $configpm = $INC{"CPAN/Config.pm"};
- $redo++;
- } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
- $configpm = $INC{"CPAN/MyConfig.pm"};
- $redo++;
- } else {
- my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
- my($configpmdir) = File::Spec->catdir($path_to_cpan,"CPAN");
- my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm");
- my $inc_key;
- if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
- $configpm = _configpmtest($configpmdir,$configpmtest);
- $inc_key = "CPAN/Config.pm";
- }
- unless ($configpm) {
- $configpmdir = File::Spec->catdir(home,".cpan","CPAN");
- File::Path::mkpath($configpmdir);
- $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm");
- $configpm = _configpmtest($configpmdir,$configpmtest);
- $inc_key = "CPAN/MyConfig.pm";
- }
- if ($configpm) {
- $INC{$inc_key} = $configpm;
- } else {
- my $text = qq{WARNING: CPAN.pm is unable to } .
- qq{create a configuration file.};
- output($text, 'confess');
- }
-
- }
- local($") = ", ";
- if ($redo && !$doit) {
- $CPAN::Frontend->myprint(<<END);
-Sorry, we have to rerun the configuration dialog for CPAN.pm due to
-some missing parameters... Will write to
- <<$configpm>>
-
-END
- $args{args} = \@miss;
- }
- my $initialized = CPAN::FirstTime::init($configpm, %args);
- return $initialized;
-}
-
-
-# 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
-
-]);
- undef; #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.5";
-
- # 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:
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Index.pm b/Master/tlpkg/tlperl/lib/CPAN/Index.pm
deleted file mode 100755
index 9df757de706..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Index.pm
+++ /dev/null
@@ -1,619 +0,0 @@
-package CPAN::Index;
-use strict;
-use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED $VERSION);
-$VERSION = "1.94";
-@CPAN::Index::ISA = qw(CPAN::Debug);
-$LAST_TIME ||= 0;
-$DATE_OF_03 ||= 0;
-# use constant PROTOCOL => "2.0"; # outcommented 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 @candidates = map { $_->[0] }
- sort { $b->[1] <=> $a->[1] }
- map { [ $_, -M File::Spec->catfile($d,$_) ] }
- grep {/\.yml$/} readdir $dh;
- unless (@candidates) {
- $CPAN::Frontend->myprint("Build_dir empty, nothing to restore\n");
- return;
- }
- $CPAN::Frontend->myprint
- (sprintf("Going to read %d yaml file%s from %s/\n",
- scalar @candidates,
- @candidates==1 ? "" : "s",
- $CPAN::Config->{build_dir}
- ));
- my $start = CPAN::FTP::_mytime();
- 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++;
- }
- }
- 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("Going to read '$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("Going to read '$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;
- 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
-});
-
- $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
-});
-
- $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;
- 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) {
- $CPAN::Frontend->mywarn("Could not split line[$_]\n");
- next;
- }
- 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("Going to read '$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 (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("Going to write $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("Going to read '$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/Master/tlpkg/tlperl/lib/CPAN/InfoObj.pm b/Master/tlpkg/tlperl/lib/CPAN/InfoObj.pm
deleted file mode 100755
index 9198316c69f..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/InfoObj.pm
+++ /dev/null
@@ -1,224 +0,0 @@
-# -*- 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/Master/tlpkg/tlperl/lib/CPAN/Inject.pm b/Master/tlpkg/tlperl/lib/CPAN/Inject.pm
deleted file mode 100755
index af3dcd8c310..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Inject.pm
+++ /dev/null
@@ -1,514 +0,0 @@
-package CPAN::Inject;
-
-=pod
-
-=head1 NAME
-
-CPAN::Inject - Base class for injecting distributions into CPAN sources
-
-=head1 SYNOPSIS
-
- # Create the injector
- my $cpan = CPAN::Inject->new(
- sources => '/root/.cpan/sources', # Required field
- author => 'LOCAL', # The default
- );
-
- # Add a file to the user
- $cpan->add( file => 'some/random/Perl-Tarball-1.02.tar.gz' );
-
- # What would have have to use when installing
- # $path = 'LOCAL/Perl-Tarball-1.02.tar.gz';
- my $path = $cpan->install_path( 'some/random/Perl-Tarball-1.02.tar.gz' );
-
-=head1 DESCRIPTION
-
-Following the release of L<CPAN::Mini>, the L<CPAN::Mini::Inject> module
-was created to add additional distributions into a minicpan mirror.
-
-While it was created for use with a minicpan mirror, similar
-functionality can be reused in other situations.
-
-B<CPAN::Inject> replicates the basics of this functionality.
-
-Specifically, it takes an arbitrary tarball and adds it to the CPAN
-sources directory for a particular author, and then add the new file
-to the F<CHECKSUMS> file.
-
-It does not reimplement the logic to add files to the indexes.
-
-The initial use this module was created for was to inject tarballs into
-the CPAN sources directory for the reserved LOCAL user, so that the can be
-installed via the CPAN shell, with automated recursion to CPAN dependencies.
-
-But although the number of functions is limited (current only C<add> exists,
-with the others to be added as needed) the implementation is very generic
-and sub-classable, so that it can be reused in other situations.
-
-=head1 METHODS
-
-=cut
-
-use 5.005;
-use strict;
-use Params::Util '_STRING';
-use File::stat ();
-use File::chmod ();
-use File::Spec ();
-use File::Path ();
-use File::Copy ();
-use File::Basename ();
-use CPAN::Checksums ();
-
-use vars qw{$VERSION $CHECK_OWNER};
-
-BEGIN {
- $VERSION = '0.11';
-
- # Attempt to determine whether or not we are capable
- # of finding the owner of a directory.
- # Unless someone set it to a hard-coded value before we
- # started to load this module.
- unless ( defined $CHECK_OWNER ) {
- # Take a directory we know should exist...
- my $root = File::Spec->rootdir();
- unless ( -d $root ) {
- die "Cannot determine if CPAN::Inject can operate on this platform";
- }
-
- # ... find the owner for it...
- my $owner = File::stat::stat($root)->uid;
-
- # ... and if it works, check again in the future.
- # Unless someone set it already, in which case
- $CHECK_OWNER = defined $owner ? 1 : '';
- }
-
- # And boolify the value, just to be a little safer
- $CHECK_OWNER = !! $CHECK_OWNER;
-}
-
-
-
-
-
-#####################################################################
-# Constructor and Accessors
-
-=pod
-
-=head2 new
-
- # Create the injector for the default LOCAL author
- $cpan = CPAN::Inject->new(
- sources => '/root/.cpan/sources',
- );
-
- # Create the injector for a specific author
- $cpan = CPAN::Inject->new(
- sources => '/root/.cpan/sources',
- author => 'ADAMK',
- );
-
-The C<new> constructor takes a set of named params and create a cpan
-injection object.
-
-* B<sources> - The compulsory C<sources> param should be the path to a
-directory that is the root of a mirror (or a partial mirror such as a
-L<CPAN::Cache> or a L<CPAN::Mini>).
-
-To retain the permissions and ownership integrity of the sources tree,
-you must be the owner of the C<sources> directory in order to inject the
-distribution tarballs.
-
-* B<author> - The optional C<author> param should be the CPAN id of an
-author. By default, the reserved local CPAN id "LOCAL" will be used.
-
-The author provided will be used as a default in all further actions.
-
-Returns a C<CPAN::Inject> object, or throws an exception on error.
-
-=cut
-
-sub new {
- my $class = shift;
- my $self = bless {@_}, $class;
-
- # Check where we are going to write to
- my $sources = $self->sources;
- unless ( _STRING($sources) ) {
- Carp::croak("Did not probide a sources param, or not a string");
- }
- unless ( -d $sources ) {
- # The sources directory may actually exist, but we cannot
- # see it because we do not have execute permissions to the
- # parent directory tree.
- # For example, if it is at /root/.cpan/source and we do not
- # have -x permissions to /root
- my ($v, $d) = File::Spec->splitpath( $sources, 'nofile' );
- my @dirs = File::Spec->splitdir( $d );
-
- # Ignore the last directory, since that is what we -d tested
- pop @dirs;
-
- # Check for the existance and rx status of each parent
- foreach my $i ( 0 .. $#dirs ) {
- my $parent = File::Spec->catpath(
- $v,
- File::Spec->catdir( @dirs[0..$i] ),
- '', # No file (returns just the dir)
- );
- unless ( -d $parent ) {
- Carp::croak("The directory '$sources' does not exist");
- }
- unless ( -r $parent and -x $parent ) {
- # Assume that it does exist, but that we can't see it
- Carp::croak("The sources directory is not owned by the current user");
- }
- }
- Carp::croak("The directory '$sources' does not exist");
- }
- unless ( $< == File::stat::stat($sources)->uid ) {
- Carp::croak("The sources directory is not owned by the current user");
- }
-
- # Check for a default author name
- $self->{author} = 'LOCAL' unless $self->author;
- unless ( _AUTHOR( $self->author ) ) {
- Carp::croak( "The author name '"
- . $self->author
- . "' is not a valid author string"
- );
- }
-
- $self;
-}
-
-=pod
-
-=head2 from_cpan_config
-
-The C<from_cpan_config> constructor loads the CPAN.pm configuration file, and
-uses the data contained within to specific the sources path for the
-object.
-
-This constructor is otherwise the same.
-
-Returns a B<CPAN::Inject> object on success, or throws an exception on
-error.
-
-=cut
-
-sub from_cpan_config {
- my $class = shift;
-
- # Load the CPAN module
- require CPAN;
-
- # Support for different mechanisms depending on the version
- # of CPAN that is in use.
- if ( defined $CPAN::HandleConfig::VERSION ) {
- CPAN::HandleConfig->load;
- } else {
- CPAN::Config->load;
- }
-
- # Get the sources directory
- my $sources = undef;
- if ( defined $CPAN::Config->{keep_source_where} ) {
- $sources = $CPAN::Config->{keep_source_where};
- } elsif ( defined $CPAN::Config->{cpan_home} ) {
- $sources = File::Spec->catdir( $CPAN::Config->{cpan_home}, 'sources' );
- } else {
- Carp::croak("Failed to find sources directory in CPAN::Config");
- }
-
- # Hand off to the main constructor
- return $class->new(
- sources => $sources,
- @_,
- );
-}
-
-=pod
-
-=head2 sources
-
-The C<sources> accessor returns the path to the root of the directory tree.
-
-=cut
-
-sub sources {
- $_[0]->{sources};
-}
-
-=pod
-
-=head2 author
-
-The C<author> accessor returns the CPAN id for the default author which
-will be "LOCAL" if you did not provide an alternative param to the the
-C<new> constructor.
-
-=cut
-
-sub author {
- $_[0]->{author};
-}
-
-
-
-
-
-#####################################################################
-# Main methods
-
-=pod
-
-=head2 add
-
- # Add a file to the constructor/default author
- $cpan->add( file => 'any/arbitrary/Perl-Tarball-1.01.tar.gz' );
-
-The C<add> method takes a Perl distribution tarball from an arbitrary
-path, and adds it to the sources path.
-
-The specific location the tarball is copied to will be in the root
-directory for the author provided to the constructor.
-
-Returns the install_path value as a convenience, or throws an exception
-on error.
-
-=cut
-
-sub add {
- my $self = shift;
- my %params = @_;
-
- # Check the file source path
- my $from_file = $params{file};
- unless ( $from_file and -f $from_file and -r $from_file ) {
- Carp::croak("Did not provide a file name, or does not exist");
- }
-
- # Get the file name
- my $name = File::Basename::fileparse($from_file)
- or die "Failed to get filename";
-
- # Find the location to copy it to
- my $to_file = $self->file_path($name);
- my $to_dir = File::Basename::dirname($to_file);
-
- # Make the path for the file
- eval { File::Path::mkpath($to_dir) };
- if ( my $e = $@ ) {
- Carp::croak("Failed to create $to_dir: $e");
- }
-
- # Copy the file to the directory, and ensure writable
- File::Copy::copy( $from_file => $to_file )
- or Carp::croak("Failed to copy $from_file to $to_file");
- chmod( 0644, $to_file )
- or Carp::croak("Failed to correct permissions for $to_file");
-
- # Update the checksums file, and ensure writable
- eval { CPAN::Checksums::updatedir($to_dir); };
- if ( my $e = $@ ) {
- Carp::croak("Failed to update CHECKSUMS after insertion: $e");
- }
- chmod( 0644, File::Spec->catfile( $to_dir, 'CHECKSUMS' ) )
- or Carp::croak("Failed to correct permissions for CHECKSUMS");
-
- # Return the install_path as a convenience
- $self->install_path($name);
-}
-
-=pod
-
-=head2 remove
-
- # Remove a distribution from the repository
- $cpan->remove( dist => 'LOCAL/Perl-Tarball-1.01.tar.gz' );
-
-The C<remove> method takes a distribution path and removes it from the
-sources path. The file is also removed.
-
-Does not return anything useful and throws an exception on error.
-
-=cut
-
-sub remove {
- my $self = shift;
- my %params = @_;
-
- # Get the file name
- my $name = File::Basename::fileparse($params{dist})
- or die "Failed to get filename";
-
- my $file_path = $self->file_path($name);
-
- # Remove the file from CPAN.
- unlink $file_path while -e $file_path;
-
- # Update the checksums file
- my $to_file = $self->file_path($name);
- my $to_dir = File::Basename::dirname($to_file);
- eval { CPAN::Checksums::updatedir($to_dir); };
- if ( my $e = $@ ) {
- Carp::croak("Failed to update CHECKSUMS after removal: $e");
- }
-
- return 1;
-}
-
-=pod
-
-=head2 author_subpath
-
- # $path = 'authors/id/L/LO/LOCAL'
- $path = $cpan->author_subpath;
-
-The C<author_subpath> method takes a CPAN author id (or uses the CPAN
-author id originally provided to the constructor) and returns the
-relative subpath for the AUTHOR within the sources tree.
-
-Returns the subpath as a string.
-
-=cut
-
-sub author_subpath {
- my $author = $_[0]->author;
- File::Spec->catdir(
- 'authors', 'id',
- substr( $author, 0, 1 ),
- substr( $author, 0, 2 ), $author,
- );
-}
-
-=pod
-
-=head2 author_path
-
- # $path = '/root/.cpan/sources/authors/id/L/LO/LOCAL'
- $path = $cpan->author_subpath;
-
-The C<author_path> method finds the full path for the root directory for
-the named author.
-
-Returns the path as a string.
-
-=cut
-
-sub author_path {
- File::Spec->catdir( $_[0]->sources, $_[0]->author_subpath, );
-}
-
-=pod
-
-=head2 file_path
-
- # $path = '/root/.cpan/sources/authors/id/L/LO/LOCAL/Perl-Tarball-1.02.tar.gz'
- $path = $cpan->file_path( 'Perl-Tarball-1.02.tar.gz' );
- $path = $cpan->file_path( '/some/random/place/Perl-Tarball-1.02.tar.gz' );
-
-The C<file_path> method takes the name of a tarball (either just the name
-or a full path) and calculates the location that the file will end up at.
-
-When files are copied into the sources directory, they are always copied
-to the top level of the author root.
-
-Returns the path as a string.
-
-=cut
-
-sub file_path {
- File::Spec->catfile( $_[0]->sources, $_[0]->author_subpath, $_[1], );
-}
-
-=pod
-
-=head2 install_path
-
- # $path = 'LOCAL/Perl-Tarball-1.01.tar.gz';
- $path = $cpan->install_path( 'Perl-Tarball-1.01.tar.gz' );
- $path = $cpan->install_path( '/some/random/place/Perl-Tarball-1.02.tar.gz' );
-
-The C<install_path> method returns the path for the distribution as the
-CPAN shell understands it.
-
-Using this path, the CPAN shell can expand it to locate the
-distribution, and then can install it.
-
-Returns the path as a string.
-
-=cut
-
-sub install_path {
- my $self = shift;
- my $file = File::Basename::fileparse(shift)
- or Carp::croak("Failed to get filename");
- join( '/', $self->author, $file );
-}
-
-
-
-
-
-#####################################################################
-# Support Functions
-
-sub _AUTHOR {
- ( _STRING( $_[0] ) and $_[0] =~ /^[A-Z]{3,}$/ ) ? $_[0] : undef;
-}
-
-1;
-
-=pod
-
-=head1 SUPPORT
-
-This module is stored in an Open Repository at the following address.
-
-L<http://svn.ali.as/cpan/trunk/CPAN-Inject>
-
-Write access to the repository is made available automatically to any
-published CPAN author, and to most other volunteers on request.
-
-If you are able to submit your bug report in the form of new (failing)
-unit tests, or can apply your fix directly instead of submitting a patch,
-you are B<strongly> encouraged to do so as the author currently maintains
-over 100 modules and it can take some time to deal with non-Critcal bug
-reports or patches.
-
-This will guarentee that your issue will be addressed in the next
-release of the module.
-
-If you cannot provide a direct test or fix, or don't have time to do so,
-then regular bug reports are still accepted and appreciated via the CPAN
-bug tracker.
-
-L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CPAN-Inject>
-
-For other issues, for commercial enhancement or support, or to have your
-write access enabled for the repository, contact the author at the email
-address above.
-
-=head1 AUTHOR
-
-Adam Kennedy E<lt>adamk@cpan.orgE<gt>
-
-=head1 SEE ALSO
-
-L<CPAN::Mini::Inject>
-
-=head1 COPYRIGHT
-
-Copyright 2006 - 2007 Adam Kennedy.
-
-This program is free software; you can redistribute
-it and/or modify it under the same terms as Perl itself.
-
-The full text of the license can be found in the
-LICENSE file included with this module.
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Kwalify.pm b/Master/tlpkg/tlperl/lib/CPAN/Kwalify.pm
deleted file mode 100755
index 3cade90b91a..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Kwalify.pm
+++ /dev/null
@@ -1,136 +0,0 @@
-=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/Master/tlpkg/tlperl/lib/CPAN/Kwalify/distroprefs.dd b/Master/tlpkg/tlperl/lib/CPAN/Kwalify/distroprefs.dd
deleted file mode 100755
index fd046271b87..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Kwalify/distroprefs.dd
+++ /dev/null
@@ -1,150 +0,0 @@
-$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/Master/tlpkg/tlperl/lib/CPAN/Kwalify/distroprefs.yml b/Master/tlpkg/tlperl/lib/CPAN/Kwalify/distroprefs.yml
deleted file mode 100755
index 431f1742767..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Kwalify/distroprefs.yml
+++ /dev/null
@@ -1,92 +0,0 @@
----
-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/Master/tlpkg/tlperl/lib/CPAN/LWP/UserAgent.pm b/Master/tlpkg/tlperl/lib/CPAN/LWP/UserAgent.pm
deleted file mode 100755
index 7bb86f9a15d..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/LWP/UserAgent.pm
+++ /dev/null
@@ -1,135 +0,0 @@
-# -*- 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);
-# we delay requiring LWP::UserAgent and setting up inheritance until we need it
-
-$CPAN::LWP::UserAgent::VERSION = $CPAN::LWP::UserAgent::VERSION = "1.94";
-
-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 ($USER && $PASSWD) {
- return ($USER, $PASSWD);
- }
- if ( $proxy ) {
- ($USER,$PASSWD) = $self->get_proxy_credentials();
- } else {
- ($USER,$PASSWD) = $self->get_non_proxy_credentials();
- }
- return($USER,$PASSWD);
-}
-
-sub get_proxy_credentials {
- my $self = shift;
- my ($user, $password);
- if ( defined $CPAN::Config->{proxy_user} ) {
- $user = $CPAN::Config->{proxy_user};
- $password = $CPAN::Config->{proxy_pass} || "";
- return ($user, $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:";
- ($user, $password) =
- _get_username_and_password_from_user($username_prompt);
- return ($user,$password);
-}
-
-sub get_non_proxy_credentials {
- my $self = shift;
- my ($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);
-}
-
-# mirror(): Its purpose is to deal with proxy authentication. When we
-# call SUPER::mirror, we relly 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.
-
-# mirror(): Its purpose is to deal with proxy authentication. When we
-# call SUPER::mirror, we relly 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) {
- undef $USER;
- undef $PASSWD;
- $result = $self->SUPER::mirror($url,$aslocal);
- }
- $result;
-}
-
-1;
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm b/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm
deleted file mode 100755
index 1a3402e8de5..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Mirrors.pm
+++ /dev/null
@@ -1,260 +0,0 @@
-# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
-# vim: ts=4 sts=4 sw=4:
-package CPAN::Mirrors;
-use strict;
-use vars qw($VERSION $urllist $silent);
-$VERSION = "1.77";
-
-use Carp;
-use FileHandle;
-use Fcntl ":flock";
-
-sub new {
- my ($class, $file) = @_;
- my $self = bless {
- mirrors => [],
- geography => {},
- }, $class;
-
- 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;
-
- # populate continents & countries
-
- return $self
-}
-
-sub continents {
- my ($self) = @_;
- return keys %{$self->{geography}};
-}
-
-sub countries {
- my ($self, @continents) = @_;
- @continents = $self->continents unless @continents;
- my @countries;
- for my $c (@continents) {
- push @countries, keys %{ $self->{geography}{$c} };
- }
- return @countries;
-}
-
-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;
-}
-
-sub best_mirrors {
- my ($self, %args) = @_;
- my $how_many = $args{how_many} || 1;
- my $callback = $args{callback};
- my $verbose = $args{verbose};
- my $conts = $args{continents} || [];
- $conts = [$conts] unless ref $conts;
-
- my $seen = {};
-
- if ( ! @$conts ) {
- print "Searching for the best continent ...\n" if $verbose;
- my @best = $self->_find_best_continent($seen, $verbose, $callback);
-
- # how many continents to find enough mirrors? We should scan
- # more than we need -- arbitrarily, we'll say x2
- my $count = 0;
- for my $c ( @best ) {
- push @$conts, $c;
- $count += $self->mirrors( $self->countries($c) );
- last if $count >= 2 * $how_many;
- }
- }
-
- print "Scanning " . join(", ", @$conts) . " ...\n" if $verbose;
-
- my @timings;
- for my $m ($self->mirrors($self->countries(@$conts))) {
- next unless $m->ftp;
- my $hostname = $m->hostname;
- if ( $seen->{$hostname} ) {
- push @timings, $seen->{$hostname}
- if defined $seen->{$hostname}[1];
- }
- else {
- my $ping = $m->ping;
- next unless defined $ping;
- push @timings, [$m, $ping];
- $callback->($m,$ping) if $callback;
- }
- }
- return unless @timings;
- $how_many = @timings if $how_many > @timings;
- my @best =
- map { $_->[0] }
- sort { $a->[1] <=> $b->[1] } @timings;
-
- return wantarray ? @best[0 .. $how_many-1] : $best[0];
-}
-
-sub _find_best_continent {
- my ($self, $seen, $verbose, $callback) = @_;
-
- my %median;
- CONT: for my $c ( $self->continents ) {
- my @mirrors = $self->mirrors( $self->countries($c) );
- next CONT unless @mirrors;
- my $sample = 9;
- my $n = (@mirrors < $sample) ? @mirrors : $sample;
- my @tests;
- RANDOM: while ( @mirrors && @tests < $n ) {
- my $m = splice( @mirrors, int(rand(@mirrors)), 1 );
- my $ping = $m->ping;
- $callback->($m,$ping) if $callback;
- # record undef so we don't try again
- $seen->{$m->hostname} = [$m, $ping];
- next RANDOM unless defined $ping;
- push @tests, $ping;
- }
- next CONT unless @tests;
- @tests = sort { $a <=> $b } @tests;
- if ( @tests == 1 ) {
- $median{$c} = $tests[0];
- }
- elsif ( @tests % 2 ) {
- $median{$c} = $tests[ int(@tests / 2) ];
- }
- else {
- my $mid_high = int(@tests/2);
- $median{$c} = ($tests[$mid_high-1] + $tests[$mid_high])/2;
- }
- }
-
- my @best_cont = sort { $median{$a} <=> $median{$b} } keys %median ;
-
- if ( $verbose ) {
- print "Median result by continent:\n";
- for my $c ( @best_cont ) {
- printf( " %d ms %s\n", int($median{$c}*1000+.5), $c );
- }
- }
-
- return wantarray ? @best_cont : $best_cont[0];
-}
-
-# 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 url {
- my $self = shift;
- return $self->{ftp} || $self->{http};
-}
-
-sub ping {
- my $self = shift;
- my $ping = Net::Ping->new("tcp",1);
- my ($proto) = $self->url =~ m{^([^:]+)};
- my $port = $proto eq 'http' ? 80 : 21;
- return unless $port;
- $ping->port_number($port);
- $ping->hires(1);
- my ($alive,$rtt) = $ping->ping($self->hostname);
- return $alive ? $rtt : undef;
-}
-
-
-1;
-
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Module.pm b/Master/tlpkg/tlperl/lib/CPAN/Module.pm
deleted file mode 100755
index 43c42bf1049..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Module.pm
+++ /dev/null
@@ -1,688 +0,0 @@
-# -*- 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.5";
-
-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) {
- die(CPAN::Exception::RecursiveDependency->new($ancestors));
- }
- # 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) = @_;
- for my $confdirname (qw(archlibexp privlibexp)) {
- my $confdir = $Config::Config{$confdirname};
- if ($confdir eq substr($inst_file,0,length($confdir))) {
- 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/Master/tlpkg/tlperl/lib/CPAN/Nox.pm b/Master/tlpkg/tlperl/lib/CPAN/Nox.pm
deleted file mode 100755
index 5fe5a25ae6e..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Nox.pm
+++ /dev/null
@@ -1,51 +0,0 @@
-package CPAN::Nox;
-use strict;
-use vars qw($VERSION @EXPORT);
-
-BEGIN{
- $CPAN::Suppress_readline=1 unless defined $CPAN::term;
-}
-
-use base 'Exporter';
-use CPAN;
-
-$VERSION = "5.50";
-$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/Master/tlpkg/tlperl/lib/CPAN/Prompt.pm b/Master/tlpkg/tlperl/lib/CPAN/Prompt.pm
deleted file mode 100755
index 7a4e2d81e13..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Prompt.pm
+++ /dev/null
@@ -1,29 +0,0 @@
-# -*- 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/Master/tlpkg/tlperl/lib/CPAN/Queue.pm b/Master/tlpkg/tlperl/lib/CPAN/Queue.pm
deleted file mode 100755
index b60f57c1cfe..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Queue.pm
+++ /dev/null
@@ -1,198 +0,0 @@
-# -*- 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};
-}
-
-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.5";
-
-# 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]\n",$_->{qmod},$_->{reqtype}} @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;
- return;
- }
- }
-}
-
-# CPAN::Queue::jumpqueue ;
-sub jumpqueue {
- my $class = shift;
- my @what = @_;
- CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
- join("",
- map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All, @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($what,$reqtype) = @$what_tuple{qw(qmod reqtype)};
- if ($reqtype eq "r"
- &&
- $inherit_reqtype eq "b"
- ) {
- $reqtype = "b";
- }
- my $jumped = 0;
- for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
- # CPAN->debug("i[$i]this[$All[$i]{qmod}]what[$what]") if $CPAN::DEBUG;
- if ($All[$i]{qmod} eq $what) {
- $jumped++;
- if ($jumped >= 50) {
- die "PANIC: object[$what] 50 instances on the queue, looks like ".
- "some recursiveness has hit";
- } elsif ($jumped > 25) { # one's OK if e.g. just processing
- # now; more are OK if user typed
- # it several times
- my $sleep = sprintf "%.1f", $jumped/10;
- $CPAN::Frontend->mywarn(
-qq{Warning: Object [$what] queued $jumped times, sleeping $sleep secs!\n}
- );
- $CPAN::Frontend->mysleep($sleep);
- # next WHAT;
- }
- }
- }
- my $obj = "$class\::Item"->new(
- qmod => $what,
- reqtype => $reqtype
- );
- unshift @All, $obj;
- }
- CPAN->debug(sprintf("after jumpqueue All[%s]",
- join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @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]\n",$_->{qmod},$_->{reqtype}} @All)
- )) if $CPAN::DEBUG;
-}
-
-# CPAN::Queue::nullify_queue ;
-sub nullify_queue {
- @All = ();
-}
-
-# CPAN::Queue::size ;
-sub size {
- return scalar @All;
-}
-
-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
diff --git a/Master/tlpkg/tlperl/lib/CPAN/SQLite.pm b/Master/tlpkg/tlperl/lib/CPAN/SQLite.pm
deleted file mode 100755
index 01fd4139af7..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/SQLite.pm
+++ /dev/null
@@ -1,323 +0,0 @@
-package CPAN::SQLite;
-use strict;
-use warnings;
-use File::HomeDir;
-require File::Spec;
-use Cwd;
-require CPAN::SQLite::META;
-
-our $VERSION = '0.199';
-
-# an array ref of distributions to ignore indexing
-my $ignore = [qw(SpreadSheet-WriteExcel-WebPivot)];
-our $db_name = 'cpandb.sql';
-
-use constant WIN32 => $^O eq 'MSWin32';
-
-sub new {
- my ($class, %args) = @_;
- my ($CPAN, $update_indices);
- my $db_dir = $args{db_dir};
- my $urllist = [];
- my $keep_source_where;
- # for testing undr Darwin, must load CPAN::MyConfig contained
- # in PERL5LIB, as File::HomeDir doesn't use this
- if ($ENV{CPAN_SQLITE_TESTING}) {
- eval {require CPAN::MyConfig;};
- }
- eval {require CPAN; CPAN::HandleConfig->load;};
- if ( not $@ and not defined $args{CPAN} ) {
- $CPAN = $CPAN::Config->{cpan_home};
- $db_dir = $CPAN;
- $keep_source_where = $CPAN::Config->{keep_source_where};
- $urllist = $CPAN::Config->{urllist};
- die qq{The '$CPAN' directory doesn't exist} unless -d $CPAN;
- $update_indices = 0;
- }
- else {
- $CPAN = $args{CPAN} || '';
- die qq{Please specify the CPAN location} unless defined $CPAN;
- die qq{The '$CPAN' directory doesn't exist} unless (-d $CPAN);
- $update_indices = (-f File::Spec->catfile($CPAN, 'MIRRORING.FROM')) ?
- 0 : 1;
- }
- push @$urllist, q{http://www.cpan.org/};
- $db_dir ||= cwd;
- my $self = {%args, CPAN => $CPAN, update_indices => $update_indices,
- db_name => $db_name, urllist => $urllist,
- keep_source_where => $keep_source_where, db_dir => $db_dir};
- bless $self, $class;
-}
-
-sub index {
- my ($self, %args) = @_;
- require CPAN::SQLite::Index;
- my %wanted = map {$_ => $self->{$_}}
- qw(CPAN ignore update_indices db_name db_dir
- keep_source_where setup reindex urllist);
- my $log_dir = $self->{CPAN} || $self->{db_dir};
- die qq{Please create the directory '$log_dir' first} unless -d $log_dir;
- my $index = CPAN::SQLite::Index->new(%wanted, %args, log_dir => $log_dir);
- $index->index() or do {
- warn qq{Indexing failed!};
- return;
- };
- return 1;
-}
-
-sub query {
- my ($self, %args) = @_;
- my $cwd = $self->{cwd};
- require CPAN::SQLite::Search;
- my %wanted = map {$_ => $self->{$_}}
- qw(max_results CPAN db_name db_dir meta_obj);
- my $query = CPAN::SQLite::Search->new(%wanted, %args);
- %wanted = map {$_ => $self->{$_}} qw(mode query id name);
- $query->query(%wanted, %args) or do {
- warn qq{Query failed!};
- return;
- };
- my $results = $query->{results};
- return unless defined $results;
- $self->{results} = $query->{results};
- return 1;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-CPAN::SQLite - maintain and search a minimal CPAN database
-
-=head1 SYNOPSIS
-
- my $obj = CPAN::SQLite->new(CPAN => '/path/to/CPAN');
- $obj->index(setup => 1);
-
- $obj->query(mode => 'dist', name => 'CPAN');
- my $results = $obj->{results};
-
-=head1 DESCRIPTION
-
-This package is used for setting up, maintaining, and
-searching a CPAN database consisting of the information
-stored in the three main CPAN indices:
-F<$CPAN/modules/03modlist.data.gz>,
-F<$CPAN/modules/02packages.details.txt.gz>, and
-F<$CPAN/authors/01mailrc.txt.gz>. It should be
-considered at an alpha stage of development.
-
-One begins by creating the object as
-
- my $obj = CPAN::SQLite->new(%args);
-
-which accepts the following arguments:
-
-=over 3
-
-=item * C<CPAN =E<gt> '/path/to/CPAN'>
-
-This specifies the path to where the index files are
-to be stored. This could be a local CPAN mirror,
-defined here by the presence of a F<MIRRORED.BY> file beneath
-this directory, or a local directory in which to store
-these files from a remote CPAN mirror. In the latter case,
-the index files are fetched from a remote CPAN mirror,
-using the same list that C<CPAN.pm> uses, if this is
-configured, and are updated if they are more than one
-day old.
-
-If the C<CPAN> option is not given, it will default
-to C<cpan_home> of L<CPAN>, if this is configured,
-with the index files found under C<keep_source_where>.
-A fatal error results if such a directory isn't found.
-Updates to these index files are assumed here to be
-handled by C<CPAN.pm>.
-
-=item * C<db_dir =E<gt> '/path/to/db/dir'>
-
-This specifies the path to where the database file is
-found. If not given, it defaults to the
-C<cpan_home> directory of C<CPAN.pm>, if present, or to
-the directory in which the script was invoked. The name
-of the database file is C<cpandb.sql>.
-
-=back
-
-There are two main methods available.
-
-=head2 C<$obj-E<gt>index(%args);>
-
-This is used to set up and maintain the database. The
-following arguments are accepted:
-
-=over 3
-
-=item * setup =E<gt> 1
-
-This specifies that the database is to be created and
-populated from the CPAN indices; any exisiting database
-will be overwritten. Not specifying this option will
-assume that an existing database is to be updated.
-
-=item * reindex =E<gt> 'dist_name'
-
-This specifies that the CPAN distribution C<dist_name>
-is to be reindexed.
-
-=back
-
-=head2 C<$obj-E<gt>query(%args);>
-
-This is used for querying the database by distribution
-name, module name, or CPAN author name. There are
-two arguments needed to specify such queries.
-
-=over 3
-
-=item * C<mode =E<gt> some_value>
-
-This specifies what type of query to perform,
-with C<mode> being one of C<dist>, C<module>,
-or C<author>, for searching through, respectively,
-CPAN distribution names, module names, or author names and
-CPAN ids.
-
-=item * C<type =E<gt> query_term>
-
-This specifies the query term for the search, with
-C<type> being one of C<name>, to search for an
-exact match, or C<search>, for searching for partial
-matches. Perl regular expressions are supported in
-the C<query_term> for the C<search> option.
-
-=back
-
-As well, an option of C<max_results =E<gt> some_number> will
-limit the number of results returned; if not specified,
-this defaults to 200.
-
-=head1 CPAN.pm support
-
-As of CPAN.pm version 1.88_65, there is experimental support
-within CPAN.pm for using CPAN::SQLite to obtain
-information on packages, modules, and authors. One goal
-of this is to reduce the memory footprint of the CPAN.pm
-shell, as this information is no longer all preloaded into
-memory. This can be enabled through
-
- perl -MCPAN -e shell
- cpan> o conf use_sqlite 1
-
-Use
-
- cpan> o conf commit
-
-to save this setting for future sessions.
-
-Using CPAN::SQLite, what happens is that a request for information
-through CPAN.pm, such as
-
- cpan> a ANDK
-
-will cause a query to the SQLite database to be made.
-If successful, this will place the relevant data for this
-request into the data structure CPAN.pm uses to store and
-retrieve such information. Thus, at any given time, the
-only information CPAN.pm stores in memory is that for
-packages, modules, and authors for which previous queries
-have been made. There are certain requests, such as
-
- cpan> r
-
-to make a list of recommended packages for which upgrades
-on CPAN are available, which will result in loading
-information on all available packages into memory; if such
-a query is made, the subsequent memory footprint of CPAN.pm
-with and without CPAN::SQLite will be essentially the same.
-
-The database itself, called F<cpandb.sql>, will be stored
-in the location specified by C<$CPAN::Config-E<gt>{cpan_home}>.
-When first started, this database will be created, and afterwards,
-it will be updated if the database is older than one day since
-the last update. A log file of the creation or update process, called
-F<cpan_search_log.dddddddddd>, will be created in the same
-directory as the database file.
-
-=head1 SEE ALSO
-
-L<CPAN::SQLite::Index>, for setting up and maintaining
-the database, and L<CPAN::SQLite::Search> for an
-interface to querying the database. Some details
-of the interaction with L<CPAN> is available from
-L<CPAN::SQLite::META>. See also the L<cpandb> script for a
-command-line interface to the
-indexing and querying of the database.
-
-Development takes place on the CPAN-Search-Lite project
-at L<http://cpan-search.svn.sourceforge.net/viewvc/cpan-search/CPAN-SQLite/>.
-
-=head1 SUPPORT
-
-You can find documentation for this module with the perldoc command.
-
- perldoc CPAN::SQLite
-
-You can also look for information at:
-
-=over 4
-
-=item * AnnoCPAN: Annotated CPAN documentation
-
-L<http://annocpan.org/dist/CPAN-SQLite>
-
-=item * CPAN::Forum: Discussion forum
-
-L<http:///www.cpanforum.com/dist/CPAN-SQLite>
-
-=item * CPAN Ratings
-
-L<http://cpanratings.perl.org/d/CPAN-SQLite>
-
-=item * RT: CPAN's request tracker
-
-L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CPAN-SQLite>
-
-=item * Search CPAN
-
-L<http://search.cpan.org/dist/CPAN-SQLite>
-
-=back
-
-=head1 BUGS
-
-At this time, CPAN::SQLite keeps information contained only
-in the latest version of a CPAN distribution. This means that
-modules that are provided only in older versions of a CPAN
-distribution will not be present in the database; for example,
-at this time, the latest version of the I<libwww-perl> distribution
-on CPAN is 5.805, but there are modules such as I<URI::URL::finger>
-contained in version 5.10 of libwww-perl that are not present in 5.805.
-This behaviour differs from that of L<CPAN> without CPAN::SQLite.
-This may change in the future.
-
-Please report bugs and feature requests via
-L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CPAN-SQLite>.
-
-=head1 ENVIRONMENT VARIABLES
-
-Information messages from the indexing procedures are printed
-out to STDOUT if the environment variable CPAN_SQLITE_DEBUG
-is set. This is automatically set within L<CPAN::SQLite::Index>.
-If CPAN_SQLITE_NO_LOG_FILES is set, no log files will be created
-during the indexing procedures.
-
-=head1 COPYRIGHT
-
-This software is copyright 2006,2008 by Randy Kobes
-E<lt>r.kobes@uwinnipeg.caE<gt>. Use and
-redistribution are under the same terms as Perl itself.
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/CPAN/SQLite/DBI.pm b/Master/tlpkg/tlperl/lib/CPAN/SQLite/DBI.pm
deleted file mode 100755
index 52318924531..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/SQLite/DBI.pm
+++ /dev/null
@@ -1,169 +0,0 @@
-package CPAN::SQLite::DBI;
-use strict;
-use warnings;
-require File::Spec;
-use DBI;
-our $VERSION = '0.199';
-
-use base qw(Exporter);
-our ($dbh, $tables, @EXPORT_OK);
-@EXPORT_OK = qw($dbh $tables);
-
-sub rlike {
- my ($x, $y) = @_;
- return ($x =~ /$y/i) ? 1 : 0;
-}
-
-$tables = {
- mods => {
- primary => {mod_id => q{INTEGER NOT NULL PRIMARY KEY}},
- other => {
- mod_name => q{VARCHAR(100) NOT NULL},
- dist_id => q{INTEGER NOT NULL},
- mod_abs => q{TEXT},
- mod_vers => q{VARCHAR(10)},
- dslip => q{VARCHAR(5)},
- chapterid => q{INTEGER},
- },
- key => [qw/dist_id mod_name/],
- name => 'mod_name',
- id => 'mod_id',
- has_a => {dists => 'dist_id'},
- },
- dists => {
- primary => {dist_id => q{INTEGER NOT NULL PRIMARY KEY}},
- other => {
- dist_name => q{VARCHAR(90) NOT NULL},
- auth_id => q{INTEGER NOT NULL},
- dist_file => q{VARCHAR(110) NOT NULL},
- dist_vers => q{VARCHAR(20)},
- dist_abs => q{TEXT},
- dist_dslip => q{VARCHAR(5)},
- },
- key => [qw/auth_id dist_name/],
- name => 'dist_name',
- id => 'dist_id',
- has_a => {auths => 'auth_id'},
- has_many => {mods => 'dist_id',
- chaps => 'dist_id',
- },
- },
- auths => {
- primary => {auth_id => q{INTEGER NOT NULL PRIMARY KEY}},
- other => {
- cpanid => q{VARCHAR(20) NOT NULL},
- fullname => q{VARCHAR(40) NOT NULL},
- email => q{TEXT},
- },
- key => [qw/cpanid/],
- has_many => {dists => 'dist_id'},
- name => 'cpanid',
- id => 'auth_id',
- },
- chaps => {
- primary => {chap_id => q{INTEGER NOT NULL PRIMARY KEY}},
- other => {
- dist_id => q{INTEGER NOT NULL},
- chapterid => q{INTEGER},
- subchapter => q{TEXT},
- },
- key => [qw/dist_id/],
- id => 'chap_id',
- name => 'chapterid',
- has_a => {dists => 'dist_id'},
- },
- };
-
-sub new {
- my ($class, %args) = @_;
- my $db_dir = $args{db_dir} || $args{CPAN};
- my $db = File::Spec->catfile($db_dir, $args{db_name});
- $dbh ||= DBI->connect("DBI:SQLite:$db", '', '',
- {RaiseError => 1, AutoCommit => 0})
- or die "Cannot connect to $db";
- $dbh->{AutoCommit} = 0;
- $dbh->func('RLIKE', 2, \&rlike, 'create_function');
-
- my $objs;
- foreach my $table (keys %$tables) {
- my $cl = $class . '::' . $table;
- $objs->{$table} = $cl->make(table => $table);
- }
-
- for my $table (keys %$tables) {
- foreach my $type (qw(primary other)) {
- foreach my $column (keys %{$tables->{$table}->{$type}}) {
- push @{$tables->{$table}->{columns}}, $column;
- }
- }
- }
-
- bless {objs => $objs}, $class;
-}
-
-sub make {
- my ($class, %args) = @_;
- my $table = $args{table};
- die qq{No table exists corresponding to '$class'} unless $table;
- my $info = $tables->{$table};
- die qq{No information available for table '$table'} unless $info;
- my $self = {table => $table,
- columns => $info->{columns},
- id => $info->{id},
- name => $info->{name},
- };
- foreach (qw(name has_a has_many)) {
- next unless defined $info->{$_};
- $self->{$_} = $info->{$_};
- }
- bless $self, $class;
-}
-
-sub db_error {
- my ($obj, $sth) = @_;
- return unless $dbh;
- if ($sth) {
- $sth->finish;
- undef $sth;
- }
- $obj->{error_msg} = q{Database error: } . $dbh->errstr;
-}
-
-
-1;
-
-__END__
-
-=head1 NAME
-
-CPAN::SQLite::DBI - DBI information for the CPAN::SQLite database
-
-=head1 DESCRIPTION
-
-This module is used by L<CPAN::SQLite::Index> and
-L<CPAN::SQLite::Search> to set up some basic database
-information. It exports two variables:
-
-=over 3
-
-=item C<$tables>
-
-This is a hash reference whose keys are the table names, with
-corresponding values being hash references whose keys are the
-columns of the table and values being the associated data types.
-
-=item C<$dbh>
-
-This is a L<DBI> database handle used to connect to the
-database.
-
-=back
-
-The main method of this module is C<make>, which is used
-to make the tables of the database.
-
-=head1 SEE ALSO
-
-L<CPAN::SQLite::Index> and L<CPAN::SQLite::Search>
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/CPAN/SQLite/DBI/Index.pm b/Master/tlpkg/tlperl/lib/CPAN/SQLite/DBI/Index.pm
deleted file mode 100755
index 19fb93b29bf..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/SQLite/DBI/Index.pm
+++ /dev/null
@@ -1,237 +0,0 @@
-package CPAN::SQLite::DBI::Index;
-use CPAN::SQLite::DBI qw($dbh);
-use base qw(CPAN::SQLite::DBI);
-
-use strict;
-use warnings;
-our $VERSION = '0.199';
-
-package CPAN::SQLite::DBI::Index::chaps;
-use base qw(CPAN::SQLite::DBI::Index);
-use CPAN::SQLite::DBI qw($dbh);
-
-package CPAN::SQLite::DBI::Index::mods;
-use base qw(CPAN::SQLite::DBI::Index);
-use CPAN::SQLite::DBI qw($dbh);
-
-package CPAN::SQLite::DBI::Index::dists;
-use base qw(CPAN::SQLite::DBI::Index);
-use CPAN::SQLite::DBI qw($dbh);
-
-sub fetch_ids {
- my $self = shift;
- my $sql = sprintf(qq{SELECT %s,%s,%s FROM %s},
- $self->{id}, $self->{name}, 'dist_vers',
- $self->{table});
- my $sth = $dbh->prepare($sql) or do {
- $self->db_error();
- return;
- };
- $sth->execute() or do {
- $self->db_error($sth);
- return;
- };
- my ($ids, $versions);
- while (my ($id, $key, $vers) = $sth->fetchrow_array()) {
- $ids->{$key} = $id;
- $versions->{$key} = $vers;
- }
- $sth->finish;
- undef $sth;
- return ($ids, $versions);
-}
-
-package CPAN::SQLite::DBI::Index::auths;
-use base qw(CPAN::SQLite::DBI::Index);
-use CPAN::SQLite::DBI qw($dbh);
-
-package CPAN::SQLite::DBI::Index;
-use CPAN::SQLite::DBI qw($tables);
-use CPAN::SQLite::DBI qw($dbh);
-
-sub fetch_ids {
- my $self = shift;
- my $sql = sprintf(qq{SELECT %s,%s from %s},
- $self->{id}, $self->{name}, $self->{table});
- my $sth = $dbh->prepare($sql) or do {
- $self->db_error();
- return;
- };
- $sth->execute() or do {
- $self->db_error($sth);
- return;
- };
- my $ids;
- while (my ($id, $key) = $sth->fetchrow_array()) {
- $ids->{$key} = $id;
- }
- $sth->finish;
- undef $sth;
- return $ids;
-}
-
-sub schema {
- my ($self, $data) = @_;
- my $schema = '';
- foreach my $type (qw(primary other)) {
- foreach my $column (keys %{$data->{$type}}) {
- $schema .= $column . ' ' . $data->{$type}->{$column} . ", ";
- }
- }
- $schema =~ s{, $}{};
- return $schema;
-}
-
-sub create_index {
- my ($self, $data) = @_;
- my $sql = '';
- my $key = $data->{key};
- my $table = $self->{table};
- return 1 unless (defined $key and ref($key) eq 'ARRAY');
- foreach my $index(@$key) {
- my $id_name = 'ix_' . $table . '_' . $index;
- $id_name =~ s/\(\s*\d+\s*\)//;
- my $sql = 'CREATE INDEX ' . $id_name . ' ON ' .
- $table . '( ' . $index . ' )';
- my $sth = $dbh->prepare($sql);
- $sth->execute() or do {
- $self->db_error($sth);
- return;
- };
- $sth->finish;
- undef $sth;
- }
- return 1;
-}
-
-sub drop_table {
- my $self = shift;
- my $table = $self->{table};
- my $sql = qq{SELECT name FROM sqlite_master } .
- qq{ WHERE type='table' AND name=?};
- my $sth = $dbh->prepare($sql);
- $sth->execute($table);
- if (defined $sth->fetchrow_array) {
- $dbh->do(qq{drop table $table}) or do {
- $self->db_error($sth);
- return;
- };
- }
- $sth->finish;
- undef $sth;
- return 1;
-}
-
-sub create_table {
- my ($self, $schema) = @_;
- return unless $schema;
- my $sql = sprintf(qq{CREATE TABLE %s (%s)}, $self->{table}, $schema);
- my $sth = $dbh->prepare($sql);
- $sth->execute() or do {
- $self->db_error($sth);
- return;
- };
- $sth->finish;
- undef $sth;
- return 1;
-}
-
-sub create_tables {
- my ($self, %args) = @_;
- return unless $args{setup};
- my $objs = $self->{objs};
- foreach my $table(keys %$objs) {
- next unless my $schema = $self->schema($tables->{$table});
- my $obj = $objs->{$table};
- $obj->drop_table or return;
- $obj->create_table($schema) or return;
- $obj->create_index($tables->{$table}) or return;
- }
- return 1;
-}
-
-sub sth_insert {
- my ($self, $fields) = @_;
- my $flds = join ',', @$fields;
- my $vals = join ',', map '?', @$fields;
- my $sql = sprintf(qq{INSERT INTO %s (%s) VALUES (%s)},
- $self->{table}, $flds, $vals);
-
- my $sth = $dbh->prepare($sql) or do {
- $self->db_error();
- return;
- };
- return $sth;
-}
-
-sub sth_update {
- my ($self, $fields, $id, $rep_id) = @_;
- my $set = join ',', map "$_=?", @$fields;
- my $sql = sprintf(qq{UPDATE %s SET %s WHERE %s = %s},
- $self->{table}, $set, $self->{id}, $id);
- $sql .= qq { AND rep_id = $rep_id } if ($rep_id);
- my $sth = $dbh->prepare($sql) or do {
- $self->db_error();
- return;
- };
- return $sth;
-}
-
-sub sth_delete {
- my ($self, $table_id, $rep_id) = @_;
- my $sql = sprintf(qq{DELETE FROM %s where %s = ?},
- $self->{table}, $table_id);
- $sql .= qq { AND rep_id = $rep_id } if ($rep_id);
- my $sth = $dbh->prepare($sql) or do {
- $self->db_error();
- return;
- };
- return $sth;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-CPAN::SQLite::DBI::Index - DBI information for indexing the CPAN::SQLite database
-
-=head1 DESCRIPTION
-
-This module provides various methods for L<CPAN::SQLite::Index> in
-indexing and populating the database from the index files.
-
-=over
-
-=item C<create_tables>
-
-This creates the database tables.
-
-=item C<drop_table>
-
-This drops a table.
-
-=item C<sth_insert>
-
-This returns an C<$sth> statement handle for inserting
-values into a table.
-
-=item C<sth_update>
-
-This returns an C<$sth> statement handle for updating
-values into a table.
-
-=item C<sth_delete>
-
-This returns an C<$sth> statement handle for deleting
-values from a table.
-
-=back
-
-=head1 SEE ALSO
-
-L<CPAN::SQLite::Index>
-
-=cut
-
diff --git a/Master/tlpkg/tlperl/lib/CPAN/SQLite/DBI/Search.pm b/Master/tlpkg/tlperl/lib/CPAN/SQLite/DBI/Search.pm
deleted file mode 100755
index 32b4dcae4c9..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/SQLite/DBI/Search.pm
+++ /dev/null
@@ -1,283 +0,0 @@
-package CPAN::SQLite::DBI::Search;
-use base qw(CPAN::SQLite::DBI);
-use CPAN::SQLite::DBI qw($tables $dbh);
-use CPAN::SQLite::Util qw($full_id);
-
-our $VERSION = '0.199';
-
-use strict;
-use warnings;
-
-package CPAN::SQLite::DBI::Search::chaps;
-use base qw(CPAN::SQLite::DBI::Search);
-use CPAN::SQLite::DBI qw($dbh);
-
-package CPAN::SQLite::DBI::Search::mods;
-use base qw(CPAN::SQLite::DBI::Search);
-use CPAN::SQLite::DBI qw($dbh);
-
-package CPAN::SQLite::DBI::Search::dists;
-use base qw(CPAN::SQLite::DBI::Search);
-use CPAN::SQLite::DBI qw($dbh);
-
-package CPAN::SQLite::DBI::Search::auths;
-use base qw(CPAN::SQLite::DBI::Search);
-use CPAN::SQLite::DBI qw($dbh);
-
-package CPAN::SQLite::DBI::Search;
-use base qw(CPAN::SQLite::DBI);
-use CPAN::SQLite::DBI qw($tables $dbh);
-use CPAN::SQLite::Util qw($full_id expand_dslip download %chaps);
-
-sub fetch {
- my ($self, %args) = @_;
- my $fields = $args{fields};
- my $search = $args{search};
- my @fields = ref($fields) eq 'ARRAY' ?
- @{$fields} : ($fields);
- my $sql = $self->sql_statement(%args) or do {
- $self->{error} = 'Error constructing sql statement: ' .
- $self->{error};
- return;
- };
- my $sth = $dbh->prepare($sql) or do {
- $self->db_error();
- return;
- };
- $sth->execute() or do {
- $self->db_error($sth);
- return;
- };
-
- if (not $search->{wantarray}) {
- my (%results, %meta_results, $results);
- @results{@fields} = $sth->fetchrow_array;
- $results = ($sth->rows == 0) ? undef : \%results;
- $sth->finish;
- undef $sth;
- $self->extra_info($results) if $results;
- return $results;
- }
- else {
- my (%hash, $results);
- while ( @hash{@fields} = $sth->fetchrow_array) {
- my %tmp = %hash;
- $self->extra_info(\%tmp);
- push @{$results}, \%tmp;
- }
- $results = undef if ($sth->rows == 0);
- $sth->finish;
- undef $sth;
- return $results;
- }
-}
-
-sub fetch_and_set {
- my ($self, %args) = @_;
- my $fields = $args{fields};
- my $search = $args{search};
- my $meta_obj = $args{meta_obj};
- die "Please supply a CPAN::SQLite::Meta::* object"
- unless ($meta_obj and ref($meta_obj) =~ /^CPAN::SQLite::META/);
- my @fields = ref($fields) eq 'ARRAY' ?
- @{$fields} : ($fields);
- my $sql = $self->sql_statement(%args) or do {
- $self->{error} = 'Error constructing sql statement: ' .
- $self->{error};
- return;
- };
- my $sth = $dbh->prepare($sql) or do {
- $self->db_error();
- return;
- };
- $sth->execute() or do {
- $self->db_error($sth);
- return;
- };
-
- my $want_ids = $args{want_ids};
- my $set_list = $args{set_list};
- my $download = $args{download};
- if (not $search->{wantarray}) {
- my (%results, %meta_results, $results);
- @results{@fields} = $sth->fetchrow_array;
- $results = ($sth->rows == 0) ? undef : \%results;
- $sth->finish;
- undef $sth;
- return unless $results;
- $self->extra_info($results);
- $meta_obj->set_data($results);
- if ($want_ids) {
- $meta_results{dist_id} = $results{dist_id};
- $meta_results{download} = download($results{cpanid},
- $results{dist_file});
- return \%meta_results;
- }
- else {
- return 1;
- }
- }
- else {
- my (%hash, $meta_results);
- while ( @hash{@fields} = $sth->fetchrow_array) {
- my %tmp = %hash;
- if ($set_list) {
- push @{$meta_results}, \%tmp;
- }
- else {
- $self->extra_info(\%tmp);
- $meta_obj->set_data(\%tmp);
- if ($want_ids) {
- my $download = download($tmp{cpanid}, $tmp{dist_file});
- push @{$meta_results}, {dist_id => $tmp{dist_id},
- download => $download};
-
- }
- }
- }
- $meta_results = undef if ($sth->rows == 0);
- $sth->finish;
- undef $sth;
- return unless $meta_results;
- $meta_obj->set_list_data($meta_results, $download) if $set_list;
- return $want_ids ? $meta_results : 1;
- }
-}
-
-sub extra_info {
- my ($self, $results) = @_;
- if ($results->{cpanid} and $results->{dist_file}) {
- $results->{download} = download($results->{cpanid}, $results->{dist_file});
- }
- my $what;
- if ( ($what = $results->{dslip}) or ($what = $results->{dist_dslip}) ) {
- $results->{dslip_info} = expand_dslip($what);
- }
- if (my $chapterid = $results->{chapterid}) {
- $chapterid += 0;
- $results->{chapter_desc} = $chaps{$chapterid};
- }
-}
-
-sub sql_statement {
- my ($self, %args) = @_;
-
- my $search = $args{search};
- my $distinct = $search->{distinct} ? 'DISTINCT' : '';
- my $table = $args{table};
- my @tables = ($table);
-
- my $fields = $args{fields};
- my @fields = ref($fields) eq 'ARRAY' ?
- @{$fields} : ($fields);
- for (@fields) {
- $_ = $full_id->{$_} if $full_id->{$_};
- }
-
- my $sql = qq{SELECT $distinct } . join(',', @fields);
- my $where = '';
- my $type = $search->{type};
- QUERY: {
- ($type eq 'query' ) and do {
- my $value = $search->{value};
- last QUERY if ($value eq '^');
- my $name = $search->{name};
- my $text = $search->{text};
- my $use_like = ($value =~ /^\^?[A-Za-z0-9_\\\:\-]+$/) ? 1 : 0;
- my $prepend = '%';
- if ($use_like and $value =~ /^\^/) {
- $prepend = '';
- $value =~ s/^\^//;
- $value =~ s{\\}{}g;
- }
- $where = $use_like ?
- qq{$name LIKE '$prepend$value%'} :
- qq{RLIKE($name, '$value')};
- if ($name eq 'cpanid') {
- $where .= $use_like ?
- qq{ OR $text LIKE '$prepend$value%'} :
- qq{ OR RLIKE($text, '$value')};
- }
- last QUERY;
- };
- ($type eq 'id') and do {
- $where = qq{ $search->{id} = $search->{value} };
- last QUERY;
- };
- ($type eq 'name') and do {
- $where = qq{ $search->{name} = '$search->{value}' };
- last QUERY;
- };
- warn qq{Unknown query type};
- return;
- }
- my $join;
-
- $sql .= ' FROM ' . $table;
- my $left_join = $args{join} || $args{left_join};
- if ($left_join) {
- if (ref($left_join) eq 'HASH') {
- foreach my $key(keys %$left_join) {
- my $id = $left_join->{$key};
- $sql .= " LEFT JOIN $key ON $table.$id=$key.$id ";
- }
- }
- }
-
- if ($where) {
- $sql .= ' WHERE ( ' . $where . ' )';
- $sql .= ' AND (' . $join . ')' if $join;
- }
- else {
- $sql .= ' WHERE (' . $join . ')' if $join;
- }
-
- my $order_by = '';
- if (my $user_order_by = $args{order_by}) {
- $order_by = $order_by ? "$order_by,$user_order_by" : $user_order_by;
- }
- if ($order_by and $where) {
- $sql .= qq{ ORDER BY $order_by };
- }
-
- if (my $limit = $args{limit}) {
- my ($min, $max) = ref($limit) eq 'HASH' ?
- ( $limit->{min} || 0, $limit->{max} ) :
- (0, $limit );
- $sql .= qq{ LIMIT $min,$max };
- }
- return $sql;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-CPAN::SQLite::DBI::Search - DBI information for searching the CPAN::SQLite database
-
-=head1 DESCRIPTION
-
-This module provides methods for L<CPAN::SQLite::Search> for searching
-the C<CPAN::SQLite> database. There are two main methods.
-
-=over
-
-=item C<fetch>
-
-This takes information from C<CPAN::SQLite::Search> and sets up
-a query on the database, returning the results found.
-
-=item C<sql_statement>
-
-This is used by the C<fetch> method to construct the appropriate
-SQL statement.
-
-=back
-
-=head1 SEE ALSO
-
-L<CPAN::SQLite::Search>
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/CPAN/SQLite/Index.pm b/Master/tlpkg/tlperl/lib/CPAN/SQLite/Index.pm
deleted file mode 100755
index 31923ff2beb..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/SQLite/Index.pm
+++ /dev/null
@@ -1,264 +0,0 @@
-package CPAN::SQLite::Index;
-use strict;
-use warnings;
-use CPAN::SQLite::Info;
-use CPAN::SQLite::State;
-use CPAN::SQLite::Populate;
-use CPAN::SQLite::DBI qw($tables);
-use File::Spec::Functions qw(catfile);
-use File::Basename;
-use File::Path;
-use LWP::Simple qw(getstore is_success);
-
-our $VERSION = '0.199';
-unless ($ENV{CPAN_SQLITE_NO_LOG_FILES}) {
- $ENV{CPAN_SQLITE_DEBUG} = 1;
-}
-
-our ($oldout);
-my $log_file = 'cpan_sqlite_log.' . time;
-
-sub new {
- my ($class, %args) = @_;
- if ($args{setup} and $args{reindex}) {
- die "Reindexing must be done on an exisiting database";
- }
-
- my $self = {index => undef, state => undef, %args};
- bless $self, $class;
-}
-
-sub index {
- my ($self, %args) = @_;
- my $setup = $self->{setup};
-
- if ($setup) {
- my $db_name = catfile($self->{db_dir}, $self->{db_name});
- if (-f $db_name) {
- warn qq{Removing existing $db_name\n};
- unlink $db_name or warn qq{Cannot unlink $db_name: $!};
- }
- }
- my $log = catfile($self->{log_dir}, $log_file);
- unless ($ENV{CPAN_SQLITE_NO_LOG_FILES}) {
- $oldout = error_fh($log);
- }
-
- if ($self->{update_indices}) {
- warn qq{Fetching index files ...\n};
- $self->fetch_cpan_indices() or do {
- warn qq{fetch_cpan_indices() failed};
- return;
- }
- }
-
- warn qq{Gathering information from index files ...\n};
- $self->fetch_info or do {
- warn qq{fetch_info() failed!};
- return;
- };
- unless ($setup) {
- warn qq{Obtaining current state of database ...\n};
- $self->state or do {
- warn qq{state() failed!};
- return;
- };
- }
- warn qq{Populating database tables ...\n};
- $self->populate or do {
- warn qq{populate() failed!};
- return;
- };
- return 1;
-}
-
-sub fetch_cpan_indices {
- my ($self, %args) = @_;
- my $CPAN = $self->{CPAN};
- my $indices = {'01mailrc.txt.gz' => 'authors',
- '02packages.details.txt.gz' => 'modules',
- '03modlist.data.gz' => 'modules',
- };
- foreach my $index (keys %$indices) {
- my $file = catfile($CPAN, $indices->{$index}, $index);
- next if (-e $file and -M $file < 1);
- my $dir = dirname($file);
- unless (-d $dir) {
- mkpath($dir, 1, 0755) or die "Cannot mkpath $dir: $!";
- }
- my @urllist = @{$self->{urllist}};
- foreach my $cpan(@urllist) {
- my $from = join '/', ($cpan, $indices->{$index}, $index);
- last if is_success(getstore($from, $file));
- }
- unless (-f $file) {
- warn qq{Cannot retrieve '$file'};
- return;
- }
- }
- return 1;
-}
-
-sub fetch_info {
- my $self = shift;
- my %wanted = map {$_ => $self->{$_}} qw(CPAN ignore keep_source_where);
- my $info = CPAN::SQLite::Info->new(%wanted);
- $info->fetch_info() or return;
- my @tables = qw(dists mods auths);
- my $index;
- foreach my $table(@tables) {
- my $class = __PACKAGE__ . '::' . $table;
- my $this = {info => $info->{$table}};
- $index->{$table} = bless $this, $class;
- }
- $self->{index} = $index;
- return 1;
-}
-
-sub state {
- my $self = shift;
-
- my %wanted = map {$_ => $self->{$_}}
- qw(db_name index setup reindex db_dir);
- my $state = CPAN::SQLite::State->new(%wanted);
- $state->state() or return;
- $self->{state} = $state;
- return 1;
-}
-
-sub populate {
- my $self = shift;
- my %wanted = map {$_ => $self->{$_}}
- qw(db_name index setup state db_dir);
- my $db = CPAN::SQLite::Populate->new(%wanted);
- $db->populate() or return;
- return 1;
-}
-
-sub error_fh {
- my $file = shift;
- open(my $tmp, '>', $file) or die "Cannot open $file: $!";
- close $tmp;
- open(my $oldout, '>&STDOUT');
- open(STDOUT, '>', $file) or die "Cannot tie STDOUT to $file: $!";
- select STDOUT; $| = 1;
- return $oldout;
-}
-
-sub DESTROY {
- unless ($ENV{CPAN_SQLITE_NO_LOG_FILES}) {
- close STDOUT;
- open(STDOUT, ">&$oldout");
- }
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-CPAN::SQLite::Index - set up or update database tables.
-
-=head1 SYNOPSIS
-
- my $index = CPAN::SQLite::Index->new(setup => 1);
- $index->index();
-
-=head1 DESCRIPTION
-
-This is the main module used to set up or update the
-database tables used to store information from the
-CPAN and ppm indices. The creation of the object
-
- my $index = CPAN::SQLite::Index->new(%args);
-
-accepts two possible arguments:
-
-=over 3
-
-=item * setup =E<gt> 1
-
-This (optional) argument specifies that the database is being set up.
-Any existing tables will be dropped.
-
-=item * reindex =E<gt> value
-
-This (optional) argument specifies distribution names that
-one would like to reindex in an existing database. These may
-be specified as either a scalar, for a single distribution,
-or as an array reference for a list of distributions.
-
-=back
-
-=head1 DETAILS
-
-Calling
-
- $index->index();
-
-will start the indexing procedure. Various messages
-detailing the progress will written to I<STDOUT>,
-which by default will be captured into a file
-F<cpan_sqlite_log.dddddddddd>, where the extension
-is the C<time> that the method was invoked. Error messages
-are not captured, and will appear in I<STDERR>.
-
-The steps of the indexing procedure are as follows.
-
-=over 3
-
-=item * fetch index data
-
-The necessary CPAN index files
-F<$CPAN/authors/01mailrc.txt.gz>,
-F<$CPAN/modules/02packages.details.txt.gz>, and
-F<$CPAN/modules/03modlist.data.gz> will be fetched
-from the CPAN mirror specified by the C<$cpan> variable
-at the beginning of L<CPAN::SQLite::Index>. If you are
-using this option, it is recommended to use the
-same CPAN mirror with subsequent updates, to ensure consistency
-of the database. As well, the information on the locations
-of the CPAN mirrors used for Template-Toolkit and GeoIP
-is written.
-
-=item * get index information
-
-Information from the CPAN indices is extracted through
-L<CPAN::SQLite::Info>.
-
-=item * get state information
-
-Unless the C<setup> argument within the C<new>
-method of L<CPAN::SQLite::Index> is specified,
-this will get information on the state of the database
-through L<CPAN::SQLite::State>.
-A comparision is then made between this information
-and that gathered from the CPAN indices, and if there's
-a discrepency in some items, those items are marked
-for either insertion, updating, or deletion, as appropriate.
-
-=item * populate the database
-
-At this stage the gathered information is used to populate
-the database, through L<CPAN::SQLite::Populate>,
-either inserting new items, updating
-existing ones, or deleting obsolete items.
-
-=back
-
-=head1 SEE ALSO
-
-L<CPAN::SQLite::Info>, L<CPAN::SQLite::State>,
-L<CPAN::SQLite::Populate>,
-and L<CPAN::SQLite::Util>.
-Development takes place on the CPAN-SQLite project
-at L<http://sourceforge.net/projects/cpan-search/>.
-
-=head1 COPYRIGHT
-
-This software is copyright 2006 by Randy Kobes
-E<lt>r.kobes@uwinnipeg.caE<gt>. Use and
-redistribution are under the same terms as Perl itself.
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/CPAN/SQLite/Info.pm b/Master/tlpkg/tlperl/lib/CPAN/SQLite/Info.pm
deleted file mode 100755
index 09ec1896bb5..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/SQLite/Info.pm
+++ /dev/null
@@ -1,338 +0,0 @@
-package CPAN::SQLite::Info;
-use strict;
-use warnings;
-use CPAN::DistnameInfo;
-use File::Spec::Functions qw(catfile);
-use Compress::Zlib;
-use File::Basename;
-use Safe;
-use CPAN::SQLite::Util qw(vcmp print_debug);
-
-our $VERSION = '0.199';
-
-my $ext = qr/\.(tar\.gz|tar\.Z|tgz|zip)$/;
-
-sub new {
- my ($class, %args) = @_;
- my $self = {dists => {}, auths => {}, mods => {}, %args};
- bless $self, $class;
-}
-
-sub fetch_info {
- my $self = shift;
- $self->mailrc() or return;
- $self->dists_and_mods() or return;
- return 1;
-}
-
-sub dists_and_mods {
- my $self = shift;
- my $modlist = $self->modlist();
- my ($packages, $cpan_files) = $self->packages();
-
- my ($dists, $mods);
- my $ignore = $self->{ignore};
- my $pat;
- if ($ignore and ref($ignore) eq 'ARRAY') {
- $pat = join '|', @$ignore;
- }
- foreach my $cpan_file (keys %$cpan_files) {
- if ($pat and ($cpan_file =~ /^($pat)/)) {
- delete $cpan_files->{$cpan_file};
- print_debug("Ignoring $cpan_file\n");
- next;
- }
- my $d = CPAN::DistnameInfo->new($cpan_file);
- next unless ($d->maturity eq 'released');
- my $dist_name = $d->dist;
- my $dist_vers = $d->version;
- my $cpanid = $d->cpanid;
- my $dist_file = $d->filename;
- unless ($dist_name and $dist_vers and $cpanid) {
- print_debug("No dist_name/version/cpanid for $cpan_file: skipping\n");
- delete $cpan_files->{$cpan_file};
- next;
- }
- # ignore specified dists
- if ($pat and ($dist_name =~ /^($pat)$/)) {
- delete $cpan_files->{$cpan_file};
- print_debug("Ignoring $dist_name\n");
- next;
- }
- if (not $dists->{$dist_name} or
- vcmp($dist_vers, $dists->{$dist_name}->{dist_vers}) > 0) {
- $dists->{$dist_name}->{dist_vers} = $dist_vers;
- $dists->{$dist_name}->{dist_file} = $dist_file;
- $dists->{$dist_name}->{cpanid} = $cpanid;
- }
- }
-
- my $wanted;
- foreach my $dist_name (keys %$dists) {
- $wanted->{basename($dists->{$dist_name}->{dist_file})} = $dist_name;
- }
- foreach my $mod_name (keys %$packages) {
- my $file = basename($packages->{$mod_name}->{dist_file});
- my $dist_name = $wanted->{$file};
- unless ($dist_name and $dists->{$dist_name}) {
- delete $packages->{$mod_name};
- next;
- }
- $mods->{$mod_name}->{dist_name} = $dist_name;
- $dists->{$dist_name}->{modules}->{$mod_name}++;
- $mods->{$mod_name}->{mod_vers} = $packages->{$mod_name}->{mod_vers};
- if (my $info = $modlist->{$mod_name}) {
- if (my $mod_abs = $info->{description}) {
- $mods->{$mod_name}->{mod_abs} = $mod_abs;
- (my $trial_dist = $mod_name) =~ s!::!-!g;
- if ($trial_dist eq $dist_name) {
- $dists->{$dist_name}->{dist_abs} = $mod_abs;
- }
- }
- if (my $chapterid = $info->{chapterid} + 0) {
- $mods->{$mod_name}->{chapterid} = $chapterid;
- (my $sub_chapter = $mod_name) =~ s!^([^:]+).*!$1!;
- $dists->{$dist_name}->{chapterid}->{$chapterid}->{$sub_chapter}++;
- }
- my %dslip = ();
- for (qw(statd stats statl stati statp) ) {
- next unless defined $info->{$_};
- $dslip{$_} = $info->{$_};
- }
- if (%dslip) {
- my $value = '';
- foreach (qw(d s l i p)) {
- my $key = 'stat' . $_;
- $value .= (defined $dslip{$key} ?
- $dslip{$key} : '?');
- }
- $mods->{$mod_name}->{dslip} = $value;
- (my $trial_dist = $mod_name) =~ s!::!-!g;
- if ($trial_dist eq $dist_name) {
- $dists->{$dist_name}->{dslip} = $value;
- }
- }
- }
- }
- $self->{dists} = $dists;
- $self->{mods} = $mods;
-}
-
-sub modlist {
- my $self = shift;
- my $index = 'modules/03modlist.data.gz';
- my $mod = $self->{keep_source_where} ?
- CPAN::FTP->localize($index,
- catfile($self->{keep_source_where}, $index) ) :
- catfile($self->{CPAN}, $index);
- return unless check_file('modules/03modlist.data.gz', $mod);
- print_debug("Reading information from $mod\n");
- my $lines = zcat($mod);
- while (@$lines) {
- my $shift = shift(@$lines);
- last if $shift =~ /^\s*$/;
- }
- push @$lines, q{CPAN::Modulelist->data;};
- my($comp) = Safe->new("CPAN::Safe1");
- my($eval) = join("\n", @$lines);
- my $ret = $comp->reval($eval);
- die "Cannot eval $mod: $@" if $@;
- return $ret;
-}
-
-sub packages {
- my $self = shift;
- my $index = 'modules/02packages.details.txt.gz';
- my $packages = $self->{keep_source_where} ?
- CPAN::FTP->localize($index,
- catfile($self->{keep_source_where}, $index) ) :
- catfile($self->{CPAN}, $index);
- return unless check_file('modules/02packages.details.txt.gz', $packages);
- print_debug("Reading information from $packages\n");
- my $lines = zcat($packages);
- while (@$lines) {
- my $shift = shift(@$lines);
- last if $shift =~ /^\s*$/;
- }
- my ($mods, $cpan_files);
- foreach (@$lines) {
- my ($mod_name,$mod_vers,$dist_file,$comment) = split " ", $_, 4;
- $mod_vers = undef if $mod_vers eq 'undef';
- $mods->{$mod_name} = {mod_vers => $mod_vers, dist_file => $dist_file};
- $cpan_files->{$dist_file}++;
- }
- return ($mods, $cpan_files);
-}
-
-sub mailrc {
- my $self = shift;
- my $index = 'authors/01mailrc.txt.gz';
- my $mailrc = $self->{keep_source_where} ?
- CPAN::FTP->localize($index,
- catfile($self->{keep_source_where}, $index) ) :
- catfile($self->{CPAN}, $index);
- return unless check_file('authors/01mailrc.txt.gz', $mailrc);
- print_debug("Reading information from $mailrc\n");
- my $lines = zcat($mailrc);
- my $auths;
- foreach (@$lines) {
- #my($cpanid,$fullname,$email) =
- #m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
- my ($cpanid, $authinfo) = m/alias\s+(\S+)\s+\"([^\"]+)\"/;
- next unless $cpanid;
- my ($fullname, $email);
- if ($authinfo =~ m/([^<]+)\<(.*)\>/) {
- $fullname = $1;
- $email = $2;
- }
- else {
- $fullname = '';
- $email = lc($cpanid) . '@cpan.org';
- }
- $auths->{$cpanid} = {fullname => trim($fullname),
- email => trim($email)};
- }
- $self->{auths} = $auths;
-}
-
-sub check_file {
- my ($index, $file) = @_;
- unless ($file) {
- warn qq{index file '$index' not defined};
- return;
- }
- unless (-f $file) {
- warn qq{index file '$file' not found};
- return;
- }
- return 1;
-}
-
-sub zcat {
- my $file = shift;
- my ($buffer, $lines);
- my $gz = gzopen($file, 'rb')
- or die "Cannot open $file: $gzerrno";
- while ($gz->gzreadline($buffer) > 0) {
- push @$lines, $buffer;
- }
- die "Error reading from $file: $gzerrno" . ($gzerrno+0)
- if $gzerrno != Z_STREAM_END;
- $gz->gzclose();
- return $lines;
-}
-
-sub trim {
- my $string = shift;
- return '' unless $string;
- $string =~ s/^\s+//;
- $string =~ s/\s+$//;
- $string =~ s/\s+/ /g;
- return $string;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-CPAN::SQLite::Info - extract information from CPAN indices
-
-=head1 DESCRIPTION
-
-This module extracts information from the CPAN indices
-F<$CPAN/modules/03modlist.data.gz>,
-F<$CPAN/modules/02packages.details.txt.gz>, and
-F<$CPAN/authors/01mailrc.txt.gz>.
-
-A C<CPAN::SQLite::Info> object is created with
-
- my $info = CPAN::SQLite::Info->new(CPAN => $cpan);
-
-where C<$cpan> specifies the top-level CPAN directory
-underneath which the index files are found. Calling
-
- $info->fetch_info();
-
-will result in the object being populated with 3 hash references:
-
-=over 3
-
-=item * C<$info-E<gt>{dists}>
-
-This contains information on distributions. Keys of this hash
-reference are the distribution names, with the associated value being a
-hash reference with keys of
-
-=over 3
-
-=item C<dist_vers> - the version of the CPAN file
-
-=item C<dist_file> - the CPAN filename
-
-=item C<cpanid> - the CPAN author id
-
-=item C<dist_abs> - a description, if available
-
-=item C<modules> - specifies the modules present in the distribution:
-
- for my $module (keys %{$info->{$distname}->{modules}}) {
- print "Module: $module\n";
- }
-
-=item C<chapterid> - specifies the chapterid and the subchapter
-for the distribution:
-
- for my $id (keys %{$info->{$distname}->{chapterid}}) {
- print "For chapterid $id\n";
- for my $sc (keys %{$info->{$distname}->{chapterid}->{$id}}) {
- print " Subchapter: $sc\n";
- }
- }
-
-=back
-
-=item * C<$info-E<gt>{mods}>
-
-This contains information on modules. Keys of this hash
-reference are the module names, with the associated values being a
-hash reference with keys of
-
-=over 3
-
-=item C<dist_name> - the distribution name containing the module
-
-=item C<mod_vers> - the version
-
-=item C<mod_abs> - a description, if available
-
-=item C<chapterid> - the chapter id of the module, if present
-
-=item C<dslip> - a 5 character string specifying the dslip
-(development, support, language, interface, public licence) information.
-
-=back
-
-=item * C<$info-E<gt>{auths}>
-
-This contains information on CPAN authors. Keys of this hash
-reference are the CPAN ids, with the associated value being a
-hash reference with keys of
-
-=over 3
-
-=item C<fullname> - the author's full name
-
-=item C<email> - the author's email address
-
-=back
-
-=back
-
-=head1 SEE ALSO
-
-L<CPAN::SQLite::Index>
-
-=cut
-
diff --git a/Master/tlpkg/tlperl/lib/CPAN/SQLite/META.pm b/Master/tlpkg/tlperl/lib/CPAN/SQLite/META.pm
deleted file mode 100755
index b1309eaf1d8..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/SQLite/META.pm
+++ /dev/null
@@ -1,480 +0,0 @@
-package CPAN::SQLite::META;
-require CPAN::SQLite;
-use strict;
-use warnings;
-use base qw(Exporter);
-our @EXPORT_OK;
-@EXPORT_OK = qw(setup update);
-our $global_id;
-our $VERSION = '0.199';
-
-sub new {
- my ($class, $cpan_meta) = @_;
- my $cpan_sqlite = CPAN::SQLite->new();
- bless {cpan_meta => $cpan_meta, cpan_sqlite => $cpan_sqlite}, $class;
-}
-
-sub set {
- my ($self, $class, $id) = @_;
- my $sqlite_obj = $self->make_obj(class => $class, id => $id);
- return $sqlite_obj->set_one();
-}
-
-sub search {
- my ($self, $class, $regex) = @_;
- my $sqlite_obj = $self->make_obj(class => $class, regex => $regex);
- $sqlite_obj->set_many();
-}
-
-sub make_obj {
- my ($self, %args) = @_;
- my $class = $args{class};
- die qq{Must supply a CPAN::* class string}
- unless ($class and $class =~ /^CPAN::/);
- (my $type = $class) =~ s/^CPAN//;
- my $package = __PACKAGE__ . $type;
- bless {cpan_meta => $self->{cpan_meta},
- cpan_sqlite => $self->{cpan_sqlite},
- class => $class,
- id => $args{id}, regex => $args{regex},
- }, $package;
-}
-
-package CPAN::SQLite::META::Author;
-use base qw(CPAN::SQLite::META);
-use CPAN::SQLite::Util qw(has_hash_data);
-
-sub set_one {
- my $self = shift;
- my $cpan_sqlite = $self->{cpan_sqlite};
- my $id = $self->{id};
- my $class = $self->{class};
- $cpan_sqlite->{results} = {};
- $cpan_sqlite->query(mode => 'author', name => $id, meta_obj => $self);
- my $cpan_meta = $self->{cpan_meta};
- $cpan_meta->{readonly}{$class}{$id};
-}
-
-sub set_many {
- my $self = shift;
- my $cpan_sqlite = $self->{cpan_sqlite};
- my $regex = $self->{regex};
- $cpan_sqlite->{results} = [];
- $cpan_sqlite->query(mode => 'author', query => $regex, meta_obj => $self);
-}
-
-sub set_data {
- my ($self, $results) = @_;
- $self->set_author($results->{cpanid}, $results);
-}
-
-package CPAN::SQLite::META::Distribution;
-use base qw(CPAN::SQLite::META);
-use CPAN::SQLite::Util qw(has_hash_data download);
-use CPAN::DistnameInfo;
-my $ext = qr{\.(tar\.gz|tar\.Z|tgz|zip)$};
-
-sub set_one {
- my $self = shift;
- my $cpan_sqlite = $self->{cpan_sqlite};
- my $id = $self->{id};
- my ($dist_name, $dist_id);
- if ($id =~ /$ext/) {
- ($dist_name, $dist_id) = $self->extract_distinfo($id);
- }
- return unless ($dist_name and $dist_id);
- my $class = $self->{class};
- $cpan_sqlite->{results} = {};
- $cpan_sqlite->query(mode => 'dist', name => $dist_name, meta_obj => $self);
- my $cpan_meta = $self->{cpan_meta};
- $cpan_meta->{readonly}{$class}{$dist_id};
-}
-
-sub set_many {
- my $self = shift;
- my $cpan_sqlite = $self->{cpan_sqlite};
- my $regex = $self->{regex};
- $cpan_sqlite->{results} = [];
- $cpan_sqlite->query(mode => 'dist', query => $regex, meta_obj => $self);
-}
-
-sub set_data {
- my ($self, $results) = @_;
- $global_id = $results->{download};
- $self->set_dist($results->{download}, $results);
-}
-
-sub set_list_data {
- my ($self, $results, $download) = @_;
- $global_id = $download;
- $self->set_containsmods($results);
- $global_id = undef;
-}
-
-package CPAN::SQLite::META::Module;
-use base qw(CPAN::SQLite::META);
-use CPAN::SQLite::Util qw(has_hash_data);
-
-sub set_one {
- my $self = shift;
- my $cpan_sqlite = $self->{cpan_sqlite};
- my $id = $self->{id};
- return if ($id =~ /^Bundle::/);
- my $class = $self->{class};
- $cpan_sqlite->{results} = {};
- $cpan_sqlite->query(mode => 'module', name => $id, meta_obj => $self);
- my $cpan_meta = $self->{cpan_meta};
- $cpan_meta->{readonly}{$class}{$id};
-}
-
-sub set_many {
- my $self = shift;
- my $cpan_sqlite = $self->{cpan_sqlite};
- my $regex = $self->{regex};
- $cpan_sqlite->{results} = [];
- $cpan_sqlite->query(mode => 'module', query => $regex, meta_obj => $self);
-}
-
-sub set_data {
- my ($self, $results) = @_;
- $self->set_module($results->{mod_name}, $results);
- $global_id = $results->{download};
- $self->set_dist($results->{download}, $results);
-}
-
-sub set_list_data {
- my ($self, $results, $download) = @_;
- $global_id = $download;
- $self->set_containsmods($results);
- $global_id = undef;
-}
-
-package CPAN::SQLite::META::Bundle;
-use base qw(CPAN::SQLite::META);
-use CPAN::SQLite::Util qw(has_hash_data);
-
-sub set_one {
- my $self = shift;
- my $cpan_sqlite = $self->{cpan_sqlite};
- my $id = $self->{id};
- unless ($id =~ /^Bundle::/) {
- $id = 'Bundle::' . $id;
- }
- my $class = $self->{class};
- $cpan_sqlite->{results} = {};
- $cpan_sqlite->query(mode => 'module', name => $id, meta_obj => $self);
- my $cpan_meta = $self->{cpan_meta};
- $cpan_meta->{readonly}{$class}{$id};
-}
-
-sub set_many {
- my $self = shift;
- my $cpan_sqlite = $self->{cpan_sqlite};
- my $regex = $self->{regex};
- unless ($regex =~ /(^Bundle::|[\^\$\*\+\?\|])/i) {
- $regex = '^Bundle::' . $regex;
- }
- $regex = '^Bundle::' if $regex eq '^';
- $cpan_sqlite->{results} = [];
- $cpan_sqlite->query(mode => 'module', query => $regex, meta_obj => $self);
-}
-
-sub set_data {
- my ($self, $results) = @_;
- $self->set_bundle($results->{mod_name}, $results);
- $global_id = $results->{download};
- $self->set_dist($results->{download}, $results);
-}
-
-sub set_list_data {
- my ($self, $results, $download) = @_;
- $global_id = $download;
- $self->set_containsmods($results);
- $global_id = undef;
-}
-
-package CPAN::SQLite::META;
-use CPAN::SQLite::Util qw(download);
-
-my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
-my @days = qw(Sun Mon Tue Wed Thu Fri Sat);
-
-sub set_author {
- my ($self, $id, $results) = @_;
- my $class = 'CPAN::Author';
- my $cpan_meta = $self->{cpan_meta};
- $cpan_meta->instance(
- $class => $id
- )->set(
- 'FULLNAME' => $results->{fullname},
- 'EMAIL' => $results->{email},
- );
-}
-
-sub set_module {
- my ($self, $id, $results) = @_;
- my $class = 'CPAN::Module';
- my $cpan_meta = $self->{cpan_meta};
- my %dslip;
- if (my $dslip = $results->{dslip}) {
- my @values = split '', $dslip;
- for (qw(d s l i p)) {
- $dslip{'stat' . $_} = shift @values;
- }
- }
- my $d = $cpan_meta->instance(
- $class => $id
- );
- $d->set(
- 'description' => $results->{mod_abs},
- 'userid' => $results->{cpanid},
- 'CPAN_VERSION' => $results->{mod_vers},
- 'CPAN_FILE' => $results->{download},
- 'CPAN_USERID' => $results->{cpanid},
- 'chapterid' => $results->{chapterid},
- %dslip,
- );
-}
-
-sub set_bundle {
- my ($self, $id, $results) = @_;
- my $class = 'CPAN::Bundle';
- my $cpan_meta = $self->{cpan_meta};
- my %dslip;
- if (my $dslip = $results->{dslip}) {
- my @values = split '', $dslip;
- for (qw(d s l i p)) {
- $dslip{'stat' . $_} = shift @values;
- }
- }
- my $d = $cpan_meta->instance(
- $class => $id
- );
- $d->set(
- 'description' => $results->{mod_abs},
- 'userid' => $results->{cpanid},
- 'CPAN_VERSION' => $results->{mod_vers},
- 'CPAN_FILE' => $results->{download},
- 'CPAN_USERID' => $results->{cpanid},
- 'chapterid' => $results->{chapterid},
- %dslip,
- );
-}
-
-sub set_dist {
- my ($self, $id, $results) = @_;
- my $class = 'CPAN::Distribution';
- my $cpan_meta = $self->{cpan_meta};
- my $d = $cpan_meta->instance(
- $class => $id
- );
- $d->set(
- 'DESCRIPTION' => $results->{dist_abs},
- 'CPAN_USERID' => $results->{cpanid},
- 'CPAN_VERSION' => $results->{dist_vers},
- );
-}
-
-sub set_containsmods {
- my ($self, $mods) = @_;
- my $class = 'CPAN::Distribution';
- my $cpan_meta = $self->{cpan_meta};
- my %containsmods;
- if ($mods and (ref($mods) eq 'ARRAY')) {
- %containsmods = map {$_->{mod_name} => 1} @$mods;
- }
- my $d = $cpan_meta->instance(
- $class => $global_id
- );
- $d->{CONTAINSMODS} = \%containsmods;
-}
-
-sub reload {
- my($self, %args) = @_;
- my $time = $args{'time'} || time;
- my $force = $args{force};
- my $db_name = $CPAN::SQLite::db_name;
- my $db = File::Spec->catfile($CPAN::Config->{cpan_home}, $db_name);
- my $journal_file = $db . '-journal';
- if (-e $journal_file) {
- warn qq{Database locked - cannot update.};
- return;
- }
- my @args = ($^X, '-MCPAN::SQLite::META=setup,update', '-e');
- if (-e $db && -s _) {
- my $mtime_db = (stat(_))[9];
- my $time_string = gmtime_string($mtime_db);
- warn "Database was generated on $time_string\n";
- unless ($force) {
- return if (($time - $mtime_db) < $CPAN::Config->{index_expire}*86400);
- }
- warn "Updating database file ...\n";
- push @args, q{update};
- }
- else {
- unlink($db) if -e _;
- warn "Creating database file ...\n";
- push @args, q{setup};
- }
- if ($CPAN::SQLite::DBI::dbh) {
- $CPAN::SQLite::DBI::dbh->disconnect();
- $CPAN::SQLite::DBI::dbh = undef;
- }
- system(@args) == 0 or die qq{system @args failed: $?};
- warn "Done!\n";
-}
-
-sub setup {
- my $obj = CPAN::SQLite->new(setup => 1);
- $obj->index() or die qq{CPAN::SQLite setup failed};
-}
-
-sub update {
- my $obj = CPAN::SQLite->new();
- $obj->index() or die qq{CPAN::SQLite update failed};
-}
-
-sub gmtime_string {
- my $time = shift;
- return unless $time;
- my @a = gmtime($time);
- my $string = sprintf("%s, %02d %s %d %02d:%02d:%02d GMT",
- $days[$a[6]], $a[3], $months[$a[4]],
- $a[5] + 1900, $a[2], $a[1], $a[0]);
- return $string;
-}
-
-sub extract_distinfo {
- my ($self, $pathname) = @_;
- unless ($pathname =~ m{^\w/\w\w/}) {
- $pathname =~ s{^(\w)(\w)(.*)}{$1/$1$2/$1$2$3};
- }
- my $d = CPAN::DistnameInfo->new($pathname);
- my $dist = $d->dist;
- my $download = download($d->cpanid, $d->filename);
- return ($dist and $download) ? ($dist, $download) : undef;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-CPAN::SQLite::META - helper module for CPAN.pm integration
-
-=head1 DESCRIPTION
-
-This module has no direct public interface, but is intended
-as a helper module for use of CPAN::SQLite within the CPAN.pm
-module. A new object is created as
-
- my $obj = CPAN::SQLite::META->new($CPAN::META);
-
-where C<$CPAN::META> comes from CPAN.pm. There are then
-two main methods available.
-
-=over 4
-
-=item C<set>
-
-This is used as
-
- $obj->set($class, $id);
-
-where C<$class> is one of C<CPAN::Author>, C<CPAN::Module>, or
-C<CPAN::Distribution>, and C<$id> is the id CPAN.pm uses to
-identify the class. The method searches the C<CPAN::SQLite>
-database by name using the appropriate C<author>, C<dist>,
-or C<module> mode, and if a result is found, calls
-
- $CPAN::META->instance(
- $class => $id
- )->set(
- %attributes
- );
-
-to register an instance of this class within C<CPAN.pm>.
-
-=item C<ssearch>
-
-This is used as
-
- $obj->search($class, $id);
-
-where C<$class> is one of C<CPAN::Author>, C<CPAN::Module>, or
-C<CPAN::Distribution>, and C<$id> is the id CPAN.pm uses to
-identify the class. The method searches the C<CPAN::SQLite>
-database by C<query> using the appropriate C<author>, C<dist>,
-or C<module> mode, and if results are found, calls
-
- $CPAN::META->instance(
- $class => $id
- )->set(
- %attributes
- );
-
-for each match to register an instance of this class
-within C<CPAN.pm>.
-
-=back
-
-The attributes set within C<$CPAN::META->instance> depend
-on the particular class.
-
-=over
-
-=item author
-
-The attributes are
-
- 'FULLNAME' => $results->{fullname},
- 'EMAIL' => $results->{email},
-
-where C<$results> are the results returned from C<CPAN::SQLite>.
-
-=item module
-
-The attributes are
-
- 'description' => $results->{mod_abs},
- 'userid' => $results->{cpanid},
- 'CPAN_VERSION' => $results->{mod_vers},
- 'CPAN_FILE' => $results->{download},
- 'CPAN_USERID' => $results->{cpanid},
- 'chapterid' => $results->{chapterid},
- %dslip,
-
-where C<$results> are the results returned from C<CPAN::SQLite>.
-Here, C<%dslip> is a hash containing keys C<statd>, C<stats>,
-C<statl>, C<stati>, and C<statp>, with corresponding values
-being the registered dslip entries for the module, if present.
-
-=item dist
-
-The attributes are
-
- 'DESCRIPTION' => $results->{dist_abs},
- 'CPAN_USERID' => $results->{cpanid},
- 'CPAN_VERSION' => $results->{dist_vers},
-
-As well, a C<CONTAINSMODS> key to C<$CPAN::META> is added, this
-being a hash reference whose keys are the modules contained
-within the distribution.
-
-=back
-
-There is also a method available C<reload>, which rebuilds
-the database. It can be used as
-
- $obj->reload(force => 1, time => $time);
-
-The C<time> option (which, if not passed in, will default to the
-current time) will be used to compare the current time to
-the mtime of the database file; if they differ by more than
-one day, the database will be rebuilt. The <force> option, if
-given, will force a rebuilding of the database regardless
-of the time difference.
-
-=cut
-
diff --git a/Master/tlpkg/tlperl/lib/CPAN/SQLite/Populate.pm b/Master/tlpkg/tlperl/lib/CPAN/SQLite/Populate.pm
deleted file mode 100755
index ec03f9bdecf..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/SQLite/Populate.pm
+++ /dev/null
@@ -1,958 +0,0 @@
-package CPAN::SQLite::Populate;
-use strict;
-use warnings;
-no warnings qw(redefine);
-use CPAN::SQLite::Util qw($table_id has_hash_data print_debug);
-use CPAN::SQLite::DBI::Index;
-use CPAN::SQLite::DBI qw($dbh);
-use File::Find;
-use File::Basename;
-use File::Spec::Functions;
-use File::Path;
-
-our $dbh = $CPAN::SQLite::DBI::dbh;
-my ($setup);
-our $VERSION = '0.199';
-
-my %tbl2obj;
-$tbl2obj{$_} = __PACKAGE__ . '::' . $_
- for (qw(dists mods auths chaps));
-my %obj2tbl = reverse %tbl2obj;
-
-sub new {
- my ($class, %args) = @_;
-
- $setup = $args{setup};
-
- my $index = $args{index};
- my @tables = qw(dists mods auths);
- foreach my $table (@tables) {
- my $obj = $index->{$table};
- die "Please supply a CPAN::SQLite::Index::$table object"
- unless ($obj and ref($obj) eq "CPAN::SQLite::Index::$table");
- }
- my $state = $args{state};
- unless ($setup) {
- die "Please supply a CPAN::SQLite::State object"
- unless ($state and ref($state) eq 'CPAN::SQLite::State');
- }
- my $cdbi = CPAN::SQLite::DBI::Index->new(%args);
-
- my $self = {index => $index,
- state => $state,
- obj => {},
- cdbi => $cdbi,
- db_name => $args{db_name},
- };
- bless $self, $class;
-}
-
-sub populate {
- my $self = shift;
-
- if ($setup) {
- unless ($self->{cdbi}->create_tables(setup => $setup)) {
- warn "Creating tables failed";
- return;
- }
- }
- unless ($self->create_objs()) {
- warn "Cannot create objects";
- return;
- }
- unless ($self->populate_tables()) {
- warn "Populating tables failed";
- return;
- }
- return 1;
-}
-
-sub create_objs {
- my $self = shift;
- my @tables = qw(dists auths mods chaps);
-
- foreach my $table (@tables) {
- my $obj;
- my $pack = $tbl2obj{$table};
- my $index = $self->{index}->{$table};
- if ($index and ref($index) eq "CPAN::SQLite::Index::$table") {
- my $info = $index->{info};
- return unless has_hash_data($info);
- $obj = $pack->new(info => $info,
- cdbi => $self->{cdbi}->{objs}->{$table});
- }
- else {
- $obj = $pack->new(cdbi => $self->{cdbi}->{objs}->{$table});
- }
- $self->{obj}->{$table} = $obj;
- }
- foreach my $table (@tables) {
- my $obj = $self->{obj}->{$table};
- foreach (@tables) {
- next if ref($obj) eq $tbl2obj{$_};
- $obj->{obj}->{$_} = $self->{obj}->{$_};
- }
- }
-
- unless ($setup) {
- my $state = $self->{state};
- my @tables = qw(auths dists mods);
- my @data = qw(ids insert update delete);
-
- foreach my $table (@tables) {
- my $state_obj = $state->{obj}->{$table};
- my $pop_obj = $self->{obj}->{$table};
- $pop_obj->{$_} = $state_obj->{$_} for (@data);
- }
- }
- return 1;
-}
-
-sub populate_tables {
- my $self = shift;
- my @methods = $setup ? qw(insert) : qw(insert update delete);
- my @tables = qw(auths dists mods chaps);
- for my $method (@methods) {
- for my $table (@tables) {
- my $obj = $self->{obj}->{$table};
- unless ($obj->$method()) {
- if (my $error = $obj->{error_msg}) {
- print_debug("Fatal error from ", ref($obj), ": ", $error, $/);
- return;
- }
- else {
- my $info = $obj->{info_msg};
- print_debug("Info from ", ref($obj), ": ", $info, $/);
- }
- }
- }
- }
- return 1;
-}
-
-package CPAN::SQLite::Populate::auths;
-use base qw(CPAN::SQLite::Populate);
-use CPAN::SQLite::Util qw(has_hash_data print_debug);
-
-sub new {
- my ($class, %args) = @_;
- my $info = $args{info};
- die "No author info available" unless has_hash_data($info);
- my $cdbi = $args{cdbi};
- die "No dbi object available"
- unless ($cdbi and ref($cdbi) eq 'CPAN::SQLite::DBI::Index::auths');
- my $self = {
- info => $info,
- insert => {},
- update => {},
- delete => {},
- ids => {},
- obj => {},
- cdbi => $cdbi,
- error_msg => '',
- info_msg => '',
- };
- bless $self, $class;
-}
-
-sub insert {
- my $self = shift;
- unless ($dbh) {
- $self->{error_msg} = q{No db handle available};
- return;
- }
- my $info = $self->{info};
- my $cdbi = $self->{cdbi};
- my $data = $setup ? $info : $self->{insert};
- unless (has_hash_data($data)) {
- $self->{info_msg} = q{No author data to insert};
- return;
- }
- my $auth_ids = $self->{ids};
- my @fields = qw(cpanid email fullname);
- my $sth = $cdbi->sth_insert(\@fields) or do {
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- foreach my $cpanid (keys %$data) {
- my $values = $info->{$cpanid};
- next unless ($values and $cpanid);
- print_debug("Inserting author $cpanid\n");
- $sth->execute($cpanid, $values->{email}, $values->{fullname})
- or do {
- $cdbi->db_error($sth);
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- $auth_ids->{$cpanid} =
- $dbh->func('last_insert_rowid') or do {
- $cdbi->db_error($sth);
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- }
- $sth->finish();
- undef $sth;
- $dbh->commit() or do {
- $cdbi->db_error();
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- return 1;
-}
-
-sub update {
- my $self = shift;
- unless ($dbh) {
- $self->{error_msg} = q{No db handle available};
- return;
- }
- my $data = $self->{update};
- my $cdbi = $self->{cdbi};
- unless (has_hash_data($data)) {
- $self->{info_msg} = q{No author data to update};
- return;
- }
-
- my $info = $self->{info};
- my @fields = qw(cpanid email fullname);
- foreach my $cpanid (keys %$data) {
- print_debug("Updating author $cpanid\n");
- next unless $data->{$cpanid};
- my $sth = $cdbi->sth_update(\@fields, $data->{$cpanid});
- my $values = $info->{$cpanid};
- next unless ($cpanid and $values);
- $sth->execute($cpanid, $values->{email}, $values->{fullname})
- or do {
- $cdbi->db_error($sth);
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- $sth->finish();
- undef $sth;
- }
- $dbh->commit() or do {
- $cdbi->db_error();
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- return 1;
-}
-
-sub delete {
- my $self = shift;
- $self->{info_msg} = q{No author data to delete};
- return;
-}
-
-package CPAN::SQLite::Populate::dists;
-use base qw(CPAN::SQLite::Populate);
-use CPAN::SQLite::Util qw(has_hash_data print_debug);
-
-sub new {
- my ($class, %args) = @_;
- my $info = $args{info};
- die "No dist info available" unless has_hash_data($info);
- my $cdbi = $args{cdbi};
- die "No dbi object available"
- unless ($cdbi and ref($cdbi) eq 'CPAN::SQLite::DBI::Index::dists');
- my $self = {
- info => $info,
- insert => {},
- update => {},
- delete => {},
- ids => {},
- obj => {},
- cdbi => $cdbi,
- error_msg => '',
- info_msg => '',
- };
- bless $self, $class;
-}
-
-sub insert {
- my $self = shift;
- unless ($dbh) {
- $self->{error_msg} = q{No db handle available};
- return;
- }
- return unless my $auth_obj = $self->{obj}->{auths};
- my $cdbi = $self->{cdbi};
- my $auth_ids = $auth_obj->{ids};
- my $dists = $self->{info};
- my $data = $setup ? $dists : $self->{insert};
- unless (has_hash_data($data)) {
- $self->{info_msg} = q{No dist data to insert};
- return;
- }
- unless ($dists and $auth_ids) {
- $self->{error_msg}->{index} = q{No dist index data available};
- return;
- }
-
- my $dist_ids = $self->{ids};
- my @fields = qw(auth_id dist_name dist_file dist_vers dist_abs dist_dslip);
- my $sth = $cdbi->sth_insert(\@fields) or do {
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- foreach my $distname (keys %$data) {
- my $values = $dists->{$distname};
- my $cpanid = $values->{cpanid};
- next unless ($values and $cpanid and $auth_ids->{$cpanid});
- print_debug("Inserting $distname of $cpanid\n");
- $sth->execute($auth_ids->{$values->{cpanid}}, $distname,
- $values->{dist_file}, $values->{dist_vers},
- $values->{dist_abs}, $values->{dslip}) or do {
- $cdbi->db_error($sth);
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- $dist_ids->{$distname} = $dbh->func('last_insert_rowid') or do {
- $cdbi->db_error($sth);
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- }
- $sth->finish();
- undef $sth;
- $dbh->commit() or do {
- $cdbi->db_error();
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- return 1;
-}
-
-sub update {
- my $self = shift;
- unless ($dbh) {
- $self->{error_msg} = q{No db handle available};
- return;
- }
- my $cdbi = $self->{cdbi};
- my $data = $self->{update};
- unless (has_hash_data($data)) {
- $self->{info_msg} = q{No dist data to update};
- return;
- }
- return unless my $auth_obj = $self->{obj}->{auths};
- my $auth_ids = $auth_obj->{ids};
- my $dists = $self->{info};
- unless ($dists and $auth_ids) {
- $self->{error_msg} = q{No dist index data available};
- return;
- }
-
- my @fields = qw(auth_id dist_name dist_file dist_vers dist_abs dist_dslip);
- foreach my $distname (keys %$data) {
- next unless $data->{$distname};
- my $sth = $cdbi->sth_update(\@fields, $data->{$distname});
- my $values = $dists->{$distname};
- my $cpanid = $values->{cpanid};
- next unless ($values and $cpanid and $auth_ids->{$cpanid});
- print_debug("Updating $distname of $cpanid\n");
- $sth->execute($auth_ids->{$values->{cpanid}}, $distname,
- $values->{dist_file}, $values->{dist_vers},
- $values->{dist_abs}, $values->{dslip}) or do {
- $cdbi->db_error($sth);
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- $sth->finish();
- undef $sth;
- }
- $dbh->commit() or do {
- $cdbi->db_error();
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- return 1;
-}
-
-sub delete {
- my $self = shift;
- unless ($dbh) {
- $self->{error_msg} = q{No db handle available};
- return;
- }
- my $cdbi = $self->{cdbi};
- my $data = $self->{delete};
- unless (has_hash_data($data)) {
- $self->{info_msg} = q{No dist data to delete};
- return;
- }
-
- my $sth = $cdbi->sth_delete('dist_id');
- foreach my $distname(keys %$data) {
- print_debug("Deleting $distname\n");
- $sth->execute($data->{$distname}) or do {
- $cdbi->db_error($sth);
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- }
- $sth->finish();
- undef $sth;
- $dbh->commit() or do {
- $cdbi->db_error();
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- return 1;
-}
-
-package CPAN::SQLite::Populate::mods;
-use base qw(CPAN::SQLite::Populate);
-use CPAN::SQLite::Util qw(has_hash_data print_debug);
-
-sub new {
- my ($class, %args) = @_;
- my $info = $args{info};
- die "No module info available" unless has_hash_data($info);
- my $cdbi = $args{cdbi};
- die "No dbi object available"
- unless ($cdbi and ref($cdbi) eq 'CPAN::SQLite::DBI::Index::mods');
- my $self = {
- info => $info,
- insert => {},
- update => {},
- delete => {},
- ids => {},
- obj => {},
- cdbi => $cdbi,
- error_msg => '',
- info_msg => '',
- };
- bless $self, $class;
-}
-
-sub insert {
- my $self = shift;
- unless ($dbh) {
- $self->{error_msg} = q{No db handle available};
- return;
- }
- return unless my $dist_obj = $self->{obj}->{dists};
- my $cdbi = $self->{cdbi};
- my $dist_ids = $dist_obj->{ids};
- my $mods = $self->{info};
- my $data = $setup ? $mods : $self->{insert};
- unless (has_hash_data($data)) {
- $self->{info_msg} = q{No module data to insert};
- return;
- }
- unless ($mods and $dist_ids) {
- $self->{error_msg} = q{No module index data available};
- return;
- }
-
- my $mod_ids = $self->{ids};
- my @fields = qw(dist_id mod_name mod_abs
- mod_vers dslip chapterid);
-
- my $sth = $cdbi->sth_insert(\@fields) or do {
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- foreach my $modname(keys %$data) {
- my $values = $mods->{$modname};
- next unless ($values and $dist_ids->{$values->{dist_name}});
- $sth->execute($dist_ids->{$values->{dist_name}}, $modname,
- $values->{mod_abs}, $values->{mod_vers},
- $values->{dslip}, $values->{chapterid})
- or do {
- $cdbi->db_error($sth);
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- $mod_ids->{$modname} = $dbh->func('last_insert_rowid') or do {
- $cdbi->db_error($sth);
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- }
- $sth->finish();
- undef $sth;
- $dbh->commit() or do {
- $cdbi->db_error();
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- return 1;
-}
-
-sub update {
- my $self = shift;
- unless ($dbh) {
- $self->{error_msg} = q{No db handle available};
- return;
- }
- my $cdbi = $self->{cdbi};
- my $data = $self->{update};
- unless (has_hash_data($data)) {
- $self->{info_msg} = q{No module data to update};
- return;
- }
- return unless my $dist_obj = $self->{obj}->{dists};
- my $dist_ids = $dist_obj->{ids};
- my $mods = $self->{info};
- unless ($dist_ids and $mods) {
- $self->{error_msg} = q{No module index data available};
- return;
- }
-
- my @fields = qw(dist_id mod_name mod_abs
- mod_vers dslip chapterid);
-
- foreach my $modname (keys %$data) {
- next unless $data->{$modname};
- print_debug("Updating $modname\n");
- my $sth = $cdbi->sth_update(\@fields, $data->{$modname});
- my $values = $mods->{$modname};
- next unless ($values and $dist_ids->{$values->{dist_name}});
- $sth->execute($dist_ids->{$values->{dist_name}}, $modname,
- $values->{mod_abs}, $values->{mod_vers},
- $values->{dslip}, $values->{chapterid})
- or do {
- $cdbi->db_error($sth);
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- $sth->finish();
- undef $sth;
- }
- $dbh->commit() or do {
- $cdbi->db_error();
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- return 1;
-}
-
-sub delete {
- my $self = shift;
- unless ($dbh) {
- $self->{error_msg} = q{No db handle available};
- return;
- }
- return unless my $dist_obj = $self->{obj}->{dists};
- my $cdbi = $self->{cdbi};
- my $data = $dist_obj->{delete};
- if (has_hash_data($data)) {
- my $sth = $cdbi->sth_delete('dist_id');
- foreach my $distname(keys %$data) {
- $sth->execute($data->{$distname}) or do {
- $cdbi->db_error($sth);
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- }
- $sth->finish();
- undef $sth;
- }
-
- $data = $self->{delete};
- if (has_hash_data($data)) {
- my $sth = $cdbi->sth_delete('mod_id');
- foreach my $modname(keys %$data) {
- $sth->execute($data->{$modname}) or do {
- $cdbi->db_error($sth);
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- print_debug("Deleting $modname\n");
- }
- $sth->finish;
- undef $sth;
- }
- $dbh->commit() or do {
- $cdbi->db_error();
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- return 1;
-}
-
-package CPAN::SQLite::Populate::chaps;
-use base qw(CPAN::SQLite::Populate);
-use CPAN::SQLite::Util qw(has_hash_data print_debug);
-
-sub new {
- my ($class, %args) = @_;
- my $cdbi = $args{cdbi};
- die "No dbi object available"
- unless ($cdbi and ref($cdbi) eq 'CPAN::SQLite::DBI::Index::chaps');
- my $self = {
- obj => {},
- cdbi => $cdbi,
- error_msg => '',
- info_msg => '',
- };
- bless $self, $class;
-}
-
-sub insert {
- my $self = shift;
- unless ($dbh) {
- $self->{error_msg} = q{No db handle available};
- return;
- }
- return unless my $dist_obj = $self->{obj}->{dists};
- my $cdbi = $self->{cdbi};
- my $dist_insert = $dist_obj->{insert};
- my $dists = $dist_obj->{info};
- my $dist_ids = $dist_obj->{ids};
- my $data = $setup ? $dists : $dist_insert;
- unless (has_hash_data($data)) {
- $self->{info_msg} = q{No chap data to insert};
- return;
- }
- unless ($dists and $dist_ids) {
- $self->{error_msg} = q{No chap index data available};
- return;
- }
-
- my @fields = qw(chapterid dist_id subchapter);
- my $sth = $cdbi->sth_insert(\@fields) or do {
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- foreach my $dist (keys %$data) {
- my $values = $dists->{$dist};
- next unless defined $values->{chapterid};
- foreach my $chap_id(keys %{$values->{chapterid}}) {
- foreach my $sub_chap(keys %{$values->{chapterid}->{$chap_id}}) {
- next unless $dist_ids->{$dist};
- $sth->execute($chap_id, $dist_ids->{$dist}, $sub_chap)
- or do {
- $cdbi->db_error($sth);
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- }
- }
- }
- $sth->finish();
- undef $sth;
- $dbh->commit() or do {
- $cdbi->db_error();
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- return 1;
-}
-
-sub update {
- my $self = shift;
- unless ($dbh) {
- $self->{error_msg} = q{No db handle available};
- return;
- }
- my $cdbi = $self->{cdbi};
- return unless my $dist_obj = $self->{obj}->{dists};
- my $dists = $dist_obj->{info};
- my $dist_ids = $dist_obj->{ids};
- my $data = $dist_obj->{update};
- unless (has_hash_data($data)) {
- $self->{info_msg} = q{No chap data to update};
- return;
- }
- unless ($dist_ids and $dists) {
- $self->{error_msg} = q{No chap index data available};
- return;
- }
-
- my $sth = $cdbi->sth_delete('dist_id');
- foreach my $distname(keys %$data) {
- next unless $data->{$distname};
- $sth->execute($data->{$distname}) or do {
- $cdbi->db_error($sth);
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- }
- $sth->finish();
- undef $sth;
-
- my @fields = qw(chapterid dist_id subchapter);
- $sth = $cdbi->sth_insert(\@fields);
- foreach my $dist (keys %$data) {
- my $values = $dists->{$dist};
- next unless defined $values->{chapterid};
- foreach my $chap_id(keys %{$values->{chapterid}}) {
- foreach my $sub_chap(keys %{$values->{chapterid}->{$chap_id}}) {
- next unless $dist_ids->{$dist};
- $sth->execute($chap_id, $dist_ids->{$dist}, $sub_chap)
- or do {
- $cdbi->db_error($sth);
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- }
- }
- }
- $sth->finish();
- undef $sth;
- $dbh->commit() or do {
- $cdbi->db_error();
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- return 1;
-}
-
-sub delete {
- my $self = shift;
- unless ($dbh) {
- $self->{error_msg} = q{No db handle available};
- return;
- }
- return unless my $dist_obj = $self->{obj}->{dists};
- my $cdbi = $self->{cdbi};
- my $data = $dist_obj->{delete};
- unless (has_hash_data($data)) {
- $self->{info_msg} = q{No chap data to delete};
- return;
- }
-
- my $sth = $cdbi->sth_delete('dist_id');
- foreach my $distname(keys %$data) {
- $sth->execute($data->{$distname}) or do {
- $cdbi->db_error($sth);
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- }
- $sth->finish();
- undef $sth;
- $dbh->commit() or do {
- $cdbi->db_error();
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- return 1;
-}
-
-package CPAN::SQLite::Populate;
-
-sub db_error {
- my ($obj, $sth) = @_;
- return unless $dbh;
- if ($sth) {
- $sth->finish;
- undef $sth;
- }
- $obj->{error_msg} = q{Database error: } . $dbh->errstr;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-CPAN::SQLite::Populate - create and populate database tables
-
-=head1 DESCRIPTION
-
-This module is responsible for creating the tables
-(if C<setup> is passed as an option) and then for
-inserting, updating, or deleting (as appropriate) the
-relevant information from the indices of
-I<CPAN::SQLite::Info> and the
-state information from I<CPAN::SQLite::State>. It does
-this through the C<insert>, C<update>, and C<delete>
-methods associated with each table.
-
-Note that the tables are created with the C<setup> argument
-passed into the C<new> method when creating the
-C<CPAN::SQLite::Index> object; existing tables will be
-dropped.
-
-=head1 TABLES
-
-The tables used are described below - the data types correspond
-to mysql tables, with the corresponding adjustments made if
-the SQLite database is used.
-
-=head2 mods
-
-This table contains module information, and is created as
-
- mod_id INTEGER NOT NULL PRIMARY KEY
- mod_name VARCHAR(100) NOT NULL
- dist_id INTEGER NOT NULL
- mod_abs TEXT
- mod_vers VARCHAR(10)
- dslip VARCHAR(5)
- chapterid INTEGER
-
-=over 3
-
-=item * mod_id
-
-This is the primary (unique) key of the table.
-
-=item * dist_id
-
-This key corresponds to the id of the associated distribution
-in the C<dists> table.
-
-=item * mod_name
-
-This is the module's name.
-
-=item * mod_abs
-
-This is a description, if available, of the module.
-
-=item * mod_vers
-
-This value, if present, gives the version of the module.
-
-=item * dslip
-
-This is a 5 character string expressing the dslip
-(development, support, language, interface, public
-license) information.
-
-=item * chapterid
-
-This number corresponds to the chapter id of the module,
-if present.
-
-=back
-
-=head2 dists
-
-This table contains distribution information, and is created as
-
- dist_id INTEGER NOT NULL PRIMARY KEY
- dist_name VARCHAR(90) NOT NULL
- auth_id INTEGER NOT NULL
- dist_file VARCHAR(110) NOT NULL
- dist_vers VARCHAR(20)
- dist_abs TEXT
- dist_dslip VARCHAR(5)
-
-=over 3
-
-=item * dist_id
-
-This is the primary (unique) key of the table.
-
-=item * auth_id
-
-This corresponds to the CPAN author id of the distribution
-in the C<auths> table.
-
-=item * dist_name
-
-This corresponds to the distribution name (eg, for
-F<My-Distname-0.22.tar.gz>, C<dist_name> will be C<My-Distname>).
-
-=item * dist_file
-
-This corresponds to the CPAN file name.
-
-=item * dist_vers
-
-This is the version of the CPAN file (eg, for
-F<My-Distname-0.22.tar.gz>, C<dist_vers> will be C<0.22>).
-
-=item * dist_abs
-
-This is a description of the distribtion. If not directly
-supplied, the description for, eg, C<Foo::Bar>, if present, will
-be used for the C<Foo-Bar> distribution.
-
-=item * dist_dslip
-
-This is a 5 character string expressing the dslip
-(development, support, language, interface, public
-license) information. Normally this comes from the
-module name; this value for the distribution name
-comes in simple cases where the module name
-matches the distribution name by a substitution of
-C<::> by C<->.
-
-=back
-
-=head2 auths
-
-This table contains CPAN author information, and is created as
-
- auth_id INTEGER NOT NULL PRIMARY KEY
- cpanid VARCHAR(20) NOT NULL
- fullname VARCHAR(40) NOT NULL
- email TEXT
-
-=over 3
-
-=item * auth_id
-
-This is the primary (unique) key of the table.
-
-=item * cpanid
-
-This gives the CPAN author id.
-
-=item * fullname
-
-This is the full name of the author.
-
-=item * email
-
-This is the supplied email address of the author.
-
-=back
-
-=head2 chaps
-
-This table contains chapter information associated with
-distributions. PAUSE allows one, when registering modules,
-to associate a chapter id with each module (see the C<mods>
-table). This information is used here to associate chapters
-(and subchapters) with distributions in the following manner.
-Suppose a distribution C<Quantum-Theory> contains a module
-C<Beta::Decay> with chapter id C<55>, and
-another module C<Laser> with chapter id C<87>. The
-C<Quantum-Theory> distribution will then have two
-entries in this table - C<chapterid> of I<55> and
-C<subchapter> of I<Beta>, and C<chapterid> of I<87> and
-C<subchapter> of I<Laser>.
-
-The table is created as follows.
-
- chap_id INTEGER NOT NULL PRIMARY KEY
- chapterid INTEGER
- dist_id INTEGER NOT NULL
- subchapter TEXT
-
-=over 3
-
-=item * chap_id
-
-This is the primary (unique) key of the table.
-
-=item * chapterid
-
-This number corresponds to the chapter id.
-
-=item * dist_id
-
-This is the id corresponding to the distribution in the
-C<dists> table.
-
-=item * subchapter
-
-This is the subchapter.
-
-=back
-
-=head1 SEE ALSO
-
-L<CPAN::SQLite::Index>
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/CPAN/SQLite/Search.pm b/Master/tlpkg/tlperl/lib/CPAN/SQLite/Search.pm
deleted file mode 100755
index c09b549c606..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/SQLite/Search.pm
+++ /dev/null
@@ -1,520 +0,0 @@
-package CPAN::SQLite::Search;
-use strict;
-use warnings;
-no warnings qw(redefine);
-use utf8;
-use CPAN::SQLite::Util qw($mode_info);
-use CPAN::SQLite::DBI::Search;
-
-our $max_results = 0;
-our $VERSION = '0.199';
-my $cdbi_query;
-
-my %mode2obj;
-$mode2obj{$_} = __PACKAGE__ . '::' . $_
- for (qw(dist author module));
-
-sub new {
- my ($class, %args) = @_;
- $cdbi_query = CPAN::SQLite::DBI::Search->new(%args);
- $max_results = $args{max_results} if $args{max_results};
- my $self = {results => undef, error => '', %args};
- bless $self, $class;
-}
-
-sub query {
- my ($self, %args) = @_;
- my $mode = $args{mode} || 'module';
- unless ($mode) {
- $self->{error} = q{Please specify a 'mode' argument};
- return;
- }
- my $info = $mode_info->{$mode};
- my $table = $info->{table};
- unless ($table) {
- $self->{error} = qq{No table exists for '$mode'};
- return;
- }
- my $cdbi = $cdbi_query->{objs}->{$table};
- my $class = 'CPAN::SQLite::DBI::Search::' . $table;
- unless ($cdbi and ref($cdbi) eq $class) {
- $self->{error} = qq{No cdbi object exists for '$table'};
- return;
- }
- my $obj;
- eval {$obj = $mode2obj{$mode}->make(table => $table, cdbi => $cdbi);};
- if ($@) {
- $self->{error} = qq{Mode '$mode' is not known};
- return;
- }
- my $value;
- my $search = {name => $info->{name},
- text => $info->{text},
- id => $info->{id},
- };
- TYPE: {
- ($value = $args{query}) and do {
- $search->{value} = $value;
- $search->{type} = 'query';
- $search->{wantarray} = 1;
- last TYPE;
- };
- ($value = $args{id}) and do {
- $search->{value} = $value;
- $search->{type} = 'id';
- $search->{distinct} = 1;
- last TYPE;
- };
- ($value = $args{name}) and do {
- $search->{value} = $value;
- $search->{type} = 'name';
- $search->{distinct} = 1;
- last TYPE;
- };
- $self->{error} = q{Cannot determine the type of search};
- return;
- }
-
- $obj->search(search => $search, meta_obj => $self->{meta_obj});
- $self->{results} = $obj->{results};
- if (my $error = $obj->{error}) {
- $self->{error} = $error;
- return;
- }
- return 1;
-}
-
-sub make {
- my ($class, %args) = @_;
- for (qw(table cdbi)) {
- die qq{Must supply an '$_' arg} unless defined $args{$_};
- }
- my $self = {results => undef, error => '',
- table => $args{table}, cdbi => $args{cdbi}};
- bless $self, $class;
-}
-
-package CPAN::SQLite::Search::author;
-use base qw(CPAN::SQLite::Search);
-
-sub search {
- my ($self, %args) = @_;
- return unless $args{search};
- my $cdbi = $self->{cdbi};
- my $meta_obj = $args{meta_obj};
- $args{fields} = [ qw(auth_id cpanid fullname email) ];
- $args{table} = 'auths';
- if ($max_results) {
- $args{limit} = $max_results;
- }
- $args{order_by} = 'cpanid';
- my $results;
- return unless $results = ($meta_obj ?
- $cdbi->fetch_and_set(%args) :
- $cdbi->fetch(%args));
- unless ($meta_obj) {
- $self->{results} =
- (ref($results) eq 'ARRAY' and scalar @$results == 1) ?
- $results->[0] : $results;
- }
- return 1 if $meta_obj;
-
-# The following will get all the dists associated with the cpanid
- $args{join} = undef;
- $args{table} = 'dists';
- $args{fields} = [ qw(dist_file dist_abs) ];
- $args{order_by} = 'dist_file';
- my @items = (ref($results) eq 'ARRAY') ? @$results : ($results);
- foreach my $item (@items) {
- my $search = {id => 'auth_id',
- value => $item->{auth_id},
- type => 'id',
- wantarray => 1,
- };
- my $dists;
- next unless ($dists = $cdbi->fetch(%args, search => $search));
- $item->{dists} = (ref($dists) eq 'ARRAY') ? $dists : [$dists];
- }
- $self->{results} =
- (ref($results) eq 'ARRAY' and scalar @$results == 1) ?
- $results->[0] : $results;
- return 1;
-}
-
-package CPAN::SQLite::Search::module;
-use base qw(CPAN::SQLite::Search);
-
-sub search {
- my ($self, %args) = @_;
- return unless $args{search};
- my $cdbi = $self->{cdbi};
- my $meta_obj = $args{meta_obj};
-
- $args{fields} = [ qw(mod_id mod_name mod_abs mod_vers chapterid
- dslip dist_id dist_name dist_file dist_vers dist_abs
- auth_id cpanid fullname email) ];
- $args{table} = 'dists';
- $args{join} = { mods => 'dist_id',
- auths => 'auth_id',
- };
- $args{order_by} = 'mod_name';
- if ($max_results) {
- $args{limit} = $max_results;
- }
- my $results;
- return unless $results = ($meta_obj ?
- $cdbi->fetch_and_set(%args, want_ids => 1) :
- $cdbi->fetch(%args));
-# if running under CPAN.pm, need to build a list of modules
-# contained in the distribution
- if ($meta_obj) {
- my %seen;
- $args{join} = undef;
- $args{table} = 'mods';
- my @items = (ref($results) eq 'ARRAY') ? @$results : ($results);
- foreach my $item(@items) {
- my $dist_id = $item->{dist_id};
- next if $seen{$dist_id};
- $args{fields} = [ qw(mod_name mod_abs) ];
- $args{order_by} = 'mod_name';
- $args{join} = undef;
- my $search = {id => 'dist_id',
- value => $item->{dist_id},
- type => 'id',
- wantarray => 1,
- };
- $seen{$dist_id}++;
- my $mods;
- next unless $mods = $cdbi->fetch_and_set(%args,
- search => $search,
- set_list => 1,
- download => $item->{download});
- }
- }
- unless ($meta_obj) {
- $self->{results} =
- (ref($results) eq 'ARRAY' and scalar @$results == 1) ?
- $results->[0] : $results;
- }
- return 1;
-}
-
-package CPAN::SQLite::Search::dist;
-use base qw(CPAN::SQLite::Search);
-
-sub search {
- my ($self, %args) = @_;
- return unless $args{search};
- my $cdbi = $self->{cdbi};
- my $meta_obj = $args{meta_obj};
-
- $args{fields} = [ qw(dist_id dist_name dist_abs dist_vers dist_dslip
- dist_file auth_id cpanid fullname email) ];
- $args{table} = 'dists';
- $args{join} = {auths => 'auth_id'};
- $args{order_by} = 'dist_name';
- if ($max_results) {
- $args{limit} = $max_results;
- }
- my $results;
- return unless $results = ($meta_obj ?
- $cdbi->fetch_and_set(%args, want_ids => 1) :
- $cdbi->fetch(%args));
-
- $args{join} = undef;
- $args{table} = 'mods';
- $args{fields} = [ qw(mod_name mod_abs) ];
- $args{order_by} = 'mod_name';
- my @items = (ref($results) eq 'ARRAY') ? @$results : ($results);
- foreach my $item(@items) {
- my $search = {id => 'dist_id',
- value => $item->{dist_id},
- type => 'id',
- wantarray => 1,
- };
- my $mods;
- next unless $mods = ($meta_obj ?
- $cdbi->fetch_and_set(%args,
- search => $search,
- set_list => 1,
- download => $item->{download}) :
- $cdbi->fetch(%args,
- search => $search) );
- next if $meta_obj;
- $item->{mods} = (ref($mods) eq 'ARRAY') ? $mods : [$mods];
- }
- unless ($meta_obj) {
- $self->{results} =
- (ref($results) eq 'ARRAY' and scalar @$results == 1) ?
- $results->[0] : $results;
- }
- return 1;
-}
-
-package CPAN::SQLite::Search;
-
-sub mod_subchapter {
- my ($self, $mod_name) = @_;
- (my $sc = $mod_name) =~ s{^([^:]+).*}{$1};
- return $sc;
-}
-
-sub dist_subchapter {
- my ($self, $dist_name) = @_;
- (my $sc = $dist_name) =~ s{^([^-]+).*}{$1};
- return $sc;
-}
-
-
-1;
-
-__END__
-
-=head1 NAME
-
-CPAN::SQLite::Search - perform queries on the database
-
-=head1 SYNOPSIS
-
- my $max_results = 200;
- my $query = CPAN::SQLite::Search->new(db_dir => $db_dir,
- db_name => $db_name,
- max_results => $max_results);
- $query->query(mode => 'module', name => 'Net::FTP');
- my $results = $query->{results};
-
-=head1 CONSTRUCTING THE QUERY
-
-This module queries the database via various types of queries
-and returns the results for subsequent display. The
-C<CPAN::SQLite::Search> object is created via the C<new> method as
-
- my $query = CPAN::SQLite::Search->new(db_dir => $db_dir,
- db_name => $db_name,
- max_results => $max_results);
-
-which takes as arguments
-
-=over 3
-
-=item * db_dir =E<gt> $db_dir
-
-This is the directory where the database file is stored. This is
-optional if the C<CPAN> option is given.
-
-=item * CPAN =E<gt> $CPAN
-
-This option specifies the C<cpan_home> directory of an
-already configured CPAN.pm, which is where the database
-file will be stored if C<db_dir> is not given.
-
-=item * max_results =E<gt> $max_results
-
-This is the maximum value used to limit the number of results
-returned under a user query. If not specified, a value contained
-within C<CPAN::SQLite::Search> will be used.
-
-=back
-
-A basic query then is constructed as
-
- $query->query(mode => $mode, $type => $value);
-
-with the results available as
-
- my $results = $query->{results}
-
-There are three basic modes:
-
-=over 3
-
-=item * module
-
-This is for information on modules.
-
-=item * dist
-
-This is for information on distributions.
-
-=item * author
-
-This is for information on CPAN authors or cpanids.
-
-=back
-
-=head2 C<module>, C<dist>, and C<author> modes
-
-For a mode of C<module>, C<dist>, and C<author>, there are
-four basic options to be used for the C<$type =E<gt> $value> option:
-
-=over 3
-
-=item * query =E<gt> $query_term
-
-This will search through module names,
-distribution names, or CPAN author names and ids
-(for C<module>, C<dist>, and C<author> modes
-respectively). The results are case insensitive,
-and Perl regular expressions for the C<$query_term>
-are recognized.
-
-=item * name =E<gt> $name
-
-This will report exact matches (in a case sensitive manner)
-for the module name, distribution name, or CPAN author id,
-for C<module>, C<dist>, and C<author> modes
-respectively.
-
-=item * id =E<gt> $id
-
-This will look up information on the primary key according
-to the mode specified. This is more for internal use,
-to help speed up queries; using this "publically" is
-probably not a good idea, as the ids may change over the
-course of time.
-
-=back
-
-=head1 RESULTS
-
-After making the query, the results can be accessed through
-
- my $results = $query->{results};
-
-No results either can mean no matches were found, or
-else an error in making the query resulted (in which case,
-a brief error message is contained in C<$query-E<gt>{error}>).
-Assuming there are results, what is returned depends on
-the mode and on the type of query. See L<CPAN::SQLite::Populate>
-for a description of the fields in the various tables
-listed below - these fields are used as the keys of the
-hash references that arise.
-
-=head2 C<author> mode
-
-=over 3
-
-=item * C<name> or C<id> query
-
-This returns the C<auth_id>, C<cpanid>, C<email>, and C<fullname>
-of the C<auths> table. As well, an array reference
-C<$results-E<gt>{dists}> is returned representing
-all distributions associated with that C<cpanid> - each
-member of the array reference is a hash reference
-describing the C<dist_id>, C<dist_name>,
-C<dist_abs>, C<dist_vers>, and C<dist_file> fields in the
-C<dists> table. An additional entry, C<download>, is
-supplied, which can be used as C<$CPAN/authors/id/$download>
-to specify the url of the distribution.
-
-=item * C<query> query
-
-If this results in more than one match, an array reference
-is returned, each member of which is a hash reference containg
-the C<auth_id>, C<cpanid>, and C<fullname> fields. If there
-is only one result found, a C<name> query based on the
-matched C<cpanid> is performed.
-
-=back
-
-=head2 C<module> mode
-
-=over 3
-
-=item * C<name> or C<id> query
-
-This returns the C<mod_id>, C<mod_name>, C<mod_abs>, C<mod_vers>,
-C<dslip>, C<chapterid>, C<dist_id>, C<dist_name>, C<dist_file>,
-C<auth_id>, C<cpanid>, C<fullname>, and C<email>
-of the C<auths>, C<mods>, and C<dists> tables.
-As well, the following entries may be present.
-
-=over 3
-
-=item * C<download>
-
-This can be used as C<$CPAN/authors/id/$download>
-to specify the url of the distribution.
-
-=item * C<dslip_info>
-
-If C<dslip> is available, an array reference C<dslip_info> is supplied,
-each entry being a hash reference. The hash reference contains
-two keys - C<desc>, whose value is a general description of the
-what the dslip entry represents, and C<what>, whose value is
-a description of the entry itself.
-
-=back
-
-=item * C<query> query
-
-If this results in more than one match, an array reference
-is returned, each member of which is a hash reference containing
-the C<mod_id>, C<mod_name>, C<mod_abs>, C<mod_abs>, C<dist_vers>, C<dist_abs>,
-C<auth_id>, C<cpanid>, C<dist_id>, C<dist_name>, and C<dist_file>.
-As well, a C<download> field which
-can be used as C<$CPAN/authors/id/$download>
-to specify the url of the distribution is provided. If there
-is only one result found, a C<name> query based on the
-matched C<mod_name> is performed.
-
-=back
-
-=head2 C<dist> mode
-
-=over 3
-
-=item * C<name> or C<id> query
-
-This returns the C<dist_id>, C<dist_name>, C<dist_abs>, C<dist_vers>,
-C<dist_file>, C<size>, C<birth>, C<auth_id>, C<cpanid>, and C<fullname>
-of the C<auths>, C<mods>, and C<dists> tables.
-As well, the following entries may be present.
-
-=over 3
-
-=item * C<download>
-
-This can be used as C<$CPAN/authors/id/$download>
-to specify the url of the distribution.
-
-=item * C<mods>
-
-This is an array reference containing information on the
-modules present. Each entry is a hash reference containing the
-C<mod_id>, C<mod_name>, C<mod_abs>, C<mod_vers>, and C<dslip>
-fields for the module.
-
-=item * C<dslip> and C<dslip_info>
-
-If the module name and distribution name are related by
-C<s/::/->, the C<dslip> and C<dslip_info> entries for
-that module are returned.
-
-=back
-
-=item * C<query> query
-
-If this results in more than one match, an array reference
-is returned, each member of which is a hash reference containing
-the C<dist_id>, C<dist_name>, C<dist_abs>, C<dist_file>,
-and C<cpanid> fields. As well, a C<download> field which
-can be used as C<$CPAN/authors/id/$download>
-to specify the url of the distribution is provided. If there
-is only one result found, a C<name> query based on the
-matched C<dist_name> is performed.
-
-=back
-
-=head1 SEE ALSO
-
-L<CPAN::SQLite::Populate>.
-
-=head1 COPYRIGHT
-
-This software is copyright 2006 by Randy Kobes
-E<lt>r.kobes@uwinnipeg.caE<gt>. Use and
-redistribution are under the same terms as Perl itself.
-
-=cut
-
diff --git a/Master/tlpkg/tlperl/lib/CPAN/SQLite/State.pm b/Master/tlpkg/tlperl/lib/CPAN/SQLite/State.pm
deleted file mode 100755
index 95ed50263eb..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/SQLite/State.pm
+++ /dev/null
@@ -1,410 +0,0 @@
-package CPAN::SQLite::State;
-use strict;
-use warnings;
-no warnings qw(redefine);
-use CPAN::SQLite::DBI qw($dbh);
-use CPAN::SQLite::DBI::Index;
-use CPAN::SQLite::Util qw(has_hash_data print_debug);
-our $VERSION = '0.199';
-
-my %tbl2obj;
-$tbl2obj{$_} = __PACKAGE__ . '::' . $_ for (qw(dists mods auths));
-my %obj2tbl = reverse %tbl2obj;
-
-our $dbh = $CPAN::SQLite::DBI::dbh;
-
-sub new {
- my ($class, %args) = @_;
-
- if ($args{setup}) {
- die "No state information available under setup";
- }
-
- my $index = $args{index};
- my @tables = qw(dists mods auths);
- foreach my $table (@tables) {
- my $obj = $index->{$table};
- die "Please supply a CPAN::SQLite::Index::$table object"
- unless ($obj and ref($obj) eq "CPAN::SQLite::Index::$table");
- }
- my $cdbi = CPAN::SQLite::DBI::Index->new(%args);
-
- my $self = {index => $index,
- obj => {},
- cdbi => $cdbi,
- reindex => $args{reindex},
- };
- bless $self, $class;
-}
-
-sub state {
- my $self = shift;
- unless ($self->create_objs()) {
- print_debug("Cannot create objects");
- return;
- }
- unless ($self->state_info()) {
- print_debug("Getting state information failed");
- return;
- };
- return 1;
-}
-
-sub create_objs {
- my $self = shift;
- my @tables = qw(dists auths mods);
-
- foreach my $table (@tables) {
- my $obj;
- my $pack = $tbl2obj{$table};
- my $index = $self->{index}->{$table};
- if ($index and ref($index) eq "CPAN::SQLite::Index::$table") {
- my $info = $index->{info};
- return unless has_hash_data($info);
- $obj = $pack->new(info => $info,
- cdbi => $self->{cdbi}->{objs}->{$table});
- }
- else {
- $obj = $pack->new();
- }
- $self->{obj}->{$table} = $obj;
- }
-
- foreach my $table (@tables) {
- my $obj = $self->{obj}->{$table};
- foreach (@tables) {
- next if ref($obj) eq $tbl2obj{$_};
- $obj->{obj}->{$_} = $self->{obj}->{$_};
- }
- }
- return 1;
-}
-
-sub state_info {
- my $self = shift;
- my @methods = qw(ids state);
- my @tables = qw(dists auths mods);
-
- for my $method (@methods) {
- for my $table (@tables) {
- my $obj = $self->{obj}->{$table};
- unless ($obj->$method()) {
- if (my $error = $obj->{error_msg}) {
- print_debug("Fatal error from ", ref($obj), ": ", $error, $/);
- return;
- }
- else {
- my $info = $obj->{info_msg};
- print_debug("Info from ", ref($obj), ": ", $info, $/);
- }
- }
- }
- }
- return 1;
-}
-
-package CPAN::SQLite::State::auths;
-use base qw(CPAN::SQLite::State);
-use CPAN::SQLite::Util qw(has_hash_data print_debug);
-
-sub new {
- my ($class, %args) = @_;
- my $info = $args{info};
- die "No author info available" unless has_hash_data($info);
- my $cdbi = $args{cdbi};
- die "No dbi object available"
- unless ($cdbi and ref($cdbi) eq 'CPAN::SQLite::DBI::Index::auths');
- my $self = {
- info => $info,
- insert => {},
- update => {},
- delete => {},
- ids => {},
- obj => {},
- cdbi => $cdbi,
- error_msg => '',
- info_msg => '',
- };
- bless $self, $class;
-}
-
-sub ids {
- my $self = shift;
- my $cdbi = $self->{cdbi};
- $self->{ids} = $cdbi->fetch_ids() or do {
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- return 1;
-}
-
-sub state {
- my $self = shift;
- my $auth_ids = $self->{ids};
- return unless my $dist_obj = $self->{obj}->{dists};
- my $dist_update = $dist_obj->{update};
- my $dist_insert = $dist_obj->{insert};
- my $dists = $dist_obj->{info};
- my ($update, $insert);
- if (has_hash_data($dist_insert)) {
- foreach my $distname (keys %{$dist_insert}) {
- my $cpanid = $dists->{$distname}->{cpanid};
- if (my $auth_id = $auth_ids->{$cpanid}) {
- $update->{$cpanid} = $auth_id;
- }
- else {
- $insert->{$cpanid}++;
- }
- }
- }
- if (has_hash_data($dist_update)) {
- foreach my $distname (keys %{$dist_update}) {
- my $cpanid = $dists->{$distname}->{cpanid};
- if (my $auth_id = $auth_ids->{$cpanid}) {
- $update->{$cpanid} = $auth_id;
- }
- else {
- $insert->{$cpanid}++;
- }
- }
- }
- $self->{update} = $update;
- $self->{insert} = $insert;
- return 1;
-}
-
-package CPAN::SQLite::State::dists;
-use base qw(CPAN::SQLite::State);
-use CPAN::SQLite::Util qw(vcmp has_hash_data print_debug);
-
-sub new {
- my ($class, %args) = @_;
- my $info = $args{info};
- die "No dist info available" unless has_hash_data($info);
- my $cdbi = $args{cdbi};
- die "No dbi object available"
- unless ($cdbi and ref($cdbi) eq 'CPAN::SQLite::DBI::Index::dists');
- my $self = {
- info => $info,
- insert => {},
- update => {},
- delete => {},
- ids => {},
- versions => {},
- obj => {},
- cdbi => $cdbi,
- error_msg => '',
- info_msg => '',
- reindex => undef,
- };
- bless $self, $class;
-}
-
-sub ids {
- my $self = shift;
- my $cdbi = $self->{cdbi};
- ($self->{ids}, $self->{versions}) = $cdbi->fetch_ids() or do {
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- return 1;
-}
-
-sub state {
- my $self = shift;
- my $dist_versions = $self->{versions};
- my $dists = $self->{info};
- my $dist_ids = $self->{ids};
- my ($insert, $update, $delete);
-
- my $reindex = $self->{reindex};
- if (defined $reindex) {
- my @dists = ref($reindex) eq 'ARRAY' ? @$reindex : ($reindex);
- foreach my $distname(@dists) {
- my $id = $dist_ids->{$distname};
- if (not defined $id) {
- print_debug(qq{"$distname" does not have an id: reindexing ignored\n});
- next;
- }
- $update->{$distname} = $id;
- }
- $self->{update} = $update;
- return 1;
- }
-
- foreach my $distname (keys %$dists) {
- if (not defined $dist_versions->{$distname}) {
- $insert->{$distname}++;
- }
- elsif (vcmp($dists->{$distname}->{dist_vers},
- $dist_versions->{$distname}) > 0) {
- $update->{$distname} = $dist_ids->{$distname};
- }
- }
- $self->{update} = $update;
- $self->{insert} = $insert;
- foreach my $distname(keys %$dist_versions) {
- next if $dists->{$distname};
- $delete->{$distname} = $dist_ids->{$distname};
- print_debug("Will delete $distname\n");
- }
- $self->{delete} = $delete;
- return 1;
-}
-
-package CPAN::SQLite::State::mods;
-use base qw(CPAN::SQLite::State);
-use CPAN::SQLite::Util qw(has_hash_data print_debug);
-
-sub new {
- my ($class, %args) = @_;
- my $info = $args{info};
- die "No module info available" unless has_hash_data($info);
- my $cdbi = $args{cdbi};
- die "No dbi object available"
- unless ($cdbi and ref($cdbi) eq 'CPAN::SQLite::DBI::Index::mods');
- my $self = {
- info => $info,
- insert => {},
- update => {},
- delete => {},
- ids => {},
- obj => {},
- cdbi => $cdbi,
- error_msg => '',
- info_msg => '',
- };
- bless $self, $class;
-}
-
-sub ids {
- my $self = shift;
- my $cdbi = $self->{cdbi};
- $self->{ids} = $cdbi->fetch_ids() or do {
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- return 1;
-}
-
-sub state {
- my $self = shift;
- my $mods = $self->{info};
- my $mod_ids = $self->{ids};
- return unless my $dist_obj = $self->{obj}->{dists};
- my $dists = $dist_obj->{info};
- my $dist_update = $dist_obj->{update};
- my $dist_insert = $dist_obj->{insert};
- my ($update, $insert, $delete);
- my $cdbi = $self->{cdbi};
- if (has_hash_data($dist_insert)) {
- foreach my $distname (keys %{$dist_insert}) {
- foreach my $module(keys %{$dists->{$distname}->{modules}}) {
- $insert->{$module}++;
- }
- }
- }
- if (has_hash_data($dist_update)) {
- foreach my $distname (keys %{$dist_update}) {
- foreach my $module(keys %{$dists->{$distname}->{modules}}) {
- my $mod_id = $mod_ids->{$module};
- if ($mod_id) {
- $update->{$module} = $mod_id;
- }
- else {
- $insert->{$module}++;
- }
- }
- }
- }
-
- if (has_hash_data($dist_update)) {
- my $sql = q{SELECT mod_id,mod_name from mods,dists WHERE dists.dist_id = mods.dist_id and dists.dist_id = ?};
- my $sth = $dbh->prepare($sql) or do {
- $cdbi->db_error();
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- my $dist_ids = $dist_obj->{ids};
- foreach my $distname (keys %{$dist_update}) {
- my %mods = ();
- %mods = map {$_ => 1} keys %{$dists->{$distname}->{modules}};
- $sth->execute($dist_ids->{$distname}) or do {
- $cdbi->db_error($sth);
- $self->{error_msg} = $cdbi->{error_msg};
- return;
- };
- while (my($mod_id, $mod_name) = $sth->fetchrow_array) {
- next if $mods{$mod_name};
- $delete->{$mod_name} = $mod_id;
- }
- }
- $sth->finish;
- undef $sth;
- }
-
- $self->{update} = $update;
- $self->{insert} = $insert;
- $self->{delete} = $delete;
- return 1;
-}
-
-
-package CPAN::SQLite::State;
-
-1;
-
-__END__
-
-=head1 NAME
-
-CPAN::SQLite::State - get state information on the database
-
-=head1 DESCRIPTION
-
-This module gets information on the current state of the
-database and compares it to that obtained from the CPAN
-index files from I<CPAN::SQLite::Info> and from the
-repositories from I<CPAN::SQLite::PPM>. For each of the
-four tables I<dists>, I<mods>, I<auths>, and I<ppms>,
-two methods are used to get this information:
-
-=over 3
-
-=item * C<ids>
-
-This method gets the ids of the relevant names, and
-versions, if applicable, in the table.
-
-=item * C<state>
-
-This method compares the information in the tables
-obtained from the C<ids> method to that from the
-CPAN indices and ppm repositories. One of three actions
-is then decided, which is subsequently acted upon in
-I<CPAN::SQLite::Populate>.
-
-=over 3
-
-=item * C<insert>
-
-If the information in the indices is not in the
-database, this information is marked for insertion.
-
-=item * C<update>
-
-If the information in the database is older than that
-form the indices (generally, this means an older version),
-the information is marked for updating.
-
-=item * C<delete>
-
-If the information in the database is no longer present
-in the indices, the information is marked for deletion.
-
-=back
-
-=back
-
-=cut
-
diff --git a/Master/tlpkg/tlperl/lib/CPAN/SQLite/Util.pm b/Master/tlpkg/tlperl/lib/CPAN/SQLite/Util.pm
deleted file mode 100755
index 7f3ffcf8117..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/SQLite/Util.pm
+++ /dev/null
@@ -1,367 +0,0 @@
-package CPAN::SQLite::Util;
-use strict;
-use warnings;
-our $VERSION = '0.199';
-
-use base qw(Exporter);
-our (@EXPORT_OK, %chaps, %modes,
- $table_id, $query_info, $mode_info, $full_id, $dslip);
-@EXPORT_OK = qw(%chaps $repositories %modes
- vcmp $table_id $query_info $mode_info $full_id
- has_hash_data has_array_data $dslip
- expand_dslip download chap_desc print_debug);
-
-make_ids();
-
-$mode_info = {
- module => {id => 'mod_id',
- table => 'mods',
- name => 'mod_name',
- text => 'mod_abs',
- },
- dist => {id => 'dist_id',
- table => 'dists',
- name => 'dist_name',
- text => 'dist_abs',
- },
- author => {id => 'auth_id',
- table => 'auths',
- name => 'cpanid',
- text => 'fullname',
- },
- chapter => {id => 'chapterid',
- table => 'chaps',
- name => 'subchapter',
- text => 'subchapter',
- },
- };
-
-%modes = map {$_ => 1} keys %$mode_info;
-
-$query_info = { module => {mode => 'module', type => 'name'},
- mod_id => {mode => 'module', type => 'id'},
- dist => {mode => 'dist', type => 'name'},
- dist_id => {mode => 'dist', type => 'id'},
- cpanid => {mode => 'author', type => 'name'},
- author => {mode => 'author', type => 'name'},
- auth_id => {mode => 'author', type => 'id'},
- };
-
-%chaps = (
- 2 => 'Perl Core Modules',
- 3 => 'Development Support',
- 4 => 'Operating System Interfaces',
- 5 => 'Networking Devices IPC',
- 6 => 'Data Type Utilities',
- 7 => 'Database Interfaces',
- 8 => 'User Interfaces',
- 9 => 'Language Interfaces',
- 10 => 'File Names Systems Locking',
- 11 => 'String Lang Text Proc',
- 12 => 'Opt Arg Param Proc',
- 13 => 'Internationalization Locale',
- 14 => 'Security and Encryption',
- 15 => 'World Wide Web HTML HTTP CGI',
- 16 => 'Server and Daemon Utilities',
- 17 => 'Archiving and Compression',
- 18 => 'Images Pixmaps Bitmaps',
- 19 => 'Mail and Usenet News',
- 20 => 'Control Flow Utilities',
- 21 => 'File Handle Input Output',
- 22 => 'Microsoft Windows Modules',
- 23 => 'Miscellaneous Modules',
- 24 => 'Commercial Software Interfaces',
- 26 => 'Documentation',
- 27 => 'Pragma',
- 28 => 'Perl6',
- 99 => 'Not In Modulelist',
- );
-
-$dslip = {
- d => {
- M => q{Mature (no rigorous definition)},
- R => q{Released},
- S => q{Standard, supplied with Perl 5},
- a => q{Alpha testing},
- b => q{Beta testing},
- c => q{Under construction but pre-alpha (not yet released)},
- desc => q{Development Stage (Note: *NO IMPLIED TIMESCALES*)},
- i => q{Idea, listed to gain consensus or as a placeholder},
- },
- s => {
- a => q{Abandoned, the module has been abandoned by its author},
- d => q{Developer},
- desc => q{Support Level},
- m => q{Mailing-list},
- n => q{None known, try comp.lang.perl.modules},
- u => q{Usenet newsgroup comp.lang.perl.modules},
- },
- l => {
- '+' => q{C++ and perl, a C++ compiler will be needed},
- c => q{C and perl, a C compiler will be needed},
- desc => q{Language Used},
- h => q{Hybrid, written in perl with optional C code, no compiler needed},
- o => q{perl and another language other than C or C++},
- p => q{Perl-only, no compiler needed, should be platform independent},
- },
- i => {
- O => q{Object oriented using blessed references and/or inheritance},
- desc => q{Interface Style},
- f => q{plain Functions, no references used},
- h => q{hybrid, object and function interfaces available},
- n => q{no interface at all (huh?)},
- r => q{some use of unblessed References or ties},
- },
- p => {
- a => q{Artistic license alone},
- b => q{BSD: The BSD License},
- desc => q{Public License},
- g => q{GPL: GNU General Public License},
- l => q{LGPL: "GNU Lesser General Public License" (previously known as "GNU Library General Public License")},
- o => q{other (but distribution allowed without restrictions)},
- p => q{Standard-Perl: user may choose between GPL and Artistic},
- },
-};
-
-
-sub make_ids {
- my @tables = qw(mods dists auths);
- foreach my $table (@tables) {
- (my $id = $table) =~ s!(\w+)s$!$1_id!;
- $table_id->{$table} = $id;
- $full_id->{$id} = $table . '.' . $id;
- }
-# $full_id->{chapterid} = 'chaps.chapterid';
-}
-
-#my $num_re = qr{^0*\.\d+$};
-#sub vcmp {
-# my ($v1, $v2) = @_;
-# return unless (defined $v1 and defined $v2);
-# if ($v1 =~ /$num_re/ and $v2 =~ /$num_re/) {
-# return $v1 <=> $v2;
-# }
-# return Sort::Versions::versioncmp($v1, $v2);
-#}
-
-sub has_hash_data {
- my $data = shift;
- return unless (defined $data and ref($data) eq 'HASH');
- return (scalar keys %$data > 0) ? 1 : 0;
-}
-
-sub has_array_data {
- my $data = shift;
- return unless (defined $data and ref($data) eq 'ARRAY');
- return (scalar @$data > 0) ? 1 : 0;
-}
-
-sub expand_dslip {
- my ($string) = @_;
- my $entries = [];
- my @info = split '', $string;
- my @given = qw(d s l i p);
- for (0 .. 4) {
- my $entry;
- my $given = $given[$_];
- my $info = $info[$_];
- $entry->{desc} = $dslip->{$given}->{desc};
- $entry->{what} = (not $info or $info eq '?') ?
- 'not specified' : $dslip->{$given}->{$info};
- push @$entries, $entry;
- }
- return $entries;
-}
-
-sub download {
- my ($cpanid, $dist_file) = @_;
- return unless ($cpanid and $dist_file);
- (my $fullid = $cpanid) =~ s!^(\w)(\w)(.*)!$1/$1$2/$1$2$3!;
- my $download = $fullid . '/' . $dist_file;
- return $download;
-}
-
-sub chap_desc {
- my ($id) = @_;
- return $chaps{$id};
-}
-
-sub print_debug {
- return unless $ENV{CPAN_SQLITE_DEBUG};
- print @_;
-}
-
-sub vcmp {
- my ($v1, $v2) = @_;
- return CPAN::SQLite::Version->vcmp($v1, $v2);
-}
-
-
-# This is borrowed essentially verbatim from CPAN::Version
-# It's included here so as to not demand a CPAN.pm upgrade
-
-package CPAN::SQLite::Version;
-
-use strict;
-our $VERSION = 0.1;
-no warnings;
-
-# CPAN::Version::vcmp courtesy Jost Krieger
-sub vcmp {
- my ($self, $l, $r) = @_;
-
- return 0 if $l eq $r; # short circuit for quicker success
-
- for ($l, $r) {
- next unless tr/.// > 1;
- s/^v?/v/;
- 1 while s/\.0+(\d)/.$1/;
- }
- if ($l =~ /^v/ <=> $r =~ /^v/) {
- for ($l, $r) {
- next if /^v/;
- $_ = $self->float2vv($_);
- }
- }
-
- return (
- ($l ne "undef") <=> ($r ne "undef") ||
- (
- $] >= 5.006 &&
- $l =~ /^v/ &&
- $r =~ /^v/ &&
- $self->vstring($l) cmp $self->vstring($r)
- ) ||
- $l <=> $r ||
- $l cmp $r
- );
-}
-
-sub vgt {
- my ($self, $l, $r) = @_;
- $self->vcmp($l, $r) > 0;
-}
-
-sub vlt {
- my ($self, $l, $r) = @_;
- 0 + ($self->vcmp($l, $r) < 0);
-}
-
-sub vstring {
- my ($self, $n) = @_;
- $n =~ s/^v//
- or die "CPAN::Search::Lite::Version::vstring() called with invalid arg [$n]";
- {
- no warnings;
- 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;
-}
-
-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"
-
- warn("Suspicious version string seen [$n]\n");
- return $n;
- }
- my $better = sprintf "v%vd", $n;
- return $better;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-CPAN::SQLite::Util - export some common data structures used by CPAN::SQLite::*
-
-=head1 DESCRIPTION
-
-This module exports some common data structures used by other
-I<CPAN::Search::Lite::*> modules. At present these are
-
-=over 3
-
-=item * C<%chaps>
-
-This is hash whose keys are the CPAN chapter ids with associated
-values being the corresponding chapter descriptions.
-
-=item * C<$dslip>
-
-This contains a description of the meaning of the
-various C<dslip> codes.
-
-=item * C<$table_id>
-
-This is a hash reference whose keys are the tables used
-and whose values are the associated primary keys.
-
-=item * C<$full_id>
-
-This is a hash reference whose keys are the primary keys
-of the tables and whose values are the associated fully qualified
-primary keys (ie, with the table name prepended).
-
-=item * C<$mode_info>
-
-This is a hash reference whose keys are the allowed
-modes of I<CPAN::Search::Lite::Query> and whose associated values
-are hash references with keys C<id>, C<name>, and C<text> describing
-what columns to use for that key.
-
-=item * C<$query_info>
-
-This is a hash reference whose purpose is to provide
-shortcuts to making queries using I<CPAN::Search::Lite::Query>. The
-keys of this reference is the shortcut name, and the associated
-value is a hash reference specifying the required I<mode> and
-I<type> keys.
-
-=item * C<vcmp>
-
-This routine, used as
-
- if (vcmp($v1, $v2) > 0) {
- print "$v1 is higher than $v2\n";
- }
-
-is used to compare two versions, and returns 1/0/-1 if
-the first argument is considered higher/equal/lower than
-the second. It uses C<Sort::Versions>.
-
-=back
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Shell.pm b/Master/tlpkg/tlperl/lib/CPAN/Shell.pm
deleted file mode 100755
index 8fb5628b112..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Shell.pm
+++ /dev/null
@@ -1,1974 +0,0 @@
-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.5";
-# 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
- r WORDs or /REGEXP/ or NONE report updates for some/matching/all modules
- 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 (upto 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/';
- my($k,$v);
- $CPAN::Frontend->myprint("\$CPAN::Config options from ");
- my @from;
- if (exists $INC{'CPAN/Config.pm'}) {
- push @from, $INC{'CPAN/Config.pm'};
- }
- if (exists $INC{'CPAN/MyConfig.pm'}) {
- push @from, $INC{'CPAN/MyConfig.pm'};
- }
- $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
- $CPAN::Frontend->myprint(":\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 (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 (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 thingie 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: $!");
- local($/);
- local $^W = 1;
- my $content = <$fh>;
- CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
- if $CPAN::DEBUG;
- 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, $cpanpm, %args) = @_;
- require CPAN::FirstTime;
- my $home = CPAN::HandleConfig::home();
- $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
- File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
- File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
- CPAN::HandleConfig::require_myconfig_or_config();
- $CPAN::Config ||= {};
- $CPAN::Config = {
- %$CPAN::Config,
- build_dir => undef,
- cpan_home => undef,
- keep_source_where => undef,
- histfile => undef,
- };
- CPAN::FirstTime::init($cpanpm, %args);
-}
-
-#-> 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 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 ($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;
- DIST: for my $d ($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|^./../||;
- #$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,
- ] :
- [
- 1,
- $id,
- $failed,
- $d->{$failed},
- 0,
- ]
- );
- }
- 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");
- }
-}
-
-# 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");
-}
-
-#-> 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 && !$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 ) {
- 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 bugreport
- $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',
- );
-}
-
-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');
-}
-
-# 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 {
- 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("Going to test 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");
- 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 || "";
- $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} ||= "";
- {
- # 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]");
- } elsif ($obj->$meth()) {
- CPAN::Queue->delete($s);
- CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG;
- } else {
- CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG;
- }
-
- $obj->undelay;
- for my $pragma (@pragma) {
- my $unpragma = "un$pragma";
- if ($obj->can($unpragma)) {
- $obj->$unpragma();
- }
- }
- if ($CPAN::Config->{halt_on_failure}
- &&
- CPAN::Distrostatus::something_has_just_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("Going to fetch '$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 "Going to download and test '$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/Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm b/Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm
deleted file mode 100755
index b97bd200164..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Tarzip.pm
+++ /dev/null
@@ -1,442 +0,0 @@
-# -*- 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.501";
-# 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' 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");
- $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");
- $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 -dc "$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 -dc $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 ($exttar && $extgzip && $file =~ /\.(?:bz2|tbz)$/i) {
- # until Archive::Tar handles bzip2
- $prefer = 1;
- } elsif (
- $CPAN::META->has_usable("Archive::Tar")
- &&
- $CPAN::META->has_inst("Compress::Zlib") ) {
- $prefer = 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 -dc }.
- 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});
- if (system($system)==0) {
- $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
- } else {
- $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
- }
- 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;
- } else {
- my $unzip = $CPAN::Config->{unzip} or
- $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
- my @system = ($unzip, $file);
- return system(@system) == 0;
- }
-}
-
-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
diff --git a/Master/tlpkg/tlperl/lib/CPAN/URL.pm b/Master/tlpkg/tlperl/lib/CPAN/URL.pm
deleted file mode 100755
index 52b42eec88e..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/URL.pm
+++ /dev/null
@@ -1,31 +0,0 @@
-# -*- 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/Master/tlpkg/tlperl/lib/CPAN/Version.pm b/Master/tlpkg/tlperl/lib/CPAN/Version.pm
deleted file mode 100755
index da876aac2d7..00000000000
--- a/Master/tlpkg/tlperl/lib/CPAN/Version.pm
+++ /dev/null
@@ -1,173 +0,0 @@
-package CPAN::Version;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = "5.5";
-
-# CPAN::Version::vcmp courtesy Jost Krieger
-sub vcmp {
- my($self,$l,$r) = @_;
- local($^W) = 0;
- CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
-
- 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) = @_;
- 0 + ($self->vcmp($l,$r) < 0);
-}
-
-sub vge {
- my($self,$l,$r) = @_;
- $self->vcmp($l,$r) >= 0;
-}
-
-sub vle {
- my($self,$l,$r) = @_;
- 0 + ($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: