diff options
author | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
---|---|---|
committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
commit | 316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch) | |
tree | cb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl/lib/CPAN | |
parent | cd0f87b5d39480d85ad9bd4ee37f520f75bed560 (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')
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: |