GSP/GSP-Agent-Windows
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Initial Windows agent repository

Browse source
This commit is contained in:
Frank Harris 2026-06-08 10:45:20 -05:00
commit a0db0c2e5b
10589 changed files with 3844063 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

44
OGP64/usr/share/perl5/5.40/CPAN/API/HOWTO.pod Normal file
View file

@ -0,0 +1,44 @@
=head1 NAME
CPAN::API::HOWTO - a recipe book for programming with CPAN.pm
=head1 RECIPES
All of these recipes assume that you have put "use CPAN" at the top of
your program.
=head2 What distribution contains a particular module?
my $distribution = CPAN::Shell->expand(
"Module", "Data::UUID"
)->distribution()->pretty_id();
This returns a string of the form "AUTHORID/TARBALL". If you want the
full path and filename to this distribution on a CPAN mirror, then it is
C<.../authors/id/A/AU/AUTHORID/TARBALL>.
=head2 What modules does a particular distribution contain?
CPAN::Index->reload();
my @modules = CPAN::Shell->expand(
"Distribution", "JHI/Graph-0.83.tar.gz"
)->containsmods();
You may also refer to a distribution in the form A/AU/AUTHORID/TARBALL.
=head1 SEE ALSO
the main CPAN.pm documentation
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<http://www.perl.com/perl/misc/Artistic.html>
=head1 AUTHOR
David Cantrell
=cut

236
OGP64/usr/share/perl5/5.40/CPAN/Author.pm Normal file
View file

@ -0,0 +1,236 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Author;
use strict;
use CPAN::InfoObj;
@CPAN::Author::ISA = qw(CPAN::InfoObj);
use vars qw(
$VERSION
);
$VERSION = "5.5002";
package CPAN::Author;
use strict;
#-> sub CPAN::Author::force
sub force {
my $self = shift;
$self->{force}++;
}
#-> sub CPAN::Author::force
sub unforce {
my $self = shift;
delete $self->{force};
}
#-> sub CPAN::Author::id
sub id {
my $self = shift;
my $id = $self->{ID};
$CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
$id;
}
#-> sub CPAN::Author::as_glimpse ;
sub as_glimpse {
my($self) = @_;
my(@m);
my $class = ref($self);
$class =~ s/^CPAN:://;
push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
$class,
$self->{ID},
$self->fullname,
$self->email);
join "", @m;
}
#-> sub CPAN::Author::fullname ;
sub fullname {
shift->ro->{FULLNAME};
}
*name = \&fullname;
#-> sub CPAN::Author::email ;
sub email { shift->ro->{EMAIL}; }
#-> sub CPAN::Author::ls ;
sub ls {
my $self = shift;
my $glob = shift || "";
my $silent = shift || 0;
my $id = $self->id;
# adapted from CPAN::Distribution::verifyCHECKSUM ;
my(@csf); # chksumfile
@csf = $self->id =~ /(.)(.)(.*)/;
$csf[1] = join "", @csf[0,1];
$csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
my(@dl);
@dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
unless (grep {$_->[2] eq $csf[1]} @dl) {
$CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
return;
}
@dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
unless (grep {$_->[2] eq $csf[2]} @dl) {
$CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
return;
}
@dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
if ($glob) {
if ($CPAN::META->has_inst("Text::Glob")) {
$glob =~ s|/$|/*|;
my $rglob = Text::Glob::glob_to_regex($glob);
CPAN->debug("glob[$glob]rglob[$rglob]dl[@dl]") if $CPAN::DEBUG;
my @tmpdl = grep { $_->[2] =~ /$rglob/ } @dl;
if (1==@tmpdl && $tmpdl[0][0]==0) {
$rglob = Text::Glob::glob_to_regex("$glob/*");
@dl = grep { $_->[2] =~ /$rglob/ } @dl;
} else {
@dl = @tmpdl;
}
CPAN->debug("rglob[$rglob]dl[@dl]") if $CPAN::DEBUG;
} else {
$CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
}
}
unless ($silent >= 2) {
$CPAN::Frontend->myprint
(
join "",
map {
sprintf
(
"%8d %10s %s/%s%s\n",
$_->[0],
$_->[1],
$id,
$_->[2],
0==$_->[0]?"/":"",
)
} sort { $a->[2] cmp $b->[2] } @dl
);
}
@dl;
}
# returns an array of arrays, the latter contain (size,mtime,filename)
#-> sub CPAN::Author::dir_listing ;
sub dir_listing {
my $self = shift;
my $chksumfile = shift;
my $recursive = shift;
my $may_ftp = shift;
my $lc_want =
File::Spec->catfile($CPAN::Config->{keep_source_where},
"authors", "id", @$chksumfile);
my $fh;
CPAN->debug("chksumfile[@$chksumfile]recursive[$recursive]may_ftp[$may_ftp]") if $CPAN::DEBUG;
# Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
# hazard. (Without GPG installed they are not that much better,
# though.)
$fh = FileHandle->new;
if (open($fh, $lc_want)) {
my $line = <$fh>; close $fh;
unlink($lc_want) unless $line =~ /PGP/;
}
local($") = "/";
# connect "force" argument with "index_expire".
my $force = $self->{force};
if (my @stat = stat $lc_want) {
$force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
}
my $lc_file;
if ($may_ftp) {
$lc_file = eval {
CPAN::FTP->localize
(
"authors/id/@$chksumfile",
$lc_want,
$force,
);
};
unless ($lc_file) {
$CPAN::Frontend->myprint("Trying $lc_want.gz\n");
$chksumfile->[-1] .= ".gz";
$lc_file = eval {
CPAN::FTP->localize
("authors/id/@$chksumfile",
"$lc_want.gz",
1,
);
};
if ($lc_file) {
$lc_file =~ s{\.gz(?!\n)\Z}{}; #};
eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
} else {
return;
}
}
} else {
$lc_file = $lc_want;
# we *could* second-guess and if the user has a file: URL,
# then we could look there. But on the other hand, if they do
# have a file: URL, why did they choose to set
# $CPAN::Config->{show_upload_date} to false?
}
# adapted from CPAN::Distribution::CHECKSUM_check_file ;
$fh = FileHandle->new;
my($cksum);
if (open $fh, $lc_file) {
local($/);
my $eval = <$fh>;
$eval =~ s/\015?\012/\n/g;
close $fh;
my($compmt) = Safe->new();
$cksum = $compmt->reval($eval);
if ($@) {
rename $lc_file, "$lc_file.bad";
Carp::confess($@) if $@;
}
} elsif ($may_ftp) {
Carp::carp ("Could not open '$lc_file' for reading.");
} else {
# Maybe should warn: "You may want to set show_upload_date to a true value"
return;
}
my(@result,$f);
for $f (sort keys %$cksum) {
if (exists $cksum->{$f}{isdir}) {
if ($recursive) {
my(@dir) = @$chksumfile;
pop @dir;
push @dir, $f, "CHECKSUMS";
push @result, [ 0, "-", $f ];
push @result, map {
[$_->[0], $_->[1], "$f/$_->[2]"]
} $self->dir_listing(\@dir,1,$may_ftp);
} else {
push @result, [ 0, "-", $f ];
}
} else {
push @result, [
($cksum->{$f}{"size"}||0),
$cksum->{$f}{"mtime"}||"---",
$f
];
}
}
@result;
}
#-> sub CPAN::Author::reports
sub reports {
$CPAN::Frontend->mywarn("reports on authors not implemented.
Please file a bugreport if you need this.\n");
}
1;

306
OGP64/usr/share/perl5/5.40/CPAN/Bundle.pm Normal file
View file

@ -0,0 +1,306 @@
# -*- 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.5005";
sub look {
my $self = shift;
$CPAN::Frontend->myprint($self->as_string);
}
#-> CPAN::Bundle::undelay
sub undelay {
my $self = shift;
delete $self->{later};
for my $c ( $self->contains ) {
my $obj = CPAN::Shell->expandany($c) or next;
if ($obj->id eq $self->id){
my $id = $obj->id;
$CPAN::Frontend->mywarn("$id seems to contain itself, skipping\n");
next;
}
$obj->undelay;
}
}
# mark as dirty/clean
#-> sub CPAN::Bundle::color_cmd_tmps ;
sub color_cmd_tmps {
my($self) = shift;
my($depth) = shift || 0;
my($color) = shift || 0;
my($ancestors) = shift || [];
# a module needs to recurse to its cpan_file, a distribution needs
# to recurse into its prereq_pms, a bundle needs to recurse into its modules
return if exists $self->{incommandcolor}
&& $color==1
&& $self->{incommandcolor}==$color;
if ($depth>=$CPAN::MAX_RECURSION) {
my $e = CPAN::Exception::RecursiveDependency->new($ancestors);
if ($e->is_resolvable) {
return $self->{incommandcolor}=2;
} else {
die $e;
}
}
# warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
for my $c ( $self->contains ) {
my $obj = CPAN::Shell->expandany($c) or next;
CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
$obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
}
# never reached code?
#if ($color==0) {
#delete $self->{badtestcnt};
#}
$self->{incommandcolor} = $color;
}
#-> sub CPAN::Bundle::as_string ;
sub as_string {
my($self) = @_;
$self->contains;
# following line must be "=", not "||=" because we have a moving target
$self->{INST_VERSION} = $self->inst_version;
return $self->SUPER::as_string;
}
#-> sub CPAN::Bundle::contains ;
sub contains {
my($self) = @_;
my($inst_file) = $self->inst_file || "";
my($id) = $self->id;
$self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
undef $inst_file;
}
unless ($inst_file) {
# Try to get at it in the cpan directory
$self->debug("no inst_file") if $CPAN::DEBUG;
my $cpan_file;
$CPAN::Frontend->mydie("I don't know a bundle with ID '$id'\n") unless
$cpan_file = $self->cpan_file;
if ($cpan_file eq "N/A") {
$CPAN::Frontend->mywarn("Bundle '$id' not found on disk and not on CPAN. Maybe stale symlink? Maybe removed during session?\n");
return;
}
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);
my $build_dir;
unless ($build_dir = $dist->{build_dir}) {
$CPAN::Frontend->mywarn("Warning: cannot determine bundle content without a build_dir.\n");
return;
}
$from = $self->find_bundle_file($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->{viabundle} ||= { id => $id, reqtype => $self->{reqtype}, optional => !$self->{mandatory}};
# $obj->$meth();
# XXX should optional be based on whether bundle was optional? -- xdg, 2012-04-01
# A: Sure, what could demand otherwise? --andk, 2013-11-25
CPAN::Queue->queue_item(qmod => $obj->id, reqtype => $self->{reqtype}, optional => !$self->{mandatory});
}
}
# If a bundle contains another that contains an xs_file we have here,
# we just don't bother I suppose
#-> sub CPAN::Bundle::xs_file
sub xs_file {
return 0;
}
#-> sub CPAN::Bundle::force ;
sub fforce { shift->rematein('fforce',@_); }
#-> sub CPAN::Bundle::force ;
sub force { shift->rematein('force',@_); }
#-> sub CPAN::Bundle::notest ;
sub notest { shift->rematein('notest',@_); }
#-> sub CPAN::Bundle::get ;
sub get { shift->rematein('get',@_); }
#-> sub CPAN::Bundle::make ;
sub make { shift->rematein('make',@_); }
#-> sub CPAN::Bundle::test ;
sub test {
my $self = shift;
# $self->{badtestcnt} ||= 0;
$self->rematein('test',@_);
}
#-> sub CPAN::Bundle::install ;
sub install {
my $self = shift;
$self->rematein('install',@_);
}
#-> sub CPAN::Bundle::clean ;
sub clean { shift->rematein('clean',@_); }
#-> sub CPAN::Bundle::uptodate ;
sub uptodate {
my($self) = @_;
return 0 unless $self->SUPER::uptodate; # we must have the current Bundle def
my $c;
foreach $c ($self->contains) {
my $obj = CPAN::Shell->expandany($c);
return 0 unless $obj->uptodate;
}
return 1;
}
#-> sub CPAN::Bundle::readme ;
sub readme {
my($self) = @_;
my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
No File found for bundle } . $self->id . qq{\n}), return;
$self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
$CPAN::META->instance('CPAN::Distribution',$file)->readme;
}
1;

249
OGP64/usr/share/perl5/5.40/CPAN/CacheMgr.pm Normal file
View file

@ -0,0 +1,249 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::CacheMgr;
use strict;
use CPAN::InfoObj;
@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
use Cwd qw(chdir);
use File::Find;
use vars qw(
$VERSION
);
$VERSION = "5.5002";
package CPAN::CacheMgr;
use strict;
#-> sub CPAN::CacheMgr::as_string ;
sub as_string {
eval { require Data::Dumper };
if ($@) {
return shift->SUPER::as_string;
} else {
return Data::Dumper::Dumper(shift);
}
}
#-> sub CPAN::CacheMgr::cachesize ;
sub cachesize {
shift->{DU};
}
#-> sub CPAN::CacheMgr::tidyup ;
sub tidyup {
my($self) = @_;
return unless $CPAN::META->{LOCK};
return unless -d $self->{ID};
my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}};
for my $current (0..$#toremove) {
my $toremove = $toremove[$current];
$CPAN::Frontend->myprint(sprintf(
"DEL(%d/%d): %s \n",
$current+1,
scalar @toremove,
$toremove,
)
);
return if $CPAN::Signal;
$self->_clean_cache($toremove);
return if $CPAN::Signal;
}
$self->{FIFO} = [];
}
#-> sub CPAN::CacheMgr::dir ;
sub dir {
shift->{ID};
}
#-> sub CPAN::CacheMgr::entries ;
sub entries {
my($self,$dir) = @_;
return unless defined $dir;
$self->debug("reading dir[$dir]") if $CPAN::DEBUG;
$dir ||= $self->{ID};
my($cwd) = CPAN::anycwd();
chdir $dir or Carp::croak("Can't chdir to $dir: $!");
my $dh = DirHandle->new(File::Spec->curdir)
or Carp::croak("Couldn't opendir $dir: $!");
my(@entries);
for ($dh->read) {
next if $_ eq "." || $_ eq "..";
if (-f $_) {
push @entries, File::Spec->catfile($dir,$_);
} elsif (-d _) {
push @entries, File::Spec->catdir($dir,$_);
} else {
$CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
}
}
chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
sort { -M $a <=> -M $b} @entries;
}
#-> sub CPAN::CacheMgr::disk_usage ;
sub disk_usage {
my($self,$dir,$fast) = @_;
return if exists $self->{SIZE}{$dir};
return if $CPAN::Signal;
my($Du) = 0;
if (-e $dir) {
if (-d $dir) {
unless (-x $dir) {
unless (chmod 0755, $dir) {
$CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
"permission to change the permission; cannot ".
"estimate disk usage of '$dir'\n");
$CPAN::Frontend->mysleep(5);
return;
}
}
} elsif (-f $dir) {
# nothing to say, no matter what the permissions
}
} else {
$CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
return;
}
if ($fast) {
$Du = 0; # placeholder
} else {
find(
sub {
$File::Find::prune++ if $CPAN::Signal;
return if -l $_;
if ($^O eq 'MacOS') {
require Mac::Files;
my $cat = Mac::Files::FSpGetCatInfo($_);
$Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
} else {
if (-d _) {
unless (-x _) {
unless (chmod 0755, $_) {
$CPAN::Frontend->mywarn("I have neither the -x permission nor ".
"the permission to change the permission; ".
"can only partially estimate disk usage ".
"of '$_'\n");
$CPAN::Frontend->mysleep(5);
return;
}
}
} else {
$Du += (-s _);
}
}
},
$dir
);
}
return if $CPAN::Signal;
$self->{SIZE}{$dir} = $Du/1024/1024;
unshift @{$self->{FIFO}}, $dir;
$self->debug("measured $dir is $Du") if $CPAN::DEBUG;
$self->{DU} += $Du/1024/1024;
$self->{DU};
}
#-> sub CPAN::CacheMgr::_clean_cache ;
sub _clean_cache {
my($self,$dir) = @_;
return unless -e $dir;
unless (File::Spec->canonpath(File::Basename::dirname($dir))
eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
$CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
"will not remove\n");
$CPAN::Frontend->mysleep(5);
return;
}
$self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
if $CPAN::DEBUG;
File::Path::rmtree($dir);
my $id_deleted = 0;
if ($dir !~ /\.yml$/ && -f "$dir.yml") {
my $yaml_module = CPAN::_yaml_module();
if ($CPAN::META->has_inst($yaml_module)) {
my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); };
if ($@) {
$CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
unlink "$dir.yml" or
$CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
return;
} elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
$CPAN::META->delete("CPAN::Distribution", $id);
# XXX we should restore the state NOW, otherwise this
# distro does not exist until we read an index. BUG ALERT(?)
# $CPAN::Frontend->mywarn (" +++\n");
$id_deleted++;
}
}
unlink "$dir.yml"; # may fail
unless ($id_deleted) {
CPAN->debug("no distro found associated with '$dir'");
}
}
$self->{DU} -= $self->{SIZE}{$dir};
delete $self->{SIZE}{$dir};
}
#-> sub CPAN::CacheMgr::new ;
sub new {
my($class,$phase) = @_;
$phase ||= "atstart";
my $time = time;
my($debug,$t2);
$debug = "";
my $self = {
ID => $CPAN::Config->{build_dir},
MAX => $CPAN::Config->{'build_cache'},
SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
DU => 0
};
$CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
unless $self->{SCAN} =~ /never|atstart|atexit/;
File::Path::mkpath($self->{ID});
my $dh = DirHandle->new($self->{ID});
bless $self, $class;
$self->scan_cache($phase);
$t2 = time;
$debug .= "timing of CacheMgr->new: ".($t2 - $time);
$time = $t2;
CPAN->debug($debug) if $CPAN::DEBUG;
$self;
}
#-> sub CPAN::CacheMgr::scan_cache ;
sub scan_cache {
my ($self, $phase) = @_;
$phase = '' unless defined $phase;
return unless $phase eq $self->{SCAN};
return unless $CPAN::META->{LOCK};
$CPAN::Frontend->myprint(
sprintf("Scanning cache %s for sizes\n",
$self->{ID}));
my $e;
my @entries = $self->entries($self->{ID});
my $i = 0;
my $painted = 0;
for $e (@entries) {
my $symbol = ".";
if ($self->{DU} > $self->{MAX}) {
$symbol = "-";
$self->disk_usage($e,1);
} else {
$self->disk_usage($e);
}
$i++;
while (($painted/76) < ($i/@entries)) {
$CPAN::Frontend->myprint($symbol);
$painted++;
}
return if $CPAN::Signal;
}
$CPAN::Frontend->myprint("DONE\n");
$self->tidyup;
}
1;

175
OGP64/usr/share/perl5/5.40/CPAN/Complete.pm Normal file
View file

@ -0,0 +1,175 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Complete;
use strict;
@CPAN::Complete::ISA = qw(CPAN::Debug);
# Q: where is the "How do I add a new command" HOWTO?
# A: git log -p -1 355c44e9caaec857e4b12f51afb96498833c3e36 where andk added the report command
@CPAN::Complete::COMMANDS = sort qw(
? ! a b d h i m o q r u
autobundle
bye
clean
cvs_import
dump
exit
failed
force
fforce
hosts
install
install_tested
is_tested
look
ls
make
mkmyconfig
notest
perldoc
quit
readme
recent
recompile
reload
report
reports
scripts
smoke
test
upgrade
);
use vars qw(
$VERSION
);
$VERSION = "5.5001";
package CPAN::Complete;
use strict;
sub gnu_cpl {
my($text, $line, $start, $end) = @_;
my(@perlret) = cpl($text, $line, $start);
# find longest common match. Can anybody show me how to peruse
# T::R::Gnu to have this done automatically? Seems expensive.
return () unless @perlret;
my($newtext) = $text;
for (my $i = length($text)+1;;$i++) {
last unless length($perlret[0]) && length($perlret[0]) >= $i;
my $try = substr($perlret[0],0,$i);
my @tries = grep {substr($_,0,$i) eq $try} @perlret;
# warn "try[$try]tries[@tries]";
if (@tries == @perlret) {
$newtext = $try;
} else {
last;
}
}
($newtext,@perlret);
}
#-> sub CPAN::Complete::cpl ;
sub cpl {
my($word,$line,$pos) = @_;
$word ||= "";
$line ||= "";
$pos ||= 0;
CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
$line =~ s/^\s*//;
if ($line =~ s/^((?:notest|f?force)\s*)//) {
$pos -= length($1);
}
my @return;
if ($pos == 0 || $line =~ /^(?:h(?:elp)?|\?)\s/) {
@return = grep /^\Q$word\E/, @CPAN::Complete::COMMANDS;
} elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
@return = ();
} elsif ($line =~ /^a\s/) {
@return = cplx('CPAN::Author',uc($word));
} elsif ($line =~ /^ls\s/) {
my($author,$rest) = $word =~ m|([^/]+)/?(.*)|;
@return = $rest ? () : map {"$_/"} cplx('CPAN::Author',uc($author||""));
if (0 && 1==@return) { # XXX too slow and even wrong when there is a * already
@return = grep /^\Q$word\E/, map {"$author/$_->[2]"} CPAN::Shell->expand("Author",$author)->ls("$rest*","2");
}
} elsif ($line =~ /^b\s/) {
CPAN::Shell->local_bundles;
@return = cplx('CPAN::Bundle',$word);
} elsif ($line =~ /^d\s/) {
@return = cplx('CPAN::Distribution',$word);
} elsif ($line =~ m/^(
[mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
)\s/x ) {
if ($word =~ /^Bundle::/) {
CPAN::Shell->local_bundles;
}
@return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
} elsif ($line =~ /^i\s/) {
@return = cpl_any($word);
} elsif ($line =~ /^reload\s/) {
@return = cpl_reload($word,$line,$pos);
} elsif ($line =~ /^o\s/) {
@return = cpl_option($word,$line,$pos);
} elsif ($line =~ m/^\S+\s/ ) {
# fallback for future commands and what we have forgotten above
@return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
} else {
@return = ();
}
return @return;
}
#-> sub CPAN::Complete::cplx ;
sub cplx {
my($class, $word) = @_;
if (CPAN::_sqlite_running()) {
$CPAN::SQLite->search($class, "^\Q$word\E");
}
my $method = "id";
$method = "pretty_id" if $class eq "CPAN::Distribution";
sort grep /^\Q$word\E/, map { $_->$method() } $CPAN::META->all_objects($class);
}
#-> sub CPAN::Complete::cpl_any ;
sub cpl_any {
my($word) = shift;
return (
cplx('CPAN::Author',$word),
cplx('CPAN::Bundle',$word),
cplx('CPAN::Distribution',$word),
cplx('CPAN::Module',$word),
);
}
#-> sub CPAN::Complete::cpl_reload ;
sub cpl_reload {
my($word,$line,$pos) = @_;
$word ||= "";
my(@words) = split " ", $line;
CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
my(@ok) = qw(cpan index);
return @ok if @words == 1;
return grep /^\Q$word\E/, @ok if @words == 2 && $word;
}
#-> sub CPAN::Complete::cpl_option ;
sub cpl_option {
my($word,$line,$pos) = @_;
$word ||= "";
my(@words) = split " ", $line;
CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
my(@ok) = qw(conf debug);
return @ok if @words == 1;
return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
if (0) {
} elsif ($words[1] eq 'index') {
return ();
} elsif ($words[1] eq 'conf') {
return CPAN::HandleConfig::cpl(@_);
} elsif ($words[1] eq 'debug') {
return sort grep /^\Q$word\E/i,
sort keys %CPAN::DEBUG, 'all';
}
}
1;

83
OGP64/usr/share/perl5/5.40/CPAN/Debug.pm Normal file
View file

@ -0,0 +1,83 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
package CPAN::Debug;
use strict;
use vars qw($VERSION);
$VERSION = "5.5001";
# module is internal to CPAN.pm
%CPAN::DEBUG = qw[
CPAN 1
Index 2
InfoObj 4
Author 8
Distribution 16
Bundle 32
Module 64
CacheMgr 128
Complete 256
FTP 512
Shell 1024
Eval 2048
HandleConfig 4096
Tarzip 8192
Version 16384
Queue 32768
FirstTime 65536
];
$CPAN::DEBUG ||= 0;
#-> sub CPAN::Debug::debug ;
sub debug {
my($self,$arg) = @_;
my @caller;
my $i = 0;
while () {
my(@c) = (caller($i))[0 .. ($i ? 3 : 2)];
last unless defined $c[0];
push @caller, \@c;
for (0,3) {
last if $_ > $#c;
$c[$_] =~ s/.*:://;
}
for (1) {
$c[$_] =~ s|.*/||;
}
last if ++$i>=3;
}
pop @caller;
if ($CPAN::DEBUG{$caller[0][0]} & $CPAN::DEBUG) {
if ($arg and ref $arg) {
eval { require Data::Dumper };
if ($@) {
$CPAN::Frontend->myprint("Debug(\n" . $arg->as_string . ")\n");
} else {
$CPAN::Frontend->myprint("Debug(\n" . Data::Dumper::Dumper($arg) . ")\n");
}
} else {
my $outer = "";
local $" = ",";
if (@caller>1) {
$outer = ",[@{$caller[1]}]";
}
$CPAN::Frontend->myprint("Debug(@{$caller[0]}$outer): $arg\n");
}
}
}
1;
__END__
=head1 NAME
CPAN::Debug - internal debugging for CPAN.pm
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut

16
OGP64/usr/share/perl5/5.40/CPAN/DeferredCode.pm Normal file
View file

@ -0,0 +1,16 @@
package CPAN::DeferredCode;
use strict;
use vars qw/$VERSION/;
use overload fallback => 1, map { ($_ => 'run') } qw/
bool "" 0+
/;
$VERSION = "5.50";
sub run {
$_[0]->();
}
1;

4930
OGP64/usr/share/perl5/5.40/CPAN/Distribution.pm Normal file
View file

File diff suppressed because it is too large Load diff

481
OGP64/usr/share/perl5/5.40/CPAN/Distroprefs.pm Normal file
View file

@ -0,0 +1,481 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
use 5.006;
use strict;
package CPAN::Distroprefs;
use vars qw($VERSION);
$VERSION = '6.0001';
package CPAN::Distroprefs::Result;
use File::Spec;
sub new { bless $_[1] || {} => $_[0] }
sub abs { File::Spec->catfile($_[0]->dir, $_[0]->file) }
sub __cloner {
my ($class, $name, $newclass) = @_;
$newclass = 'CPAN::Distroprefs::Result::' . $newclass;
no strict 'refs';
*{$class . '::' . $name} = sub {
$newclass->new({
%{ $_[0] },
%{ $_[1] },
});
};
}
BEGIN { __PACKAGE__->__cloner(as_warning => 'Warning') }
BEGIN { __PACKAGE__->__cloner(as_fatal => 'Fatal') }
BEGIN { __PACKAGE__->__cloner(as_success => 'Success') }
sub __accessor {
my ($class, $key) = @_;
no strict 'refs';
*{$class . '::' . $key} = sub { $_[0]->{$key} };
}
BEGIN { __PACKAGE__->__accessor($_) for qw(type file ext dir) }
sub is_warning { 0 }
sub is_fatal { 0 }
sub is_success { 0 }
package CPAN::Distroprefs::Result::Error;
use vars qw(@ISA);
BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic
BEGIN { __PACKAGE__->__accessor($_) for qw(msg) }
sub as_string {
my ($self) = @_;
if ($self->msg) {
return sprintf $self->fmt_reason, $self->file, $self->msg;
} else {
return sprintf $self->fmt_unknown, $self->file;
}
}
package CPAN::Distroprefs::Result::Warning;
use vars qw(@ISA);
BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic
sub is_warning { 1 }
sub fmt_reason { "Error reading distroprefs file %s, skipping: %s" }
sub fmt_unknown { "Unknown error reading distroprefs file %s, skipping." }
package CPAN::Distroprefs::Result::Fatal;
use vars qw(@ISA);
BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic
sub is_fatal { 1 }
sub fmt_reason { "Error reading distroprefs file %s: %s" }
sub fmt_unknown { "Unknown error reading distroprefs file %s." }
package CPAN::Distroprefs::Result::Success;
use vars qw(@ISA);
BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic
BEGIN { __PACKAGE__->__accessor($_) for qw(prefs extension) }
sub is_success { 1 }
package CPAN::Distroprefs::Iterator;
sub new { bless $_[1] => $_[0] }
sub next { $_[0]->() }
package CPAN::Distroprefs;
use Carp ();
use DirHandle;
sub _load_method {
my ($self, $loader, $result) = @_;
return '_load_yaml' if $loader eq 'CPAN' or $loader =~ /^YAML(::|$)/;
return '_load_' . $result->ext;
}
sub _load_yaml {
my ($self, $loader, $result) = @_;
my $data = eval {
$loader eq 'CPAN'
? $loader->_yaml_loadfile($result->abs)
: [ $loader->can('LoadFile')->($result->abs) ]
};
if (my $err = $@) {
die $result->as_warning({
msg => $err,
});
} elsif (!$data) {
die $result->as_warning;
} else {
return @$data;
}
}
sub _load_dd {
my ($self, $loader, $result) = @_;
my @data;
{
package CPAN::Eval;
# this caused a die in CPAN.pm, and I am leaving it 'fatal', though I'm
# not sure why we wouldn't just skip the file as we do for all other
# errors. -- hdp
my $abs = $result->abs;
open FH, "<$abs" or die $result->as_fatal(msg => "$!");
local $/;
my $eval = <FH>;
close FH;
no strict;
eval $eval;
if (my $err = $@) {
die $result->as_warning({ msg => $err });
}
my $i = 1;
while (${"VAR$i"}) {
push @data, ${"VAR$i"};
$i++;
}
}
return @data;
}
sub _load_st {
my ($self, $loader, $result) = @_;
# eval because Storable is never forward compatible
my @data = eval { @{scalar $loader->can('retrieve')->($result->abs) } };
if (my $err = $@) {
die $result->as_warning({ msg => $err });
}
return @data;
}
sub _build_file_list {
if (@_ > 3) {
die "_build_file_list should be called with 3 arguments, was called with more. First argument is '$_[0]'.";
}
my ($dir, $dir1, $ext_re) = @_;
my @list;
my $dh;
unless (opendir($dh, $dir)) {
$CPAN::Frontend->mywarn("ignoring prefs directory '$dir': $!");
return @list;
}
while (my $fn = readdir $dh) {
next if $fn eq '.' || $fn eq '..';
if (-d "$dir/$fn") {
next if $fn =~ /^[._]/; # prune .svn, .git, .hg, _darcs and what the user wants to hide
push @list, _build_file_list("$dir/$fn", "$dir1$fn/", $ext_re);
} else {
if ($fn =~ $ext_re) {
push @list, "$dir1$fn";
}
}
}
return @list;
}
sub find {
my ($self, $dir, $ext_map) = @_;
return CPAN::Distroprefs::Iterator->new(sub { return }) unless %$ext_map;
my $possible_ext = join "|", map { quotemeta } keys %$ext_map;
my $ext_re = qr/\.($possible_ext)$/;
my @files = _build_file_list($dir, '', $ext_re);
@files = sort @files if @files;
# label the block so that we can use redo in the middle
return CPAN::Distroprefs::Iterator->new(sub { LOOP: {
my $fn = shift @files;
return unless defined $fn;
my ($ext) = $fn =~ $ext_re;
my $loader = $ext_map->{$ext};
my $result = CPAN::Distroprefs::Result->new({
file => $fn, ext => $ext, dir => $dir
});
# copied from CPAN.pm; is this ever actually possible?
redo unless -f $result->abs;
my $load_method = $self->_load_method($loader, $result);
my @prefs = eval { $self->$load_method($loader, $result) };
if (my $err = $@) {
if (ref($err) && eval { $err->isa('CPAN::Distroprefs::Result') }) {
return $err;
}
# rethrow any exceptions that we did not generate
die $err;
} elsif (!@prefs) {
# the loader should have handled this, but just in case:
return $result->as_warning;
}
return $result->as_success({
prefs => [
map { CPAN::Distroprefs::Pref->new({ data => $_ }) } @prefs
],
});
} });
}
package CPAN::Distroprefs::Pref;
use Carp ();
sub new { bless $_[1] => $_[0] }
sub data { shift->{data} }
sub has_any_match { $_[0]->data->{match} ? 1 : 0 }
sub has_match {
my $match = $_[0]->data->{match} || return 0;
exists $match->{$_[1]} || exists $match->{"not_$_[1]"}
}
sub has_valid_subkeys {
grep { exists $_[0]->data->{match}{$_} }
map { $_, "not_$_" }
$_[0]->match_attributes
}
sub _pattern {
my $re = shift;
my $p = eval sprintf 'qr{%s}', $re;
if ($@) {
$@ =~ s/\n$//;
die "Error in Distroprefs pattern qr{$re}\n$@";
}
return $p;
}
sub _match_scalar {
my ($match, $data) = @_;
my $qr = _pattern($match);
return $data =~ /$qr/;
}
sub _match_hash {
my ($match, $data) = @_;
for my $mkey (keys %$match) {
(my $dkey = $mkey) =~ s/^not_//;
my $val = defined $data->{$dkey} ? $data->{$dkey} : '';
if (_match_scalar($match->{$mkey}, $val)) {
return 0 if $mkey =~ /^not_/;
}
else {
return 0 if $mkey !~ /^not_/;
}
}
return 1;
}
sub _match {
my ($self, $key, $data, $matcher) = @_;
my $m = $self->data->{match};
if (exists $m->{$key}) {
return 0 unless $matcher->($m->{$key}, $data);
}
if (exists $m->{"not_$key"}) {
return 0 if $matcher->($m->{"not_$key"}, $data);
}
return 1;
}
sub _scalar_match {
my ($self, $key, $data) = @_;
return $self->_match($key, $data, \&_match_scalar);
}
sub _hash_match {
my ($self, $key, $data) = @_;
return $self->_match($key, $data, \&_match_hash);
}
# do not take the order of C<keys %$match> because "module" is by far the
# slowest
sub match_attributes { qw(env distribution perl perlconfig module) }
sub match_module {
my ($self, $modules) = @_;
return $self->_match("module", $modules, sub {
my($match, $data) = @_;
my $qr = _pattern($match);
for my $module (@$data) {
return 1 if $module =~ /$qr/;
}
return 0;
});
}
sub match_distribution { shift->_scalar_match(distribution => @_) }
sub match_perl { shift->_scalar_match(perl => @_) }
sub match_perlconfig { shift->_hash_match(perlconfig => @_) }
sub match_env { shift->_hash_match(env => @_) }
sub matches {
my ($self, $arg) = @_;
my $default_match = 0;
for my $key (grep { $self->has_match($_) } $self->match_attributes) {
unless (exists $arg->{$key}) {
Carp::croak "Can't match pref: missing argument key $key";
}
$default_match = 1;
my $val = $arg->{$key};
# make it possible to avoid computing things until we have to
if (ref($val) eq 'CODE') { $val = $val->() }
my $meth = "match_$key";
return 0 unless $self->$meth($val);
}
return $default_match;
}
1;
__END__
=head1 NAME
CPAN::Distroprefs -- read and match distroprefs
=head1 SYNOPSIS
use CPAN::Distroprefs;
my %info = (... distribution/environment info ...);
my $finder = CPAN::Distroprefs->find($prefs_dir, \%ext_map);
while (my $result = $finder->next) {
die $result->as_string if $result->is_fatal;
warn($result->as_string), next if $result->is_warning;
for my $pref (@{ $result->prefs }) {
if ($pref->matches(\%info)) {
return $pref;
}
}
}
=head1 DESCRIPTION
This module encapsulates reading L<Distroprefs|CPAN> and matching them against CPAN distributions.
=head1 INTERFACE
my $finder = CPAN::Distroprefs->find($dir, \%ext_map);
while (my $result = $finder->next) { ... }
Build an iterator which finds distroprefs files in the tree below the
given directory. Within the tree directories matching C<m/^[._]/> are
pruned.
C<%ext_map> is a hashref whose keys are file extensions and whose values are
modules used to load matching files:
{
'yml' => 'YAML::Syck',
'dd' => 'Data::Dumper',
...
}
Each time C<< $finder->next >> is called, the iterator returns one of two
possible values:
=over
=item * a CPAN::Distroprefs::Result object
=item * C<undef>, indicating that no prefs files remain to be found
=back
=head1 RESULTS
L<C<find()>|/INTERFACE> returns CPAN::Distroprefs::Result objects to
indicate success or failure when reading a prefs file.
=head2 Common
All results share some common attributes:
=head3 type
C<success>, C<warning>, or C<fatal>
=head3 file
the file from which these prefs were read, or to which this error refers (relative filename)
=head3 ext
the file's extension, which determines how to load it
=head3 dir
the directory the file was read from
=head3 abs
the absolute path to the file
=head2 Errors
Error results (warning and fatal) contain:
=head3 msg
the error message (usually either C<$!> or a YAML error)
=head2 Successes
Success results contain:
=head3 prefs
an arrayref of CPAN::Distroprefs::Pref objects
=head1 PREFS
CPAN::Distroprefs::Pref objects represent individual distroprefs documents.
They are constructed automatically as part of C<success> results from C<find()>.
=head3 data
the pref information as a hashref, suitable for e.g. passing to Kwalify
=head3 match_attributes
returns a list of the valid match attributes (see the Distroprefs section in L<CPAN>)
currently: C<env perl perlconfig distribution module>
=head3 has_any_match
true if this pref has a 'match' attribute at all
=head3 has_valid_subkeys
true if this pref has a 'match' attribute and at least one valid match attribute
=head3 matches
if ($pref->matches(\%arg)) { ... }
true if this pref matches the passed-in hashref, which must have a value for
each of the C<match_attributes> (above)
=head1 LICENSE
This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.
=cut

45
OGP64/usr/share/perl5/5.40/CPAN/Distrostatus.pm Normal file
View file

@ -0,0 +1,45 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Distrostatus;
use overload '""' => "as_string",
fallback => 1;
use vars qw($something_has_failed_at);
use vars qw(
$VERSION
);
$VERSION = "5.5";
sub new {
my($class,$arg) = @_;
my $failed = substr($arg,0,2) eq "NO";
if ($failed) {
$something_has_failed_at = $CPAN::CurrentCommandId;
}
bless {
TEXT => $arg,
FAILED => $failed,
COMMANDID => $CPAN::CurrentCommandId,
TIME => time,
}, $class;
}
sub something_has_just_failed () {
defined $something_has_failed_at &&
$something_has_failed_at == $CPAN::CurrentCommandId;
}
sub commandid { shift->{COMMANDID} }
sub failed { shift->{FAILED} }
sub text {
my($self,$set) = @_;
if (defined $set) {
$self->{TEXT} = $set;
}
$self->{TEXT};
}
sub as_string {
my($self) = @_;
$self->text;
}
1;

113
OGP64/usr/share/perl5/5.40/CPAN/Exception/RecursiveDependency.pm Normal file
View file

@ -0,0 +1,113 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Exception::RecursiveDependency;
use strict;
use overload '""' => "as_string";
use vars qw(
$VERSION
);
$VERSION = "5.5001";
{
package CPAN::Exception::RecursiveDependency::na;
use overload '""' => "as_string";
sub new { bless {}, shift };
sub as_string { "N/A" };
}
my $NA = CPAN::Exception::RecursiveDependency::na->new;
# a module sees its distribution (no version)
# a distribution sees its prereqs (which are module names) (usually with versions)
# a bundle sees its module names and/or its distributions (no version)
sub new {
my($class) = shift;
my($deps_arg) = shift;
my (@deps,%seen,$loop_starts_with);
DCHAIN: for my $dep (@$deps_arg) {
push @deps, {name => $dep, display_as => $dep};
if ($seen{$dep}++) {
$loop_starts_with = $dep;
last DCHAIN;
}
}
my $in_loop = 0;
my %mark;
DWALK: for my $i (0..$#deps) {
my $x = $deps[$i]{name};
$in_loop ||= $loop_starts_with && $x eq $loop_starts_with;
my $xo = CPAN::Shell->expandany($x) or next;
if ($xo->isa("CPAN::Module")) {
my $have = $xo->inst_version || $NA;
my($want,$d,$want_type);
if ($i>0 and $d = $deps[$i-1]{name}) {
my $do = CPAN::Shell->expandany($d);
$want = $do->{prereq_pm}{requires}{$x};
if (defined $want) {
$want_type = "requires: ";
} else {
$want = $do->{prereq_pm}{build_requires}{$x};
if (defined $want) {
$want_type = "build_requires: ";
} else {
$want_type = "unknown status";
$want = "???";
}
}
} else {
$want = $xo->cpan_version;
$want_type = "want: ";
}
$deps[$i]{have} = $have;
$deps[$i]{want_type} = $want_type;
$deps[$i]{want} = $want;
$deps[$i]{display_as} = "$x (have: $have; $want_type$want)";
if ((! ref $have || !$have->isa('CPAN::Exception::RecursiveDependency::na'))
&& CPAN::Version->vge($have, $want)) {
# https://rt.cpan.org/Ticket/Display.html?id=115340
undef $loop_starts_with;
last DWALK;
}
} elsif ($xo->isa("CPAN::Distribution")) {
my $pretty = $deps[$i]{display_as} = $xo->pretty_id;
my $mark_as;
if ($in_loop) {
$mark_as = CPAN::Distrostatus->new("NO cannot resolve circular dependency");
} else {
$mark_as = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency");
}
$mark{$pretty} = { xo => $xo, mark_as => $mark_as };
}
}
if ($loop_starts_with) {
while (my($k,$v) = each %mark) {
my $xo = $v->{xo};
$xo->{make} = $v->{mark_as};
$xo->store_persistent_state; # otherwise I will not reach
# all involved parties for
# the next session
}
}
bless { deps => \@deps, loop_starts_with => $loop_starts_with }, $class;
}
sub is_resolvable {
! defined shift->{loop_starts_with};
}
sub as_string {
my($self) = shift;
my $deps = $self->{deps};
my $loop_starts_with = $self->{loop_starts_with};
unless ($loop_starts_with) {
return "--not a recursive/circular dependency--";
}
my $ret = "\nRecursive dependency detected:\n ";
$ret .= join("\n => ", map {$_->{display_as}} @$deps);
$ret .= ".\nCannot resolve.\n";
$ret;
}
1;

46
OGP64/usr/share/perl5/5.40/CPAN/Exception/blocked_urllist.pm Normal file
View file

@ -0,0 +1,46 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Exception::blocked_urllist;
use strict;
use overload '""' => "as_string";
use vars qw(
$VERSION
);
$VERSION = "1.001";
sub new {
my($class) = @_;
bless {}, $class;
}
sub as_string {
my($self) = shift;
if ($CPAN::Config->{connect_to_internet_ok}) {
return qq{
You have not configured a urllist for CPAN mirrors. Configure it with
o conf init urllist
};
} else {
return qq{
You have not configured a urllist and do not allow connections to the
internet to get a list of mirrors. If you wish to get a list of CPAN
mirrors to pick from, use this command
o conf init connect_to_internet_ok urllist
If you do not wish to get a list of mirrors and would prefer to set
your urllist manually, use just this command instead
o conf init urllist
};
}
}
1;

23
OGP64/usr/share/perl5/5.40/CPAN/Exception/yaml_not_installed.pm Normal file
View file

@ -0,0 +1,23 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Exception::yaml_not_installed;
use strict;
use overload '""' => "as_string";
use vars qw(
$VERSION
);
$VERSION = "5.5";
sub new {
my($class,$module,$file,$during) = @_;
bless { module => $module, file => $file, during => $during }, $class;
}
sub as_string {
my($self) = shift;
"'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
}
1;

53
OGP64/usr/share/perl5/5.40/CPAN/Exception/yaml_process_error.pm Normal file
View file

@ -0,0 +1,53 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Exception::yaml_process_error;
use strict;
use overload '""' => "as_string";
use vars qw(
$VERSION
);
$VERSION = "5.5";
sub new {
my($class,$module,$file,$during,$error) = @_;
# my $at = Carp::longmess(""); # XXX find something more beautiful
bless { module => $module,
file => $file,
during => $during,
error => $error,
# at => $at,
}, $class;
}
sub as_string {
my($self) = shift;
if ($self->{during}) {
if ($self->{file}) {
if ($self->{module}) {
if ($self->{error}) {
return "Alert: While trying to '$self->{during}' YAML file\n".
" '$self->{file}'\n".
"with '$self->{module}' the following error was encountered:\n".
" $self->{error}\n";
} else {
return "Alert: While trying to '$self->{during}' YAML file\n".
" '$self->{file}'\n".
"with '$self->{module}' some unknown error was encountered\n";
}
} else {
return "Alert: While trying to '$self->{during}' YAML file\n".
" '$self->{file}'\n".
"some unknown error was encountered\n";
}
} else {
return "Alert: While trying to '$self->{during}' some YAML file\n".
"some unknown error was encountered\n";
}
} else {
return "Alert: unknown error encountered\n";
}
}
1;

1323
OGP64/usr/share/perl5/5.40/CPAN/FTP.pm Normal file
View file

File diff suppressed because it is too large Load diff

62
OGP64/usr/share/perl5/5.40/CPAN/FTP/netrc.pm Normal file
View file

@ -0,0 +1,62 @@
package CPAN::FTP::netrc;
use strict;
$CPAN::FTP::netrc::VERSION = $CPAN::FTP::netrc::VERSION = "1.01";
# package CPAN::FTP::netrc;
sub new {
my($class) = @_;
my $file = File::Spec->catfile($ENV{HOME},".netrc");
my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,$blksize,$blocks)
= stat($file);
$mode ||= 0;
my $protected = 0;
my($fh,@machines,$hasdefault);
$hasdefault = 0;
$fh = FileHandle->new or die "Could not create a filehandle";
if($fh->open($file)) {
$protected = ($mode & 077) == 0;
local($/) = "";
NETRC: while (<$fh>) {
my(@tokens) = split " ", $_;
TOKEN: while (@tokens) {
my($t) = shift @tokens;
if ($t eq "default") {
$hasdefault++;
last NETRC;
}
last TOKEN if $t eq "macdef";
if ($t eq "machine") {
push @machines, shift @tokens;
}
}
}
} else {
$file = $hasdefault = $protected = "";
}
bless {
'mach' => [@machines],
'netrc' => $file,
'hasdefault' => $hasdefault,
'protected' => $protected,
}, $class;
}
# CPAN::FTP::netrc::hasdefault;
sub hasdefault { shift->{'hasdefault'} }
sub netrc { shift->{'netrc'} }
sub protected { shift->{'protected'} }
sub contains {
my($self,$mach) = @_;
for ( @{$self->{'mach'}} ) {
return 1 if $_ eq $mach;
}
return 0;
}
1;

2216
OGP64/usr/share/perl5/5.40/CPAN/FirstTime.pm Normal file
View file

File diff suppressed because it is too large Load diff

255
OGP64/usr/share/perl5/5.40/CPAN/HTTP/Client.pm Normal file
View file

@ -0,0 +1,255 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::HTTP::Client;
use strict;
use vars qw(@ISA);
use CPAN::HTTP::Credentials;
use HTTP::Tiny 0.005;
$CPAN::HTTP::Client::VERSION = $CPAN::HTTP::Client::VERSION = "1.9602";
# CPAN::HTTP::Client is adapted from parts of cpanm by Tatsuhiko Miyagawa
# and parts of LWP by Gisle Aas
sub new {
my $class = shift;
my %args = @_;
for my $k ( keys %args ) {
$args{$k} = '' unless defined $args{$k};
}
$args{no_proxy} = [split(",", $args{no_proxy}) ] if $args{no_proxy};
return bless \%args, $class;
}
# This executes a request with redirection (up to 5) and returns the
# response structure generated by HTTP::Tiny
#
# If authentication fails, it will attempt to get new authentication
# information and repeat up to 5 times
sub mirror {
my($self, $uri, $path) = @_;
my $want_proxy = $self->_want_proxy($uri);
my $http = HTTP::Tiny->new(
verify_SSL => 1,
$want_proxy ? (proxy => $self->{proxy}) : ()
);
my ($response, %headers);
my $retries = 0;
while ( $retries++ < 5 ) {
$response = $http->mirror( $uri, $path, {headers => \%headers} );
if ( $response->{status} eq '401' ) {
last unless $self->_get_auth_params( $response, 'non_proxy' );
}
elsif ( $response->{status} eq '407' ) {
last unless $self->_get_auth_params( $response, 'proxy' );
}
else {
last; # either success or failure
}
my %headers = (
$self->_auth_headers( $uri, 'non_proxy' ),
( $want_proxy ? $self->_auth_headers($uri, 'proxy') : () ),
);
}
return $response;
}
sub _want_proxy {
my ($self, $uri) = @_;
return unless $self->{proxy};
my($host) = $uri =~ m|://([^/:]+)|;
return ! grep { $host =~ /\Q$_\E$/ } @{ $self->{no_proxy} || [] };
}
# Generates the authentication headers for a given mode
# C<mode> is 'proxy' or 'non_proxy'
# C<_${mode}_type> is 'basic' or 'digest'
# C<_${mode}_params> will be the challenge parameters from the 401/407 headers
sub _auth_headers {
my ($self, $uri, $mode) = @_;
# Get names for our mode-specific attributes
my ($type_key, $param_key) = map {"_" . $mode . $_} qw/_type _params/;
# If _prepare_auth has not been called, we can't prepare headers
return unless $self->{$type_key};
# Get user credentials for mode
my $cred_method = "get_" . ($mode ? "proxy" : "non_proxy") ."_credentials";
my ($user, $pass) = CPAN::HTTP::Credentials->$cred_method;
# Generate the header for the mode & type
my $header = $mode eq 'proxy' ? 'Proxy-Authorization' : 'Authorization';
my $value_method = "_" . $self->{$type_key} . "_auth";
my $value = $self->$value_method($user, $pass, $self->{$param_key}, $uri);
# If we didn't get a value, we didn't have the right modules available
return $value ? ( $header, $value ) : ();
}
# Extract authentication parameters from headers, but clear any prior
# credentials if we failed (so we might prompt user for password again)
sub _get_auth_params {
my ($self, $response, $mode) = @_;
my $prefix = $mode eq 'proxy' ? 'Proxy' : 'WWW';
my ($type_key, $param_key) = map {"_" . $mode . $_} qw/_type _params/;
if ( ! $response->{success} ) { # auth failed
my $method = "clear_${mode}_credentials";
CPAN::HTTP::Credentials->$method;
delete $self->{$_} for $type_key, $param_key;
}
($self->{$type_key}, $self->{$param_key}) =
$self->_get_challenge( $response, "${prefix}-Authenticate");
return $self->{$type_key};
}
# Extract challenge type and parameters for a challenge list
sub _get_challenge {
my ($self, $response, $auth_header) = @_;
my $auth_list = $response->{headers}(lc $auth_header);
return unless defined $auth_list;
$auth_list = [$auth_list] unless ref $auth_list;
for my $challenge (@$auth_list) {
$challenge =~ tr/,/;/; # "," is used to separate auth-params!!
($challenge) = $self->split_header_words($challenge);
my $scheme = shift(@$challenge);
shift(@$challenge); # no value
$challenge = { @$challenge }; # make rest into a hash
unless ($scheme =~ /^(basic|digest)$/) {
next; # bad scheme
}
$scheme = $1; # untainted now
return ($scheme, $challenge);
}
return;
}
# Generate a basic authentication header value
sub _basic_auth {
my ($self, $user, $pass) = @_;
unless ( $CPAN::META->has_usable('MIME::Base64') ) {
$CPAN::Frontend->mywarn(
"MIME::Base64 is required for 'Basic' style authentication"
);
return;
}
return "Basic " . MIME::Base64::encode_base64("$user\:$pass", q{});
}
# Generate a digest authentication header value
sub _digest_auth {
my ($self, $user, $pass, $auth_param, $uri) = @_;
unless ( $CPAN::META->has_usable('Digest::MD5') ) {
$CPAN::Frontend->mywarn(
"Digest::MD5 is required for 'Digest' style authentication"
);
return;
}
my $nc = sprintf "%08X", ++$self->{_nonce_count}{$auth_param->{nonce}};
my $cnonce = sprintf "%8x", time;
my ($path) = $uri =~ m{^\w+?://[^/]+(/.*)$};
$path = "/" unless defined $path;
my $md5 = Digest::MD5->new;
my(@digest);
$md5->add(join(":", $user, $auth_param->{realm}, $pass));
push(@digest, $md5->hexdigest);
$md5->reset;
push(@digest, $auth_param->{nonce});
if ($auth_param->{qop}) {
push(@digest, $nc, $cnonce, ($auth_param->{qop} =~ m|^auth[,;]auth-int$|) ? 'auth' : $auth_param->{qop});
}
$md5->add(join(":", 'GET', $path));
push(@digest, $md5->hexdigest);
$md5->reset;
$md5->add(join(":", @digest));
my($digest) = $md5->hexdigest;
$md5->reset;
my %resp = map { $_ => $auth_param->{$_} } qw(realm nonce opaque);
@resp{qw(username uri response algorithm)} = ($user, $path, $digest, "MD5");
if (($auth_param->{qop} || "") =~ m|^auth([,;]auth-int)?$|) {
@resp{qw(qop cnonce nc)} = ("auth", $cnonce, $nc);
}
my(@order) =
qw(username realm qop algorithm uri nonce nc cnonce response opaque);
my @pairs;
for (@order) {
next unless defined $resp{$_};
push(@pairs, "$_=" . qq("$resp{$_}"));
}
my $auth_value = "Digest " . join(", ", @pairs);
return $auth_value;
}
# split_header_words adapted from HTTP::Headers::Util
sub split_header_words {
my ($self, @words) = @_;
my @res = $self->_split_header_words(@words);
for my $arr (@res) {
for (my $i = @$arr - 2; $i >= 0; $i -= 2) {
$arr->[$i] = lc($arr->[$i]);
}
}
return @res;
}
sub _split_header_words {
my($self, @val) = @_;
my @res;
for (@val) {
my @cur;
while (length) {
if (s/^\s*(=*[^\s=;,]+)//) { # 'token' or parameter 'attribute'
push(@cur, $1);
# a quoted value
if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) {
my $val = $1;
$val =~ s/\\(.)/$1/g;
push(@cur, $val);
# some unquoted value
}
elsif (s/^\s*=\s*([^;,\s]*)//) {
my $val = $1;
$val =~ s/\s+$//;
push(@cur, $val);
# no value, a lone token
}
else {
push(@cur, undef);
}
}
elsif (s/^\s*,//) {
push(@res, [@cur]) if @cur;
@cur = ();
}
elsif (s/^\s*;// || s/^\s+//) {
# continue
}
else {
die "This should not happen: '$_'";
}
}
push(@res, \@cur) if @cur;
}
@res;
}
1;

91
OGP64/usr/share/perl5/5.40/CPAN/HTTP/Credentials.pm Normal file
View file

@ -0,0 +1,91 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::HTTP::Credentials;
use strict;
use vars qw($USER $PASSWORD $PROXY_USER $PROXY_PASSWORD);
$CPAN::HTTP::Credentials::VERSION = $CPAN::HTTP::Credentials::VERSION = "1.9601";
sub clear_credentials {
clear_non_proxy_credentials();
clear_proxy_credentials();
}
sub clear_non_proxy_credentials {
undef $USER;
undef $PASSWORD;
}
sub clear_proxy_credentials {
undef $PROXY_USER;
undef $PROXY_PASSWORD;
}
sub get_proxy_credentials {
my $self = shift;
if ($PROXY_USER && $PROXY_PASSWORD) {
return ($PROXY_USER, $PROXY_PASSWORD);
}
if ( defined $CPAN::Config->{proxy_user}
&& $CPAN::Config->{proxy_user}
) {
$PROXY_USER = $CPAN::Config->{proxy_user};
$PROXY_PASSWORD = $CPAN::Config->{proxy_pass} || "";
return ($PROXY_USER, $PROXY_PASSWORD);
}
my $username_prompt = "\nProxy authentication needed!
(Note: to permanently configure username and password run
o conf proxy_user your_username
o conf proxy_pass your_password
)\nUsername:";
($PROXY_USER, $PROXY_PASSWORD) =
_get_username_and_password_from_user($username_prompt);
return ($PROXY_USER,$PROXY_PASSWORD);
}
sub get_non_proxy_credentials {
my $self = shift;
if ($USER && $PASSWORD) {
return ($USER, $PASSWORD);
}
if ( defined $CPAN::Config->{username} ) {
$USER = $CPAN::Config->{username};
$PASSWORD = $CPAN::Config->{password} || "";
return ($USER, $PASSWORD);
}
my $username_prompt = "\nAuthentication needed!
(Note: to permanently configure username and password run
o conf username your_username
o conf password your_password
)\nUsername:";
($USER, $PASSWORD) =
_get_username_and_password_from_user($username_prompt);
return ($USER,$PASSWORD);
}
sub _get_username_and_password_from_user {
my $username_message = shift;
my ($username,$password);
ExtUtils::MakeMaker->import(qw(prompt));
$username = prompt($username_message);
if ($CPAN::META->has_inst("Term::ReadKey")) {
Term::ReadKey::ReadMode("noecho");
}
else {
$CPAN::Frontend->mywarn(
"Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
);
}
$password = prompt("Password:");
if ($CPAN::META->has_inst("Term::ReadKey")) {
Term::ReadKey::ReadMode("restore");
}
$CPAN::Frontend->myprint("\n\n");
return ($username,$password);
}
1;

826
OGP64/usr/share/perl5/5.40/CPAN/HandleConfig.pm Normal file
View file

@ -0,0 +1,826 @@
package CPAN::HandleConfig;
use strict;
use vars qw(%can %keys $loading $VERSION);
use File::Path ();
use File::Spec ();
use File::Basename ();
use Carp ();
=head1 NAME
CPAN::HandleConfig - internal configuration handling for CPAN.pm
=cut
$VERSION = "5.5012"; # see also CPAN::Config::VERSION at end of file
%can = (
commit => "Commit changes to disk",
defaults => "Reload defaults from disk",
help => "Short help about 'o conf' usage",
init => "Interactive setting of all options",
);
# Q: where is the "How do I add a new config option" HOWTO?
# A1: svn diff -r 757:758 # where dagolden added test_report [git e997b71de88f1019a1472fc13cb97b1b7f96610f]
# A2: svn diff -r 985:986 # where andk added yaml_module [git 312b6d9b12b1bdec0b6e282d853482145475021f]
# A3: 1. add new config option to %keys below
# 2. add a Pod description in CPAN::FirstTime in the DESCRIPTION
# section; 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 }
(
"allow_installing_module_downgrades",
"allow_installing_outdated_dists",
"applypatch",
"auto_commit",
"build_cache",
"build_dir",
"build_dir_reuse",
"build_requires_install_policy",
"bzip2",
"cache_metadata",
"check_sigs",
"cleanup_after_install",
"colorize_debug",
"colorize_output",
"colorize_print",
"colorize_warn",
"commandnumber_in_prompt",
"commands_quote",
"connect_to_internet_ok",
"cpan_home",
"curl",
"dontload_hash", # deprecated after 1.83_68 (rev. 581)
"dontload_list",
"ftp",
"ftp_passive",
"ftp_proxy",
"ftpstats_size",
"ftpstats_period",
"getcwd",
"gpg",
"gzip",
"halt_on_failure",
"histfile",
"histsize",
"http_proxy",
"inactivity_timeout",
"index_expire",
"inhibit_startup_message",
"keep_source_where",
"load_module_verbosity",
"lynx",
"make",
"make_arg",
"make_install_arg",
"make_install_make_command",
"makepl_arg",
"mbuild_arg",
"mbuild_install_arg",
"mbuild_install_build_command",
"mbuildpl_arg",
"ncftp",
"ncftpget",
"no_proxy",
"pager",
"password",
"patch",
"patches_dir",
"perl5lib_verbosity",
"plugin_list",
"prefer_external_tar",
"prefer_installer",
"prefs_dir",
"prerequisites_policy",
"proxy_pass",
"proxy_user",
"pushy_https",
"randomize_urllist",
"recommends_policy",
"scan_cache",
"shell",
"show_unparsable_versions",
"show_upload_date",
"show_zero_versions",
"suggests_policy",
"tar",
"tar_verbosity",
"term_is_latin",
"term_ornaments",
"test_report",
"trust_test_report_history",
"unzip",
"urllist",
"urllist_ping_verbose",
"urllist_ping_external",
"use_prompt_default",
"use_sqlite",
"username",
"version_timeout",
"wait_list",
"wget",
"yaml_load_code",
"yaml_module",
);
my %prefssupport = map { $_ => 1 }
(
"allow_installing_module_downgrades",
"allow_installing_outdated_dists",
"build_requires_install_policy",
"check_sigs",
"make",
"make_install_make_command",
"prefer_installer",
"test_report",
);
# returns true on successful action
sub edit {
my($self,@args) = @_;
return unless @args;
CPAN->debug("self[$self]args[".join(" | ",@args)."]");
my($o,$str,$func,$args,$key_exists);
$o = shift @args;
if($can{$o}) {
my $success = $self->$o(args => \@args); # o conf init => sub init => sub load
unless ($success) {
die "Panic: could not configure CPAN.pm for args [@args]. Giving up.";
}
} else {
CPAN->debug("o[$o]") if $CPAN::DEBUG;
unless (exists $keys{$o}) {
$CPAN::Frontend->mywarn("Warning: unknown configuration variable '$o'\n");
}
my $changed;
# one day I used randomize_urllist for a boolean, so we must
# list them explicitly --ak
if (0) {
} elsif ($o =~ /^(wait_list|urllist|dontload_list|plugin_list)$/) {
#
# ARRAYS
#
$func = shift @args;
$func ||= "";
CPAN->debug("func[$func]args[@args]") if $CPAN::DEBUG;
# Let's avoid eval, it's easier to comprehend without.
if ($func eq "push") {
push @{$CPAN::Config->{$o}}, @args;
$changed = 1;
} elsif ($func eq "pop") {
pop @{$CPAN::Config->{$o}};
$changed = 1;
} elsif ($func eq "shift") {
shift @{$CPAN::Config->{$o}};
$changed = 1;
} elsif ($func eq "unshift") {
unshift @{$CPAN::Config->{$o}}, @args;
$changed = 1;
} elsif ($func eq "splice") {
my $offset = shift @args || 0;
my $length = shift @args || 0;
splice @{$CPAN::Config->{$o}}, $offset, $length, @args; # may warn
$changed = 1;
} elsif ($func) {
$CPAN::Config->{$o} = [$func, @args];
$changed = 1;
} else {
$self->prettyprint($o);
}
if ($changed) {
if ($o eq "urllist") {
# reset the cached values
undef $CPAN::FTP::Thesite;
undef $CPAN::FTP::Themethod;
$CPAN::Index::LAST_TIME = 0;
} elsif ($o eq "dontload_list") {
# empty it, it will be built up again
$CPAN::META->{dontload_hash} = {};
}
}
} elsif ($o =~ /_hash$/) {
#
# HASHES
#
if (@args==1 && $args[0] eq "") {
@args = ();
} elsif (@args % 2) {
push @args, "";
}
$CPAN::Config->{$o} = { @args };
$changed = 1;
} else {
#
# SCALARS
#
if (defined $args[0]) {
$CPAN::CONFIG_DIRTY = 1;
$CPAN::Config->{$o} = $args[0];
$changed = 1;
}
$self->prettyprint($o)
if exists $keys{$o} or defined $CPAN::Config->{$o};
}
if ($changed) {
if ($CPAN::Config->{auto_commit}) {
$self->commit;
} else {
$CPAN::CONFIG_DIRTY = 1;
$CPAN::Frontend->myprint("Please use 'o conf commit' to ".
"make the config permanent!\n\n");
}
}
}
}
sub prettyprint {
my($self,$k) = @_;
my $v = $CPAN::Config->{$k};
if (ref $v) {
my(@report);
if (ref $v eq "ARRAY") {
@report = map {"\t$_ \[$v->[$_]]\n"} 0..$#$v;
} else {
@report = map
{
sprintf "\t%-18s => %s\n",
"[$_]",
defined $v->{$_} ? "[$v->{$_}]" : "undef"
} sort keys %$v;
}
$CPAN::Frontend->myprint(
join(
"",
sprintf(
" %-18s\n",
$k
),
@report
)
);
} elsif (defined $v) {
$CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
} else {
$CPAN::Frontend->myprint(sprintf " %-18s undef\n", $k);
}
}
# generally, this should be called without arguments so that the currently
# loaded config file is where changes are committed.
sub commit {
my($self,@args) = @_;
CPAN->debug("args[@args]") if $CPAN::DEBUG;
if ($CPAN::RUN_DEGRADED) {
$CPAN::Frontend->mydie(
"'o conf commit' disabled in ".
"degraded mode. Maybe try\n".
" !undef \$CPAN::RUN_DEGRADED\n"
);
}
my ($configpm, $must_reload);
# XXX does anything do this? can it be simplified? -- dagolden, 2011-01-19
if (@args) {
if ($args[0] eq "args") {
# we have not signed that contract
} else {
$configpm = $args[0];
}
}
# use provided name or the current config or create a new MyConfig
$configpm ||= require_myconfig_or_config() || make_new_config();
# commit to MyConfig if we can't write to Config
if ( ! -w $configpm && $configpm =~ m{CPAN/Config\.pm} ) {
my $myconfig = _new_config_name();
$CPAN::Frontend->mywarn(
"Your $configpm file\n".
"is not writable. I will attempt to write your configuration to\n" .
"$myconfig instead.\n\n"
);
$configpm = make_new_config();
$must_reload++; # so it gets loaded as $INC{'CPAN/MyConfig.pm'}
}
# XXX why not just "-w $configpm"? -- dagolden, 2011-01-19
my($mode);
if (-f $configpm) {
$mode = (stat $configpm)[2];
if ($mode && ! -w _) {
_die_cant_write_config($configpm);
}
}
$self->_write_config_file($configpm);
require_myconfig_or_config() if $must_reload;
#$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
#chmod $mode, $configpm;
###why was that so? $self->defaults;
$CPAN::Frontend->myprint("commit: wrote '$configpm'\n");
$CPAN::CONFIG_DIRTY = 0;
1;
}
sub _write_config_file {
my ($self, $configpm) = @_;
my $msg;
$msg = <<EOF if $configpm =~ m{CPAN/Config\.pm};
# This is CPAN.pm's systemwide configuration file. This file provides
# defaults for users, and the values can be changed in a per-user
# configuration file.
EOF
$msg ||= "\n";
my($fh) = FileHandle->new;
rename $configpm, "$configpm~" if -f $configpm;
open $fh, ">$configpm" or
$CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
$fh->print(qq[$msg\$CPAN::Config = \{\n]);
foreach (sort keys %$CPAN::Config) {
unless (exists $keys{$_}) {
# do not drop them: forward compatibility!
$CPAN::Frontend->mywarn("Unknown config variable '$_'\n");
next;
}
$fh->print(
" '$_' => ",
$self->neatvalue($CPAN::Config->{$_}),
",\n"
);
}
$fh->print("};\n1;\n__END__\n");
close $fh;
return;
}
# stolen from MakeMaker; not taking the original because it is buggy;
# bugreport will have to say: keys of hashes remain unquoted and can
# produce syntax errors
sub neatvalue {
my($self, $v) = @_;
return "undef" unless defined $v;
my($t) = ref $v;
unless ($t) {
$v =~ s/\\/\\\\/g;
return "q[$v]";
}
if ($t eq 'ARRAY') {
my(@m, @neat);
push @m, "[";
foreach my $elem (@$v) {
push @neat, "q[$elem]";
}
push @m, join ", ", @neat;
push @m, "]";
return join "", @m;
}
return "$v" unless $t eq 'HASH';
my @m;
foreach my $key (sort keys %$v) {
my $val = $v->{$key};
push(@m,"q[$key]=>".$self->neatvalue($val)) ;
}
return "{ ".join(', ',@m)." }";
}
sub defaults {
my($self) = @_;
if ($CPAN::RUN_DEGRADED) {
$CPAN::Frontend->mydie(
"'o conf defaults' disabled in ".
"degraded mode. Maybe try\n".
" !undef \$CPAN::RUN_DEGRADED\n"
);
}
my $done;
for my $config (qw(CPAN/MyConfig.pm CPAN/Config.pm)) {
if ($INC{$config}) {
CPAN->debug("INC{'$config'}[$INC{$config}]") if $CPAN::DEBUG;
CPAN::Shell->_reload_this($config,{reloforce => 1});
$CPAN::Frontend->myprint("'$INC{$config}' reread\n");
last;
}
}
$CPAN::CONFIG_DIRTY = 0;
1;
}
=head2 C<< CLASS->safe_quote ITEM >>
Quotes an item to become safe against spaces
in shell interpolation. An item is enclosed
in double quotes if:
- the item contains spaces in the middle
- the item does not start with a quote
This happens to avoid shell interpolation
problems when whitespace is present in
directory names.
This method uses C<commands_quote> to determine
the correct quote. If C<commands_quote> is
a space, no quoting will take place.
if it starts and ends with the same quote character: leave it as it is
if it contains no whitespace: leave it as it is
if it contains whitespace, then
if it contains quotes: better leave it as it is
else: quote it with the correct quote type for the box we're on
=cut
{
# Instead of patching the guess, set commands_quote
# to the right value
my ($quotes,$use_quote)
= $^O eq 'MSWin32'
? ('"', '"')
: (q{"'}, "'")
;
sub safe_quote {
my ($self, $command) = @_;
# Set up quote/default quote
my $quote = $CPAN::Config->{commands_quote} || $quotes;
if ($quote ne ' '
and defined($command )
and $command =~ /\s/
and $command !~ /[$quote]/) {
return qq<$use_quote$command$use_quote>
}
return $command;
}
}
sub init {
my($self,@args) = @_;
CPAN->debug("self[$self]args[".join(",",@args)."]");
$self->load(do_init => 1, @args);
1;
}
# Loads CPAN::MyConfig or fall-back to CPAN::Config. Will not reload a file
# if already loaded. Returns the path to the file %INC or else the empty string
#
# Note -- if CPAN::Config were loaded and CPAN::MyConfig subsequently
# created, calling this again will leave *both* in %INC
sub require_myconfig_or_config () {
if ( $INC{"CPAN/MyConfig.pm"} || _try_loading("CPAN::MyConfig", cpan_home())) {
return $INC{"CPAN/MyConfig.pm"};
}
elsif ( $INC{"CPAN/Config.pm"} || _try_loading("CPAN::Config") ) {
return $INC{"CPAN/Config.pm"};
}
else {
return q{};
}
}
# Load a module, but ignore "can't locate..." errors
# Optionally take a list of directories to add to @INC for the load
sub _try_loading {
my ($module, @dirs) = @_;
(my $file = $module) =~ s{::}{/}g;
$file .= ".pm";
local @INC = @INC;
for my $dir ( @dirs ) {
if ( -f File::Spec->catfile($dir, $file) ) {
unshift @INC, $dir;
last;
}
}
eval { require $file };
my $err_myconfig = $@;
if ($err_myconfig and $err_myconfig !~ m#locate \Q$file\E#) {
die "Error while requiring ${module}:\n$err_myconfig";
}
return $INC{$file};
}
# prioritized list of possible places for finding "CPAN/MyConfig.pm"
sub cpan_home_dir_candidates {
my @dirs;
my $old_v = $CPAN::Config->{load_module_verbosity};
$CPAN::Config->{load_module_verbosity} = q[none];
if ($CPAN::META->has_usable('File::HomeDir')) {
if ($^O ne 'darwin') {
push @dirs, File::HomeDir->my_data;
# my_data is ~/Library/Application Support on darwin,
# which causes issues in the toolchain.
}
push @dirs, File::HomeDir->my_home;
}
# Windows might not have HOME, so check it first
push @dirs, $ENV{HOME} if $ENV{HOME};
# Windows might have these instead
push( @dirs, File::Spec->catpath($ENV{HOMEDRIVE}, $ENV{HOMEPATH}, '') )
if $ENV{HOMEDRIVE} && $ENV{HOMEPATH};
push @dirs, $ENV{USERPROFILE} if $ENV{USERPROFILE};
$CPAN::Config->{load_module_verbosity} = $old_v;
my $dotcpan = $^O eq 'VMS' ? '_cpan' : '.cpan';
@dirs = map { File::Spec->catdir($_, $dotcpan) } grep { defined } @dirs;
return wantarray ? @dirs : $dirs[0];
}
sub load {
my($self, %args) = @_;
$CPAN::Be_Silent+=0; # protect against 'used only once'
$CPAN::Be_Silent++ if $args{be_silent}; # do not use; planned to be removed in 2011
my $do_init = delete $args{do_init} || 0;
my $make_myconfig = delete $args{make_myconfig};
$loading = 0 unless defined $loading;
my $configpm = require_myconfig_or_config;
my @miss = $self->missing_config_data;
CPAN->debug("do_init[$do_init]loading[$loading]miss[@miss]") if $CPAN::DEBUG;
return unless $do_init || @miss;
if (@miss==1 and $miss[0] eq "pushy_https" && !$do_init) {
$CPAN::Frontend->myprint(<<'END');
Starting with version 2.29 of the cpan shell, a new download mechanism
is the default which exclusively uses cpan.org as the host to download
from. The configuration variable pushy_https can be used to (de)select
the new mechanism. Please read more about it and make your choice
between the old and the new mechanism by running
o conf init pushy_https
Once you have done that and stored the config variable this dialog
will disappear.
END
return;
}
# I'm not how we'd ever wind up in a recursive loop, but I'm leaving
# this here for safety's sake -- dagolden, 2011-01-19
return if $loading;
local $loading = ($loading||0) + 1;
# Warn if we have a config file, but things were found missing
if ($configpm && @miss && !$do_init) {
if ($make_myconfig || ( ! -w $configpm && $configpm =~ m{CPAN/Config\.pm})) {
$configpm = make_new_config();
$CPAN::Frontend->myprint(<<END);
The system CPAN configuration file has provided some default values,
but you need to complete the configuration dialog for CPAN.pm.
Configuration will be written to
<<$configpm>>
END
}
else {
$CPAN::Frontend->myprint(<<END);
Sorry, we have to rerun the configuration dialog for CPAN.pm due to
some missing parameters. Configuration will be written to
<<$configpm>>
END
}
}
require CPAN::FirstTime;
return CPAN::FirstTime::init($configpm || make_new_config(), %args);
}
# Creates a new, empty config file at the preferred location
# Any existing will be renamed with a ".bak" suffix if possible
# If the file cannot be created, an exception is thrown
sub make_new_config {
my $configpm = _new_config_name();
my $configpmdir = File::Basename::dirname( $configpm );
File::Path::mkpath($configpmdir) unless -d $configpmdir;
if ( -w $configpmdir ) {
#_#_# following code dumped core on me with 5.003_11, a.k.
if( -f $configpm ) {
my $configpm_bak = "$configpm.bak";
unlink $configpm_bak if -f $configpm_bak;
if( rename $configpm, $configpm_bak ) {
$CPAN::Frontend->mywarn(<<END);
Old configuration file $configpm
moved to $configpm_bak
END
}
}
my $fh = FileHandle->new;
if ($fh->open(">$configpm")) {
$fh->print("1;\n");
return $configpm;
}
}
_die_cant_write_config($configpm);
}
sub _die_cant_write_config {
my ($configpm) = @_;
$CPAN::Frontend->mydie(<<"END");
WARNING: CPAN.pm is unable to write a configuration file. You
must be able to create and write to '$configpm'.
Aborting configuration.
END
}
# From candidate directories, we would like (in descending preference order):
# * the one that contains a MyConfig file
# * one that exists (even without MyConfig)
# * the first one on the list
sub cpan_home {
my @dirs = cpan_home_dir_candidates();
for my $d (@dirs) {
return $d if -f "$d/CPAN/MyConfig.pm";
}
for my $d (@dirs) {
return $d if -d $d;
}
return $dirs[0];
}
sub _new_config_name {
return File::Spec->catfile(cpan_home(), 'CPAN', 'MyConfig.pm');
}
# returns mandatory but missing entries in the Config
sub missing_config_data {
my(@miss);
for (
"auto_commit",
"build_cache",
"build_dir",
"cache_metadata",
"cpan_home",
"ftp_proxy",
#"gzip",
"http_proxy",
"index_expire",
#"inhibit_startup_message",
"keep_source_where",
#"make",
"make_arg",
"make_install_arg",
"makepl_arg",
"mbuild_arg",
"mbuild_install_arg",
($^O eq "MSWin32" ? "" : "mbuild_install_build_command"),
"mbuildpl_arg",
"no_proxy",
#"pager",
"prerequisites_policy",
"pushy_https",
"scan_cache",
#"tar",
#"unzip",
"urllist",
) {
next unless exists $keys{$_};
push @miss, $_ unless defined $CPAN::Config->{$_};
}
return @miss;
}
sub help {
$CPAN::Frontend->myprint(q[
Known options:
commit commit session changes to disk
defaults reload default config values from disk
help this help
init enter a dialog to set all or a set of parameters
Edit key values as in the following (the "o" is a literal letter o):
o conf build_cache 15
o conf build_dir "/foo/bar"
o conf urllist shift
o conf urllist unshift ftp://ftp.foo.bar/
o conf inhibit_startup_message 1
]);
1; #don't reprint CPAN::Config
}
sub cpl {
my($word,$line,$pos) = @_;
$word ||= "";
CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
my(@words) = split " ", substr($line,0,$pos+1);
if (
defined($words[2])
and
$words[2] =~ /list$/
and
(
@words == 3
||
@words == 4 && length($word)
)
) {
return grep /^\Q$word\E/, qw(splice shift unshift pop push);
} elsif (defined($words[2])
and
$words[2] eq "init"
and
(
@words == 3
||
@words >= 4 && length($word)
)) {
return sort grep /^\Q$word\E/, keys %keys;
} elsif (@words >= 4) {
return ();
}
my %seen;
my(@o_conf) = sort grep { !$seen{$_}++ }
keys %can,
keys %$CPAN::Config,
keys %keys;
return grep /^\Q$word\E/, @o_conf;
}
sub prefs_lookup {
my($self,$distro,$what) = @_;
if ($prefssupport{$what}) {
return $CPAN::Config->{$what} unless
$distro
and $distro->prefs
and $distro->prefs->{cpanconfig}
and defined $distro->prefs->{cpanconfig}{$what};
return $distro->prefs->{cpanconfig}{$what};
} else {
$CPAN::Frontend->mywarn("Warning: $what not yet officially ".
"supported for distroprefs, doing a normal lookup\n");
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.5012";
# formerly CPAN::HandleConfig was known as CPAN::Config
sub AUTOLOAD { ## no critic
my $class = shift; # e.g. in dh-make-perl: CPAN::Config
my($l) = $AUTOLOAD;
$CPAN::Frontend->mywarn("Dispatching deprecated method '$l' to CPAN::HandleConfig\n");
$l =~ s/.*:://;
CPAN::HandleConfig->$l(@_);
}
}
1;
__END__
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# End:
# vim: ts=4 sts=4 sw=4:

626
OGP64/usr/share/perl5/5.40/CPAN/Index.pm Normal file
View file

@ -0,0 +1,626 @@
package CPAN::Index;
use strict;
use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED $VERSION);
$VERSION = "2.29";
@CPAN::Index::ISA = qw(CPAN::Debug);
$LAST_TIME ||= 0;
$DATE_OF_03 ||= 0;
# use constant PROTOCOL => "2.0"; # commented out to avoid warning on upgrade from 1.57
sub PROTOCOL { 2.0 }
#-> sub CPAN::Index::force_reload ;
sub force_reload {
my($class) = @_;
$CPAN::Index::LAST_TIME = 0;
$class->reload(1);
}
my @indexbundle =
(
{
reader => "rd_authindex",
dir => "authors",
remotefile => '01mailrc.txt.gz',
shortlocalfile => '01mailrc.gz',
},
{
reader => "rd_modpacks",
dir => "modules",
remotefile => '02packages.details.txt.gz',
shortlocalfile => '02packag.gz',
},
{
reader => "rd_modlist",
dir => "modules",
remotefile => '03modlist.data.gz',
shortlocalfile => '03mlist.gz',
},
);
#-> sub CPAN::Index::reload ;
sub reload {
my($self,$force) = @_;
my $time = time;
# XXX check if a newer one is available. (We currently read it
# from time to time)
for ($CPAN::Config->{index_expire}) {
$_ = 0.001 unless $_ && $_ > 0.001;
}
unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
# debug here when CPAN doesn't seem to read the Metadata
require Carp;
Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
}
unless ($CPAN::META->{PROTOCOL}) {
$self->read_metadata_cache;
$CPAN::META->{PROTOCOL} ||= "1.0";
}
if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
# warn "Setting last_time to 0";
$LAST_TIME = 0; # No warning necessary
}
if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
and ! $force) {
# called too often
# CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
} elsif (0) {
# IFF we are developing, it helps to wipe out the memory
# between reloads, otherwise it is not what a user expects.
undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
$CPAN::META = CPAN->new;
} else {
my($debug,$t2);
local $LAST_TIME = $time;
local $CPAN::META->{PROTOCOL} = PROTOCOL;
my $needshort = $^O eq "dos";
INX: for my $indexbundle (@indexbundle) {
my $reader = $indexbundle->{reader};
my $localfile = $needshort ? $indexbundle->{shortlocalfile} : $indexbundle->{remotefile};
my $localpath = File::Spec->catfile($indexbundle->{dir}, $localfile);
my $remote = join "/", $indexbundle->{dir}, $indexbundle->{remotefile};
my $localized = $self->reload_x($remote, $localpath, $force);
$self->$reader($localized); # may die but we let the shell catch it
if ($CPAN::DEBUG){
$t2 = time;
$debug = "timing reading 01[".($t2 - $time)."]";
$time = $t2;
}
return if $CPAN::Signal; # this is sometimes lengthy
}
$self->write_metadata_cache;
if ($CPAN::DEBUG){
$t2 = time;
$debug .= "03[".($t2 - $time)."]";
$time = $t2;
}
CPAN->debug($debug) if $CPAN::DEBUG;
}
if ($CPAN::Config->{build_dir_reuse}) {
$self->reanimate_build_dir;
}
if (CPAN::_sqlite_running()) {
$CPAN::SQLite->reload(time => $time, force => $force)
if not $LAST_TIME;
}
$LAST_TIME = $time;
$CPAN::META->{PROTOCOL} = PROTOCOL;
}
#-> sub CPAN::Index::reanimate_build_dir ;
sub reanimate_build_dir {
my($self) = @_;
unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
return;
}
return if $HAVE_REANIMATED++;
my $d = $CPAN::Config->{build_dir};
my $dh = DirHandle->new;
opendir $dh, $d or return; # does not exist
my $dirent;
my $i = 0;
my $painted = 0;
my $restored = 0;
my $start = CPAN::FTP::_mytime();
my @candidates = map { $_->[0] }
sort { $b->[1] <=> $a->[1] }
map { [ $_, -M File::Spec->catfile($d,$_) ] }
grep {/(.+)\.yml$/ && -d File::Spec->catfile($d,$1)} readdir $dh;
if ( @candidates ) {
$CPAN::Frontend->myprint
(sprintf("Reading %d yaml file%s from %s/\n",
scalar @candidates,
@candidates==1 ? "" : "s",
$CPAN::Config->{build_dir}
));
DISTRO: for $i (0..$#candidates) {
my $dirent = $candidates[$i];
my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent), {loadblessed => 1})};
if ($@) {
warn "Error while parsing file '$dirent'; error: '$@'";
next DISTRO;
}
my $c = $y->[0];
if ($c && $c->{perl} && $c->{distribution} && CPAN->_perl_fingerprint($c->{perl})) {
my $key = $c->{distribution}{ID};
for my $k (keys %{$c->{distribution}}) {
if ($c->{distribution}{$k}
&& ref $c->{distribution}{$k}
&& UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
$c->{distribution}{$k}{COMMANDID} = $i - @candidates;
}
}
#we tried to restore only if element already
#exists; but then we do not work with metadata
#turned off.
my $do
= $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
= $c->{distribution};
for my $skipper (qw(
badtestcnt
configure_requires_later
configure_requires_later_for
force_update
later
later_for
notest
should_report
sponsored_mods
prefs
negative_prefs_cache
)) {
delete $do->{$skipper};
}
if ($do->can("tested_ok_but_not_installed")) {
if ($do->tested_ok_but_not_installed) {
$CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
} else {
next DISTRO;
}
}
$restored++;
}
$i++;
while (($painted/76) < ($i/@candidates)) {
$CPAN::Frontend->myprint(".");
$painted++;
}
}
}
else {
$CPAN::Frontend->myprint("Build_dir empty, nothing to restore\n");
}
my $took = CPAN::FTP::_mytime() - $start;
$CPAN::Frontend->myprint(sprintf(
"DONE\nRestored the state of %s (in %.4f secs)\n",
$restored || "none",
$took,
));
}
#-> sub CPAN::Index::reload_x ;
sub reload_x {
my($cl,$wanted,$localname,$force) = @_;
$force |= 2; # means we're dealing with an index here
CPAN::HandleConfig->load; # we should guarantee loading wherever
# we rely on Config XXX
$localname ||= $wanted;
my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
$localname);
if (
-f $abs_wanted &&
-M $abs_wanted < $CPAN::Config->{'index_expire'} &&
!($force & 1)
) {
my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
$cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
qq{day$s. I\'ll use that.});
return $abs_wanted;
} else {
$force |= 1; # means we're quite serious about it.
}
return CPAN::FTP->localize($wanted,$abs_wanted,$force);
}
#-> sub CPAN::Index::rd_authindex ;
sub rd_authindex {
my($cl, $index_target) = @_;
return unless defined $index_target;
return if CPAN::_sqlite_running();
my @lines;
$CPAN::Frontend->myprint("Reading '$index_target'\n");
local(*FH);
tie *FH, 'CPAN::Tarzip', $index_target;
local($/) = "\n";
local($_);
push @lines, split /\012/ while <FH>;
my $i = 0;
my $painted = 0;
foreach (@lines) {
my($userid,$fullname,$email) =
m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
$fullname ||= $email;
if ($userid && $fullname && $email) {
my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
$userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
} else {
CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
}
$i++;
while (($painted/76) < ($i/@lines)) {
$CPAN::Frontend->myprint(".");
$painted++;
}
return if $CPAN::Signal;
}
$CPAN::Frontend->myprint("DONE\n");
}
sub userid {
my($self,$dist) = @_;
$dist = $self->{'id'} unless defined $dist;
my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
$ret;
}
#-> sub CPAN::Index::rd_modpacks ;
sub rd_modpacks {
my($self, $index_target) = @_;
return unless defined $index_target;
return if CPAN::_sqlite_running();
$CPAN::Frontend->myprint("Reading '$index_target'\n");
my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
local $_;
CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
my $slurp = "";
my $chunk;
while (my $bytes = $fh->READ(\$chunk,8192)) {
$slurp.=$chunk;
}
my @lines = split /\012/, $slurp;
CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
undef $fh;
# read header
my($line_count,$last_updated);
while (@lines) {
my $shift = shift(@lines);
last if $shift =~ /^\s*$/;
$shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
$shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
}
CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
my $errors = 0;
if (not defined $line_count) {
$CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
Please check the validity of the index file by comparing it to more
than one CPAN mirror. I'll continue but problems seem likely to
happen.\a
});
$errors++;
$CPAN::Frontend->mysleep(5);
} elsif ($line_count != scalar @lines) {
$CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
contains a Line-Count header of %d but I see %d lines there. Please
check the validity of the index file by comparing it to more than one
CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
$index_target, $line_count, scalar(@lines));
}
if (not defined $last_updated) {
$CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
Please check the validity of the index file by comparing it to more
than one CPAN mirror. I'll continue but problems seem likely to
happen.\a
});
$errors++;
$CPAN::Frontend->mysleep(5);
} else {
$CPAN::Frontend
->myprint(sprintf qq{ Database was generated on %s\n},
$last_updated);
$DATE_OF_02 = $last_updated;
my $age = time;
if ($CPAN::META->has_inst('HTTP::Date')) {
require HTTP::Date;
$age -= HTTP::Date::str2time($last_updated);
} else {
$CPAN::Frontend->mywarn(" HTTP::Date not available\n");
require Time::Local;
my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
$d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
$age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
}
$age /= 3600*24;
if ($age > 30) {
$CPAN::Frontend
->mywarn(sprintf
qq{Warning: This index file is %d days old.
Please check the host you chose as your CPAN mirror for staleness.
I'll continue but problems seem likely to happen.\a\n},
$age);
} elsif ($age < -1) {
$CPAN::Frontend
->mywarn(sprintf
qq{Warning: Your system date is %d days behind this index file!
System time: %s
Timestamp index file: %s
Please fix your system time, problems with the make command expected.\n},
-$age,
scalar gmtime,
$DATE_OF_02,
);
}
}
# A necessity since we have metadata_cache: delete what isn't
# there anymore
my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
my(%exists);
my $i = 0;
my $painted = 0;
LINE: foreach (@lines) {
# before 1.56 we split into 3 and discarded the rest. From
# 1.57 we assign remaining text to $comment thus allowing to
# influence isa_perl
my($mod,$version,$dist,$comment) = split " ", $_, 4;
unless ($mod && defined $version && $dist) {
require Dumpvalue;
my $dv = Dumpvalue->new(tick => '"');
$CPAN::Frontend->mywarn(sprintf "Could not split line[%s]\n", $dv->stringify($_));
if ($errors++ >= 5){
$CPAN::Frontend->mydie("Giving up parsing your $index_target, too many errors");
}
next LINE;
}
my($bundle,$id,$userid);
if ($mod eq 'CPAN' &&
! (
CPAN::Queue->exists('Bundle::CPAN') ||
CPAN::Queue->exists('CPAN')
)
) {
local($^W)= 0;
if ($version > $CPAN::VERSION) {
$CPAN::Frontend->mywarn(qq{
New CPAN.pm version (v$version) available.
[Currently running version is v$CPAN::VERSION]
You might want to try
install CPAN
reload cpan
to both upgrade CPAN.pm and run the new version without leaving
the current session.
}); #});
$CPAN::Frontend->mysleep(2);
$CPAN::Frontend->myprint(qq{\n});
}
last if $CPAN::Signal;
} elsif ($mod =~ /^Bundle::(.*)/) {
$bundle = $1;
}
if ($bundle) {
$id = $CPAN::META->instance('CPAN::Bundle',$mod);
# Let's make it a module too, because bundles have so much
# in common with modules.
# Changed in 1.57_63: seems like memory bloat now without
# any value, so commented out
# $CPAN::META->instance('CPAN::Module',$mod);
} else {
# instantiate a module object
$id = $CPAN::META->instance('CPAN::Module',$mod);
}
# Although CPAN prohibits same name with different version the
# indexer may have changed the version for the same distro
# since the last time ("Force Reindexing" feature)
if ($id->cpan_file ne $dist
||
$id->cpan_version ne $version
) {
$userid = $id->userid || $self->userid($dist);
$id->set(
'CPAN_USERID' => $userid,
'CPAN_VERSION' => $version,
'CPAN_FILE' => $dist,
);
}
# instantiate a distribution object
if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
# we do not need CONTAINSMODS unless we do something with
# this dist, so we better produce it on demand.
## my $obj = $CPAN::META->instance(
## 'CPAN::Distribution' => $dist
## );
## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
} else {
$CPAN::META->instance(
'CPAN::Distribution' => $dist
)->set(
'CPAN_USERID' => $userid,
'CPAN_COMMENT' => $comment,
);
}
if ($secondtime) {
for my $name ($mod,$dist) {
# $self->debug("exists name[$name]") if $CPAN::DEBUG;
$exists{$name} = undef;
}
}
$i++;
while (($painted/76) < ($i/@lines)) {
$CPAN::Frontend->myprint(".");
$painted++;
}
return if $CPAN::Signal;
}
$CPAN::Frontend->myprint("DONE\n");
if ($secondtime) {
for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
for my $o ($CPAN::META->all_objects($class)) {
next if exists $exists{$o->{ID}};
$CPAN::META->delete($class,$o->{ID});
# CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
# if $CPAN::DEBUG;
}
}
}
}
#-> sub CPAN::Index::rd_modlist ;
sub rd_modlist {
my($cl,$index_target) = @_;
return unless defined $index_target;
return if CPAN::_sqlite_running();
$CPAN::Frontend->myprint("Reading '$index_target'\n");
my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
local $_;
my $slurp = "";
my $chunk;
while (my $bytes = $fh->READ(\$chunk,8192)) {
$slurp.=$chunk;
}
my @eval2 = split /\012/, $slurp;
while (@eval2) {
my $shift = shift(@eval2);
if ($shift =~ /^Date:\s+(.*)/) {
if ($DATE_OF_03 eq $1) {
$CPAN::Frontend->myprint("Unchanged.\n");
return;
}
($DATE_OF_03) = $1;
}
last if $shift =~ /^\s*$/;
}
push @eval2, q{CPAN::Modulelist->data;};
local($^W) = 0;
my($compmt) = Safe->new("CPAN::Safe1");
my($eval2) = join("\n", @eval2);
CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
my $ret = $compmt->reval($eval2);
Carp::confess($@) if $@;
return if $CPAN::Signal;
my $i = 0;
my $until = keys(%$ret);
my $painted = 0;
CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
for (sort keys %$ret) {
my $obj = $CPAN::META->instance("CPAN::Module",$_);
delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
$obj->set(%{$ret->{$_}});
$i++;
while (($painted/76) < ($i/$until)) {
$CPAN::Frontend->myprint(".");
$painted++;
}
return if $CPAN::Signal;
}
$CPAN::Frontend->myprint("DONE\n");
}
#-> sub CPAN::Index::write_metadata_cache ;
sub write_metadata_cache {
my($self) = @_;
return unless $CPAN::Config->{'cache_metadata'};
return if CPAN::_sqlite_running();
return unless $CPAN::META->has_usable("Storable");
my $cache;
foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
CPAN::Distribution)) {
$cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
}
my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
$cache->{last_time} = $LAST_TIME;
$cache->{DATE_OF_02} = $DATE_OF_02;
$cache->{PROTOCOL} = PROTOCOL;
$CPAN::Frontend->myprint("Writing $metadata_file\n");
eval { Storable::nstore($cache, $metadata_file) };
$CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
}
#-> sub CPAN::Index::read_metadata_cache ;
sub read_metadata_cache {
my($self) = @_;
return unless $CPAN::Config->{'cache_metadata'};
return if CPAN::_sqlite_running();
return unless $CPAN::META->has_usable("Storable");
my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
return unless -r $metadata_file and -f $metadata_file;
$CPAN::Frontend->myprint("Reading '$metadata_file'\n");
my $cache;
eval { $cache = Storable::retrieve($metadata_file) };
$CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) {
$LAST_TIME = 0;
return;
}
if (exists $cache->{PROTOCOL}) {
if (PROTOCOL > $cache->{PROTOCOL}) {
$CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
"with protocol v%s, requiring v%s\n",
$cache->{PROTOCOL},
PROTOCOL)
);
return;
}
} else {
$CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
"with protocol v1.0\n");
return;
}
my $clcnt = 0;
my $idcnt = 0;
while(my($class,$v) = each %$cache) {
next unless $class =~ /^CPAN::/;
$CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
while (my($id,$ro) = each %$v) {
$CPAN::META->{readwrite}{$class}{$id} ||=
$class->new(ID=>$id, RO=>$ro);
$idcnt++;
}
$clcnt++;
}
unless ($clcnt) { # sanity check
$CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
return;
}
if ($idcnt < 1000) {
$CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
"in $metadata_file\n");
return;
}
$CPAN::META->{PROTOCOL} ||=
$cache->{PROTOCOL}; # reading does not up or downgrade, but it
# does initialize to some protocol
$LAST_TIME = $cache->{last_time};
$DATE_OF_02 = $cache->{DATE_OF_02};
$CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
return;
}
1;

224
OGP64/usr/share/perl5/5.40/CPAN/InfoObj.pm Normal file
View file

@ -0,0 +1,224 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::InfoObj;
use strict;
use CPAN::Debug;
@CPAN::InfoObj::ISA = qw(CPAN::Debug);
use Cwd qw(chdir);
use vars qw(
$VERSION
);
$VERSION = "5.5";
sub ro {
my $self = shift;
exists $self->{RO} and return $self->{RO};
}
#-> sub CPAN::InfoObj::cpan_userid
sub cpan_userid {
my $self = shift;
my $ro = $self->ro;
if ($ro) {
return $ro->{CPAN_USERID} || "N/A";
} else {
$self->debug("ID[$self->{ID}]");
# N/A for bundles found locally
return "N/A";
}
}
sub id { shift->{ID}; }
#-> sub CPAN::InfoObj::new ;
sub new {
my $this = bless {}, shift;
%$this = @_;
$this
}
# The set method may only be used by code that reads index data or
# otherwise "objective" data from the outside world. All session
# related material may do anything else with instance variables but
# must not touch the hash under the RO attribute. The reason is that
# the RO hash gets written to Metadata file and is thus persistent.
#-> sub CPAN::InfoObj::safe_chdir ;
sub safe_chdir {
my($self,$todir) = @_;
# we die if we cannot chdir and we are debuggable
Carp::confess("safe_chdir called without todir argument")
unless defined $todir and length $todir;
if (chdir $todir) {
$self->debug(sprintf "changed directory to %s", CPAN::anycwd())
if $CPAN::DEBUG;
} else {
if (-e $todir) {
unless (-x $todir) {
unless (chmod 0755, $todir) {
my $cwd = CPAN::anycwd();
$CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
"permission to change the permission; cannot ".
"chdir to '$todir'\n");
$CPAN::Frontend->mysleep(5);
$CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
qq{to todir[$todir]: $!});
}
}
} else {
$CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
}
if (chdir $todir) {
$self->debug(sprintf "changed directory to %s", CPAN::anycwd())
if $CPAN::DEBUG;
} else {
my $cwd = CPAN::anycwd();
$CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
qq{to todir[$todir] (a chmod has been issued): $!});
}
}
}
#-> sub CPAN::InfoObj::set ;
sub set {
my($self,%att) = @_;
my $class = ref $self;
# This must be ||=, not ||, because only if we write an empty
# reference, only then the set method will write into the readonly
# area. But for Distributions that spring into existence, maybe
# because of a typo, we do not like it that they are written into
# the readonly area and made permanent (at least for a while) and
# that is why we do not "allow" other places to call ->set.
unless ($self->id) {
CPAN->debug("Bug? Empty ID, rejecting");
return;
}
my $ro = $self->{RO} =
$CPAN::META->{readonly}{$class}{$self->id} ||= {};
while (my($k,$v) = each %att) {
$ro->{$k} = $v;
}
}
#-> sub CPAN::InfoObj::as_glimpse ;
sub as_glimpse {
my($self) = @_;
my(@m);
my $class = ref($self);
$class =~ s/^CPAN:://;
my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
push @m, sprintf "%-15s %s\n", $class, $id;
join "", @m;
}
#-> sub CPAN::InfoObj::as_string ;
sub as_string {
my($self) = @_;
my(@m);
my $class = ref($self);
$class =~ s/^CPAN:://;
push @m, $class, " id = $self->{ID}\n";
my $ro;
unless ($ro = $self->ro) {
if (substr($self->{ID},-1,1) eq ".") { # directory
$ro = +{};
} else {
$CPAN::Frontend->mywarn("Unknown object $self->{ID}\n");
$CPAN::Frontend->mysleep(5);
return;
}
}
for (sort keys %$ro) {
# next if m/^(ID|RO)$/;
my $extra = "";
if ($_ eq "CPAN_USERID") {
$extra .= " (";
$extra .= $self->fullname;
my $email; # old perls!
if ($email = $CPAN::META->instance("CPAN::Author",
$self->cpan_userid
)->email) {
$extra .= " <$email>";
} else {
$extra .= " <no email>";
}
$extra .= ")";
} elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
push @m, sprintf " %-12s %s\n", $_, $self->fullname;
next;
}
next unless defined $ro->{$_};
push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra;
}
KEY: for (sort keys %$self) {
next if m/^(ID|RO)$/;
unless (defined $self->{$_}) {
delete $self->{$_};
next KEY;
}
if (ref($self->{$_}) eq "ARRAY") {
push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
} elsif (ref($self->{$_}) eq "HASH") {
my $value;
if (/^CONTAINSMODS$/) {
$value = join(" ",sort keys %{$self->{$_}});
} elsif (/^prereq_pm$/) {
my @value;
my $v = $self->{$_};
for my $x (sort keys %$v) {
my @svalue;
for my $y (sort keys %{$v->{$x}}) {
push @svalue, "$y=>$v->{$x}{$y}";
}
push @value, "$x\:" . join ",", @svalue if @svalue;
}
$value = join ";", @value;
} else {
$value = $self->{$_};
}
push @m, sprintf(
" %-12s %s\n",
$_,
$value,
);
} else {
push @m, sprintf " %-12s %s\n", $_, $self->{$_};
}
}
join "", @m, "\n";
}
#-> sub CPAN::InfoObj::fullname ;
sub fullname {
my($self) = @_;
$CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
}
#-> sub CPAN::InfoObj::dump ;
sub dump {
my($self, $what) = @_;
unless ($CPAN::META->has_inst("Data::Dumper")) {
$CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
}
local $Data::Dumper::Sortkeys;
$Data::Dumper::Sortkeys = 1;
my $out = Data::Dumper::Dumper($what ? eval $what : $self);
if (length $out > 100000) {
my $fh_pager = FileHandle->new;
local($SIG{PIPE}) = "IGNORE";
my $pager = $CPAN::Config->{'pager'} || "cat";
$fh_pager->open("|$pager")
or die "Could not open pager $pager\: $!";
$fh_pager->print($out);
close $fh_pager;
} else {
$CPAN::Frontend->myprint($out);
}
}
1;

136
OGP64/usr/share/perl5/5.40/CPAN/Kwalify.pm Normal file
View file

@ -0,0 +1,136 @@
=head1 NAME
CPAN::Kwalify - Interface between CPAN.pm and Kwalify.pm
=head1 SYNOPSIS
use CPAN::Kwalify;
validate($schema_name, $data, $file, $doc);
=head1 DESCRIPTION
=over
=item _validate($schema_name, $data, $file, $doc)
$schema_name is the name of a supported schema. Currently only
C<distroprefs> is supported. $data is the data to be validated. $file
is the absolute path to the file the data are coming from. $doc is the
index of the document within $doc that is to be validated. The last
two arguments are only there for better error reporting.
Relies on being called from within CPAN.pm.
Dies if something fails. Does not return anything useful.
=item yaml($schema_name)
Returns the YAML text of that schema. Dies if something fails.
=back
=head1 AUTHOR
Andreas Koenig C<< <andk@cpan.org> >>
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<http://www.perl.com/perl/misc/Artistic.html>
=cut
use strict;
package CPAN::Kwalify;
use vars qw($VERSION $VAR1);
$VERSION = "5.50";
use File::Spec ();
my %vcache = ();
my $schema_loaded = {};
sub _validate {
my($schema_name,$data,$abs,$y) = @_;
my $yaml_module = CPAN->_yaml_module;
if (
$CPAN::META->has_inst($yaml_module)
&&
$CPAN::META->has_inst("Kwalify")
) {
my $load = UNIVERSAL::can($yaml_module,"Load");
unless ($schema_loaded->{$schema_name}) {
eval {
my $schema_yaml = yaml($schema_name);
$schema_loaded->{$schema_name} = $load->($schema_yaml);
};
if ($@) {
# we know that YAML.pm 0.62 cannot parse the schema,
# so we try a fallback
my $content = do {
my $path = __FILE__;
$path =~ s/\.pm$//;
$path = File::Spec->catfile($path, "$schema_name.dd");
local *FH;
open FH, $path or die "Could not open '$path': $!";
local $/;
<FH>;
};
$VAR1 = undef;
eval $content;
if (my $err = $@) {
die "parsing of '$schema_name.dd' failed: $err";
}
$schema_loaded->{$schema_name} = $VAR1;
}
}
}
if (my $schema = $schema_loaded->{$schema_name}) {
my $mtime = (stat $abs)[9];
for my $k (keys %{$vcache{$abs}}) {
delete $vcache{$abs}{$k} unless $k eq $mtime;
}
return if $vcache{$abs}{$mtime}{$y}++;
eval { Kwalify::validate($schema, $data) };
if (my $err = $@) {
my $info = {}; yaml($schema_name, info => $info);
die "validation of distropref '$abs'[$y] against schema '$info->{path}' failed: $err";
}
}
}
sub _clear_cache {
%vcache = ();
}
sub yaml {
my($schema_name, %opt) = @_;
my $content = do {
my $path = __FILE__;
$path =~ s/\.pm$//;
$path = File::Spec->catfile($path, "$schema_name.yml");
if ($opt{info}) {
$opt{info}{path} = $path;
}
local *FH;
open FH, $path or die "Could not open '$path': $!";
local $/;
<FH>;
};
return $content;
}
1;
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# End:

150
OGP64/usr/share/perl5/5.40/CPAN/Kwalify/distroprefs.dd Normal file
View file

@ -0,0 +1,150 @@
$VAR1 = {
"mapping" => {
"comment" => {
"type" => "text"
},
"cpanconfig" => {
"mapping" => {
"=" => {
"type" => "text"
}
},
"type" => "map"
},
"depends" => {
"mapping" => {
"build_requires" => {
"mapping" => {
"=" => {
"type" => "text"
}
},
"type" => "map"
},
"configure_requires" => {},
"requires" => {}
},
"type" => "map"
},
"disabled" => {
"enum" => [
0,
1
],
"type" => "int"
},
"features" => {
"sequence" => [
{
"type" => "text"
}
],
"type" => "seq"
},
"goto" => {
"type" => "text"
},
"install" => {
"mapping" => {
"args" => {
"sequence" => [
{
"type" => "text"
}
],
"type" => "seq"
},
"commandline" => {
"type" => "text"
},
"eexpect" => {
"mapping" => {
"mode" => {
"enum" => [
"deterministic",
"anyorder"
],
"type" => "text"
},
"reuse" => {
"type" => "int"
},
"talk" => {
"sequence" => [
{
"type" => "text"
}
],
"type" => "seq"
},
"timeout" => {
"type" => "number"
}
},
"type" => "map"
},
"env" => {
"mapping" => {
"=" => {
"type" => "text"
}
},
"type" => "map"
},
"expect" => {
"sequence" => [
{
"type" => "text"
}
],
"type" => "seq"
}
},
"type" => "map"
},
"make" => {},
"match" => {
"mapping" => {
"distribution" => {
"type" => "text"
},
"env" => {
"mapping" => {
"=" => {
"type" => "text"
}
},
"type" => "map"
},
"module" => {
"type" => "text"
},
"perl" => {
"type" => "text"
},
"perlconfig" => {}
},
"type" => "map"
},
"patches" => {
"sequence" => [
{
"type" => "text"
}
],
"type" => "seq"
},
"pl" => {},
"reminder" => {
"type" => "text"
},
"test" => {}
},
"type" => "map"
};
$VAR1->{"mapping"}{"depends"}{"mapping"}{"configure_requires"} = $VAR1->{"mapping"}{"depends"}{"mapping"}{"build_requires"};
$VAR1->{"mapping"}{"depends"}{"mapping"}{"requires"} = $VAR1->{"mapping"}{"depends"}{"mapping"}{"build_requires"};
$VAR1->{"mapping"}{"make"} = $VAR1->{"mapping"}{"install"};
$VAR1->{"mapping"}{"match"}{"mapping"}{"perlconfig"} = $VAR1->{"mapping"}{"match"}{"mapping"}{"env"};
$VAR1->{"mapping"}{"pl"} = $VAR1->{"mapping"}{"install"};
$VAR1->{"mapping"}{"test"} = $VAR1->{"mapping"}{"install"};

92
OGP64/usr/share/perl5/5.40/CPAN/Kwalify/distroprefs.yml Normal file
View file

@ -0,0 +1,92 @@
---
type: map
mapping:
comment:
type: text
depends:
type: map
mapping:
configure_requires:
&requires_common
type: map
mapping:
=:
type: text
build_requires: *requires_common
requires: *requires_common
match:
type: map
mapping:
distribution:
type: text
module:
type: text
perl:
type: text
perlconfig:
&matchhash_common
type: map
mapping:
=:
type: text
env: *matchhash_common
install:
&args_env_expect
type: map
mapping:
args:
type: seq
sequence:
- type: text
commandline:
type: text
env:
type: map
mapping:
=:
type: text
expect:
type: seq
sequence:
- type: text
eexpect:
type: map
mapping:
mode:
type: text
enum:
- deterministic
- anyorder
timeout:
type: number
reuse:
type: int
talk:
type: seq
sequence:
- type: text
make: *args_env_expect
pl: *args_env_expect
test: *args_env_expect
patches:
type: seq
sequence:
- type: text
disabled:
type: int
enum:
- 0
- 1
goto:
type: text
cpanconfig:
type: map
mapping:
=:
type: text
features:
type: seq
sequence:
- type: text
reminder:
type: text

62
OGP64/usr/share/perl5/5.40/CPAN/LWP/UserAgent.pm Normal file
View file

@ -0,0 +1,62 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::LWP::UserAgent;
use strict;
use vars qw(@ISA $USER $PASSWD $SETUPDONE);
use CPAN::HTTP::Credentials;
# we delay requiring LWP::UserAgent and setting up inheritance until we need it
$CPAN::LWP::UserAgent::VERSION = $CPAN::LWP::UserAgent::VERSION = "1.9601";
sub config {
return if $SETUPDONE;
if ($CPAN::META->has_usable('LWP::UserAgent')) {
require LWP::UserAgent;
@ISA = qw(Exporter LWP::UserAgent); ## no critic
$SETUPDONE++;
} else {
$CPAN::Frontend->mywarn(" LWP::UserAgent not available\n");
}
}
sub get_basic_credentials {
my($self, $realm, $uri, $proxy) = @_;
if ( $proxy ) {
return CPAN::HTTP::Credentials->get_proxy_credentials();
} else {
return CPAN::HTTP::Credentials->get_non_proxy_credentials();
}
}
sub no_proxy {
my ( $self, $no_proxy ) = @_;
return $self->SUPER::no_proxy( split(',',$no_proxy) );
}
# mirror(): Its purpose is to deal with proxy authentication. When we
# call SUPER::mirror, we really call the mirror method in
# LWP::UserAgent. LWP::UserAgent will then call
# $self->get_basic_credentials or some equivalent and this will be
# $self->dispatched to our own get_basic_credentials method.
# Our own get_basic_credentials sets $USER and $PASSWD, two globals.
# 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
# although we have gone through our get_basic_credentials, the proxy
# server refuses to connect. This could be a case where the username or
# password has changed in the meantime, so I'm trying once again without
# $USER and $PASSWD to give the get_basic_credentials routine another
# chance to set $USER and $PASSWD.
sub mirror {
my($self,$url,$aslocal) = @_;
my $result = $self->SUPER::mirror($url,$aslocal);
if ($result->code == 407) {
CPAN::HTTP::Credentials->clear_credentials;
$result = $self->SUPER::mirror($url,$aslocal);
}
$result;
}
1;

1176
OGP64/usr/share/perl5/5.40/CPAN/Meta.pm Normal file
View file

File diff suppressed because it is too large Load diff

1657
OGP64/usr/share/perl5/5.40/CPAN/Meta/Converter.pm Normal file
View file

File diff suppressed because it is too large Load diff

153
OGP64/usr/share/perl5/5.40/CPAN/Meta/Feature.pm Normal file
View file

@ -0,0 +1,153 @@
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Feature;
our $VERSION = '2.150010';
use CPAN::Meta::Prereqs;
#pod =head1 DESCRIPTION
#pod
#pod A CPAN::Meta::Feature object describes an optional feature offered by a CPAN
#pod distribution and specified in the distribution's F<META.json> (or F<META.yml>)
#pod file.
#pod
#pod For the most part, this class will only be used when operating on the result of
#pod the C<feature> or C<features> methods on a L<CPAN::Meta> object.
#pod
#pod =method new
#pod
#pod my $feature = CPAN::Meta::Feature->new( $identifier => \%spec );
#pod
#pod This returns a new Feature object. The C<%spec> argument to the constructor
#pod should be the same as the value of the C<optional_feature> entry in the
#pod distmeta. It must contain entries for C<description> and C<prereqs>.
#pod
#pod =cut
sub new {
my ($class, $identifier, $spec) = @_;
my %guts = (
identifier => $identifier,
description => $spec->{description},
prereqs => CPAN::Meta::Prereqs->new($spec->{prereqs}),
);
bless \%guts => $class;
}
#pod =method identifier
#pod
#pod This method returns the feature's identifier.
#pod
#pod =cut
sub identifier { $_[0]{identifier} }
#pod =method description
#pod
#pod This method returns the feature's long description.
#pod
#pod =cut
sub description { $_[0]{description} }
#pod =method prereqs
#pod
#pod This method returns the feature's prerequisites as a L<CPAN::Meta::Prereqs>
#pod object.
#pod
#pod =cut
sub prereqs { $_[0]{prereqs} }
1;
# ABSTRACT: an optional feature provided by a CPAN distribution
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::Feature - an optional feature provided by a CPAN distribution
=head1 VERSION
version 2.150010
=head1 DESCRIPTION
A CPAN::Meta::Feature object describes an optional feature offered by a CPAN
distribution and specified in the distribution's F<META.json> (or F<META.yml>)
file.
For the most part, this class will only be used when operating on the result of
the C<feature> or C<features> methods on a L<CPAN::Meta> object.
=head1 METHODS
=head2 new
my $feature = CPAN::Meta::Feature->new( $identifier => \%spec );
This returns a new Feature object. The C<%spec> argument to the constructor
should be the same as the value of the C<optional_feature> entry in the
distmeta. It must contain entries for C<description> and C<prereqs>.
=head2 identifier
This method returns the feature's identifier.
=head2 description
This method returns the feature's long description.
=head2 prereqs
This method returns the feature's prerequisites as a L<CPAN::Meta::Prereqs>
object.
=head1 BUGS
Please report any bugs or feature using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.
=head1 AUTHORS
=over 4
=item *
David Golden <dagolden@cpan.org>
=item *
Ricardo Signes <rjbs@cpan.org>
=item *
Adam Kennedy <adamk@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__
# vim: ts=2 sts=2 sw=2 et :

320
OGP64/usr/share/perl5/5.40/CPAN/Meta/History.pm Normal file
View file

@ -0,0 +1,320 @@
# vi:tw=72
use 5.006;
use strict;
use warnings;
package CPAN::Meta::History;
our $VERSION = '2.150010';
1;
# ABSTRACT: history of CPAN Meta Spec changes
__END__
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::History - history of CPAN Meta Spec changes
=head1 VERSION
version 2.150010
=head1 DESCRIPTION
The CPAN Meta Spec has gone through several iterations. It was
originally written in HTML and later revised into POD (though published
in HTML generated from the POD). Fields were added, removed or changed,
sometimes by design and sometimes to reflect real-world usage after the
fact.
This document reconstructs the history of the CPAN Meta Spec based on
change logs, repository commit messages and the published HTML files.
In some cases, particularly prior to version 1.2, the exact version
when certain fields were introduced or changed is inconsistent between
sources. When in doubt, the published HTML files for versions 1.0 to
1.4 as they existed when version 2 was developed are used as the
definitive source.
Starting with version 2, the specification document is part of the
CPAN-Meta distribution and will be published on CPAN as
L<CPAN::Meta::Spec>.
Going forward, specification version numbers will be integers and
decimal portions will correspond to a release date for the CPAN::Meta
library.
=head1 HISTORY
=head2 Version 2
April 2010
=over
=item *
Revised spec examples as perl data structures rather than YAML
=item *
Switched to JSON serialization from YAML
=item *
Specified allowed version number formats
=item *
Replaced 'requires', 'build_requires', 'configure_requires',
'recommends' and 'conflicts' with new 'prereqs' data structure divided
by I<phase> (configure, build, test, runtime, etc.) and I<relationship>
(requires, recommends, suggests, conflicts)
=item *
Added support for 'develop' phase for requirements for maintaining
a list of authoring tools
=item *
Changed 'license' to a list and revised the set of valid licenses
=item *
Made 'dynamic_config' mandatory to reduce confusion
=item *
Changed 'resources' subkey 'repository' to a hash that clarifies
repository type, url for browsing and url for checkout
=item *
Changed 'resources' subkey 'bugtracker' to a hash for either web
or mailto resource
=item *
Changed specification of 'optional_features':
=over
=item *
Added formal specification and usage guide instead of just example
=item *
Changed to use new prereqs data structure instead of individual keys
=back
=item *
Clarified intended use of 'author' as generalized contact list
=item *
Added 'release_status' field to indicate stable, testing or unstable
status to provide hints to indexers
=item *
Added 'description' field for a longer description of the distribution
=item *
Formalized use of "x_" or "X_" for all custom keys not listed in the
official spec
=back
=head2 Version 1.4
June 2008
=over
=item *
Noted explicit support for 'perl' in prerequisites
=item *
Added 'configure_requires' prerequisite type
=item *
Changed 'optional_features'
=over
=item *
Example corrected to show map of maps instead of list of maps
(though descriptive text said 'map' even in v1.3)
=item *
Removed 'requires_packages', 'requires_os' and 'excluded_os'
as valid subkeys
=back
=back
=head2 Version 1.3
November 2006
=over
=item *
Added 'no_index' subkey 'directory' and removed 'dir' to match actual
usage in the wild
=item *
Added a 'repository' subkey to 'resources'
=back
=head2 Version 1.2
August 2005
=over
=item *
Re-wrote and restructured spec in POD syntax
=item *
Changed 'name' to be mandatory
=item *
Changed 'generated_by' to be mandatory
=item *
Changed 'license' to be mandatory
=item *
Added version range specifications for prerequisites
=item *
Added required 'abstract' field
=item *
Added required 'author' field
=item *
Added required 'meta-spec' field to define 'version' (and 'url') of the
CPAN Meta Spec used for metadata
=item *
Added 'provides' field
=item *
Added 'no_index' field and deprecated 'private' field. 'no_index'
subkeys include 'file', 'dir', 'package' and 'namespace'
=item *
Added 'keywords' field
=item *
Added 'resources' field with subkeys 'homepage', 'license', and
'bugtracker'
=item *
Added 'optional_features' field as an alternate under 'recommends'.
Includes 'description', 'requires', 'build_requires', 'conflicts',
'requires_packages', 'requires_os' and 'excluded_os' as valid subkeys
=item *
Removed 'license_uri' field
=back
=head2 Version 1.1
May 2003
=over
=item *
Changed 'version' to be mandatory
=item *
Added 'private' field
=item *
Added 'license_uri' field
=back
=head2 Version 1.0
March 2003
=over
=item *
Original release (in HTML format only)
=item *
Included 'name', 'version', 'license', 'distribution_type', 'requires',
'recommends', 'build_requires', 'conflicts', 'dynamic_config',
'generated_by'
=back
=head1 AUTHORS
=over 4
=item *
David Golden <dagolden@cpan.org>
=item *
Ricardo Signes <rjbs@cpan.org>
=item *
Adam Kennedy <adamk@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

247
OGP64/usr/share/perl5/5.40/CPAN/Meta/History/Meta_1_0.pod Normal file
View file

@ -0,0 +1,247 @@
=for :stopwords DOAP RDF
=head1 NAME
CPAN::Meta::History::Meta_1_0 - Version 1.0 metadata specification for META.yml
=head1 PREFACE
This is a historical copy of the version 1.0 specification for F<META.yml>
files, copyright by Ken Williams and licensed under the same terms as Perl
itself.
Modifications from the original:
=over
=item *
Conversion from the original HTML to POD format
=item *
Include list of valid licenses from L<Module::Build> 0.17 rather than
linking to the module, with minor updates to text and links to reflect
versions at the time of publication.
=item *
Fixed some dead links to point to active resources.
=back
=head1 DESCRIPTION
This document describes version 1.0 of the F<META.yml> specification.
The META.yml file describes important properties of contributed Perl
distributions such as the ones found on L<CPAN|http://www.cpan.org>. It is
typically created by tools like L<Module::Build> and L<ExtUtils::MakeMaker>.
The fields in the F<META.yml> file are meant to be helpful to people
maintaining module collections (like CPAN), for people writing
installation tools (like L<CPAN> or L<CPANPLUS>), or just people who want to
know some stuff about a distribution before downloading it and starting to
install it.
=head1 Format
F<META.yml> files are written in the L<YAML|http://www.yaml.org/> format. The
reasons we chose YAML instead of, say, XML or Data::Dumper are discussed in
L<this thread|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg406.html>
on the MakeMaker mailing list.
The first line of a F<META.yml> file should be a valid
L<YAML document header|http://yaml.org/spec/history/2002-10-31.html#syntax-document>
like C<"--- #YAML:1.0">
=head1 Fields
The rest of the META.yml file is one big YAML
L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>,
whose keys are described here.
=over 4
=item name
Example: C<Module-Build>
The name of the distribution. Often created by taking the "main
module" in the distribution and changing "::" to "-". Sometimes it's
completely different, however, as in the case of the
L<libwww-perl|http://search.cpan.org/author/GAAS/libwww-perl/> distribution.
=item version
Example: C<0.16>
The version of the distribution to which the META.yml file refers.
=item license
Example: C<perl>
The license under which this distribution may be used and
redistributed.
Must be one of the following licenses:
=over 4
=item perl
The distribution may be copied and redistributed under the same terms as perl
itself (this is by far the most common licensing option for modules on CPAN).
This is a dual license, in which the user may choose between either the GPL
version 1 or the Artistic version 1 license.
=item gpl
The distribution is distributed under the terms of the GNU General Public
License version 2 (L<http://opensource.org/licenses/GPL-2.0>).
=item lgpl
The distribution is distributed under the terms of the GNU Lesser General
Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).
=item artistic
The distribution is licensed under the Artistic License version 1, as specified
by the Artistic file in the standard perl distribution
(L<http://opensource.org/licenses/Artistic-Perl-1.0>).
=item bsd
The distribution is licensed under the BSD 3-Clause License
(L<http://opensource.org/licenses/BSD-3-Clause>).
=item open_source
The distribution is licensed under some other Open Source Initiative-approved
license listed at L<http://www.opensource.org/licenses/>.
=item unrestricted
The distribution is licensed under a license that is B<not> approved by
L<www.opensource.org|http://www.opensource.org/> but that allows distribution
without restrictions.
=item restrictive
The distribution may not be redistributed without special permission from the
author and/or copyright holder.
=back
=item distribution_type
Example: C<module>
What kind of stuff is contained in this distribution. Most things on
CPAN are C<module>s (which can also mean a collection of
modules), but some things are C<script>s.
=item requires
Example:
Data::Dumper: 0
File::Find: 1.03
A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules this distribution requires for proper
operation. The keys are the module names, and the values are version
specifications as described in the
L<documentation for Module::Build's "requires" parameter|Module::Build::API/requires>.
I<Note: the exact nature of the fancy specifications like
C<< ">= 1.2, != 1.5, < 2.0" >> is subject to
change. Advance notice will be given here. The simple specifications
like C<"1.2"> will not change in format.>
=item recommends
Example:
Data::Dumper: 0
File::Find: 1.03
A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules this distribution recommends for enhanced
operation.
=item build_requires
Example:
Data::Dumper: 0
File::Find: 1.03
A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules required for building and/or testing of
this distribution. These dependencies are not required after the
module is installed.
=item conflicts
Example:
Data::Dumper: 0
File::Find: 1.03
A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules that cannot be installed while this
distribution is installed. This is a pretty uncommon situation.
=item dynamic_config
Example: C<0>
A boolean flag indicating whether a F<Build.PL> or
F<Makefile.PL> (or similar) must be executed, or whether this
module can be built, tested and installed solely from consulting its
metadata file. The main reason to set this to a true value if that
your module performs some dynamic configuration (asking questions,
sensing the environment, etc.) as part of its build/install process.
Currently L<Module::Build> doesn't actually do anything with
this flag - it's probably going to be up to higher-level tools like
L<CPAN.pm|CPAN> to do something useful with it. It can potentially
bring lots of security, packaging, and convenience improvements.
=item generated_by
Example: C<Module::Build version 0.16>
Indicates the tool that was used to create this F<META.yml> file. It's
good form to include both the name of the tool and its version, but
this field is essentially opaque, at least for the moment.
=back
=head1 Related Projects
=over 4
=item DOAP
An RDF vocabulary to describe software projects. L<http://usefulinc.com/doap>.
=back
=head1 History
=over 4
=item *
B<March 14, 2003> (Pi day) - created version 1.0 of this document.
=item *
B<May 8, 2003> - added the "dynamic_config" field, which was missing from the
initial version.
=back

309
OGP64/usr/share/perl5/5.40/CPAN/Meta/History/Meta_1_1.pod Normal file
View file

@ -0,0 +1,309 @@
=for :stopwords Ingy READMEs WTF licensure
=head1 NAME
CPAN::Meta::History::Meta_1_1 - Version 1.1 metadata specification for META.yml
=head1 PREFACE
This is a historical copy of the version 1.1 specification for F<META.yml>
files, copyright by Ken Williams and licensed under the same terms as Perl
itself.
Modifications from the original:
=over
=item *
Conversion from the original HTML to POD format
=item *
Include list of valid licenses from L<Module::Build> 0.18 rather than
linking to the module, with minor updates to text and links to reflect
versions at the time of publication.
=item *
Fixed some dead links to point to active resources.
=back
=head1 DESCRIPTION
This document describes version 1.1 of the F<META.yml> specification.
The F<META.yml> file describes important properties of contributed Perl
distributions such as the ones found on L<CPAN|http://www.cpan.org>. It is
typically created by tools like L<Module::Build> and L<ExtUtils::MakeMaker>.
The fields in the F<META.yml> file are meant to be helpful to people
maintaining module collections (like CPAN), for people writing
installation tools (like L<CPAN> or L<CPANPLUS>), or just people who want to
know some stuff about a distribution before downloading it and starting to
install it.
=head1 Format
F<META.yml> files are written in the L<YAML|http://www.yaml.org/> format. The
reasons we chose YAML instead of, say, XML or Data::Dumper are discussed in
L<this thread|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg406.html>
on the MakeMaker mailing list.
The first line of a F<META.yml> file should be a valid
L<YAML document header|http://yaml.org/spec/history/2002-10-31.html#syntax-document>
like C<"--- #YAML:1.0">
=head1 Fields
The rest of the META.yml file is one big YAML
L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>,
whose keys are described here.
=over 4
=item name
Example: C<Module-Build>
The name of the distribution. Often created by taking the "main
module" in the distribution and changing "::" to "-". Sometimes it's
completely different, however, as in the case of the
L<libwww-perl|http://search.cpan.org/author/GAAS/libwww-perl/> distribution.
=item version
Example: C<0.16>
The version of the distribution to which the META.yml file refers.
This is a mandatory field.
The version is essentially an arbitrary string, but I<must> be
only ASCII characters, and I<strongly should> be of the format
integer-dot-digit-digit, i.e. C<25.57>, optionally followed by
underscore-digit-digit, i.e. C<25.57_04>.
The standard tools that deal with module distribution (PAUSE, CPAN,
etc.) form an identifier for each distribution by joining the 'name'
and 'version' attributes with a dash (C<->) character. Tools
who are prepared to deal with distributions that have no version
numbers generally omit the dash as well.
=item license
Example: C<perl>
a descriptive term for the licenses ... not authoritative, but must
be consistent with licensure statements in the READMEs, documentation, etc.
The license under which this distribution may be used and
redistributed.
Must be one of the following licenses:
=over 4
=item perl
The distribution may be copied and redistributed under the same terms as perl
itself (this is by far the most common licensing option for modules on CPAN).
This is a dual license, in which the user may choose between either the GPL
version 1 or the Artistic version 1 license.
=item gpl
The distribution is distributed under the terms of the GNU General Public
License version 2 (L<http://opensource.org/licenses/GPL-2.0>).
=item lgpl
The distribution is distributed under the terms of the GNU Lesser General
Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).
=item artistic
The distribution is licensed under the Artistic License version 1, as specified
by the Artistic file in the standard perl distribution
(L<http://opensource.org/licenses/Artistic-Perl-1.0>).
=item bsd
The distribution is licensed under the BSD 3-Clause License
(L<http://opensource.org/licenses/BSD-3-Clause>).
=item open_source
The distribution is licensed under some other Open Source Initiative-approved
license listed at L<http://www.opensource.org/licenses/>.
=item unrestricted
The distribution is licensed under a license that is B<not> approved by
L<www.opensource.org|http://www.opensource.org/> but that allows distribution
without restrictions.
=item restrictive
The distribution may not be redistributed without special permission from the
author and/or copyright holder.
=back
=item license_uri
This should contain a URI where the exact terms of the license may be found.
(change "unrestricted" to "redistributable"?)
=item distribution_type
Example: C<module>
What kind of stuff is contained in this distribution. Most things on
CPAN are C<module>s (which can also mean a collection of
modules), but some things are C<script>s.
This field is basically meaningless, and tools (like Module::Build or
MakeMaker) will likely stop generating it in the future.
=item private
WTF is going on here?
index_ignore: any application that indexes the contents of
distributions (PAUSE, search.cpan.org) ought to ignore the items
(packages, files, directories, namespace hierarchies).
=item requires
Example:
Data::Dumper: 0
File::Find: 1.03
A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules this distribution requires for proper
operation. The keys are the module names, and the values are version
specifications as described in the
L<documentation for Module::Build's "requires" parameter|Module::Build::API/requires>.
I<Note: the exact nature of the fancy specifications like
C<< ">= 1.2, != 1.5, < 2.0" >> is subject to
change. Advance notice will be given here. The simple specifications
like C<"1.2"> will not change in format.>
=item recommends
Example:
Data::Dumper: 0
File::Find: 1.03
A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules this distribution recommends for enhanced
operation.
=item build_requires
Example:
Data::Dumper: 0
File::Find: 1.03
A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules required for building and/or testing of
this distribution. These dependencies are not required after the
module is installed.
=item conflicts
Example:
Data::Dumper: 0
File::Find: 1.03
A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules that cannot be installed while this
distribution is installed. This is a pretty uncommon situation.
- possibly separate out test-time prereqs, complications include: can
tests be meaningfully preserved for later running? are test-time
prereqs in addition to build-time, or exclusive?
- make official location for installed *distributions*, which can
contain tests, etc.
=item dynamic_config
Example: C<0>
A boolean flag indicating whether a F<Build.PL> or
F<Makefile.PL> (or similar) must be executed, or whether this
module can be built, tested and installed solely from consulting its
metadata file. The main reason to set this to a true value if that
your module performs some dynamic configuration (asking questions,
sensing the environment, etc.) as part of its build/install process.
Currently L<Module::Build> doesn't actually do anything with
this flag - it's probably going to be up to higher-level tools like
L<CPAN.pm|CPAN> to do something useful with it. It can potentially
bring lots of security, packaging, and convenience improvements.
=item generated_by
Example: C<Module::Build version 0.16>
Indicates the tool that was used to create this F<META.yml> file. It's
good form to include both the name of the tool and its version, but
this field is essentially opaque, at least for the moment.
=back
=head2 Ingy's suggestions
=over 4
=item short_description
add as field, containing abstract, maximum 80 characters, suggested minimum 40 characters
=item description
long version of abstract, should add?
=item maturity
alpha, beta, gamma, mature, stable
=item author_id, owner_id
=item categorization, keyword, chapter_id
=item URL for further information
could default to search.cpan.org on PAUSE
=item namespaces
can be specified for single elements by prepending
dotted-form, i.e. "com.example.my_application.my_property". Default
namespace for META.yml is probably "org.cpan.meta_author" or
something. Precedent for this is Apple's Carbon namespaces, I think.
=back
=head1 History
=over 4
=item *
B<March 14, 2003> (Pi day) - created version 1.0 of this document.
=item *
B<May 8, 2003> - added the "dynamic_config" field, which was missing from the
initial version.
=back

712
OGP64/usr/share/perl5/5.40/CPAN/Meta/History/Meta_1_2.pod Normal file
View file

@ -0,0 +1,712 @@
=for :stopwords MailingList RWS subcontext
=head1 NAME
CPAN::Meta::History::Meta_1_2 - Version 1.2 metadata specification for META.yml
=head1 PREFACE
This is a historical copy of the version 1.2 specification for F<META.yml>
files, copyright by Ken Williams and licensed under the same terms as Perl
itself.
Modifications from the original:
=over
=item *
Various spelling corrections
=item *
Include list of valid licenses from L<Module::Build> 0.2611 rather than
linking to the module, with minor updates to text and links to reflect
versions at the time of publication.
=item *
Fixed some dead links to point to active resources.
=back
=head1 SYNOPSIS
--- #YAML:1.0
name: Module-Build
abstract: Build and install Perl modules
version: 0.20
author:
- Ken Williams <kwilliams@cpan.org>
license: perl
distribution_type: module
requires:
Config: 0
Cwd: 0
Data::Dumper: 0
ExtUtils::Install: 0
File::Basename: 0
File::Compare: 0
File::Copy: 0
File::Find: 0
File::Path: 0
File::Spec: 0
IO::File: 0
perl: 5.005_03
recommends:
Archive::Tar: 1.00
ExtUtils::Install: 0.3
ExtUtils::ParseXS: 2.02
Pod::Text: 0
YAML: 0.35
build_requires:
Test: 0
urls:
license: http://dev.perl.org/licenses/
meta-spec:
version: 1.2
url: http://module-build.sourceforge.net/META-spec-v1.2.html
generated_by: Module::Build version 0.20
=head1 DESCRIPTION
This document describes version 1.2 of the F<META.yml> specification.
The F<META.yml> file describes important properties of contributed
Perl distributions such as the ones found on CPAN. It is typically
created by tools like Module::Build, Module::Install, and
ExtUtils::MakeMaker.
The fields in the F<META.yml> file are meant to be helpful for people
maintaining module collections (like CPAN), for people writing
installation tools (like CPAN.pm or CPANPLUS), or just for people who
want to know some stuff about a distribution before downloading it and
starting to install it.
I<Note: The latest stable version of this specification can always be
found at L<http://module-build.sourceforge.net/META-spec-current.html>,
and the latest development version (which may include things that
won't make it into the stable version can always be found at
L<http://module-build.sourceforge.net/META-spec-blead.html>.>
=head1 FORMAT
F<META.yml> files are written in the YAML format (see
L<http://www.yaml.org/>).
See the following links to learn why we chose YAML instead of, say,
XML or Data::Dumper:
=over 4
=item *
L<Module::Build design plans|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg407.html>
=item *
L<Not keen on YAML|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1353.html>
=item *
L<META Concerns|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1385.html>
=back
=head1 TERMINOLOGY
=over 4
=item distribution
This is the primary object described by the F<META.yml>
specification. In the context of this document it usually refers to a
collection of modules, scripts, and/or documents that are distributed
for other developers to use.
=item module
This refers to a reusable library of code typically contained in a
single file. Currently, we primarily talk of perl modules, but this
specification should be open enough to apply to other languages as
well (ex. python, ruby).
=back
=head1 VERSION SPECIFICATIONS
Some fields require a version specification (ex. L</requires>,
L</recommends>, L</build_requires>, etc.). This section details the
version specifications that are currently supported.
If a single version is listed, then that version is considered to be
the minimum version supported.
If 0 is given as the version number, then any version is supported.
Additionally, for more complicated requirements, the specification
supports a list of versions, each of which may be optionally preceded
by a relational operator.
Supported operators include E<lt> (less than), E<lt>= (less than or
equal), E<gt> (greater than), E<gt>= (greater than or equal), == (equal), and !=
(not equal).
If a list is given then it is evaluated from left to right so that any
specifications in the list that conflict with a previous specification
are overridden by the later.
Examples:
>= 1.2, != 1.5, < 2.0
Any version from version 1.2 onward, except version 1.5, that also
precedes version 2.0.
=head1 HEADER
The first line of a F<META.yml> file should be a valid YAML document
header like C<"--- #YAML:1.0">.
=head1 FIELDS
The rest of the F<META.yml> file is one big YAML mapping whose keys
are described here.
=head2 meta-spec
Example:
meta-spec:
version: 1.2
url: http://module-build.sourceforge.net/META-spec-v1.2.html
(Spec 1.1) [required] {URL} This field indicates the location of the
version of the META.yml specification used.
=head2 name
Example:
name: Module-Build
(Spec 1.0) [required] {string} The name of the distribution which is often
created by taking the "main module" in the distribution and changing
"::" to "-". Sometimes it's completely different, however, as in the
case of the libwww-perl distribution (see
L<http://search.cpan.org/author/GAAS/libwww-perl/>).
=head2 version
Example:
version: 0.20
(Spec 1.0) [required] {version} The version of the distribution to which the
F<META.yml> file refers.
=head2 abstract
Example:
abstract: Build and install Perl modules.
(Spec 1.1) [required] {string} A short description of the purpose of the
distribution.
=head2 author
Example:
author:
- Ken Williams <kwilliams@cpan.org>
(Spec 1.1) [required] {list of strings} A YAML sequence indicating the author(s) of the
distribution. The preferred form is author-name <email-address>.
=head2 license
Example:
license: perl
(Spec 1.0) [required] {string} The license under which this distribution may be
used and redistributed.
Must be one of the following licenses:
=over 4
=item perl
The distribution may be copied and redistributed under the same terms as perl
itself (this is by far the most common licensing option for modules on CPAN).
This is a dual license, in which the user may choose between either the GPL
version 1 or the Artistic version 1 license.
=item gpl
The distribution is distributed under the terms of the GNU General Public
License version 2 (L<http://opensource.org/licenses/GPL-2.0>).
=item lgpl
The distribution is distributed under the terms of the GNU Lesser General
Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).
=item artistic
The distribution is licensed under the Artistic License version 1, as specified
by the Artistic file in the standard perl distribution
(L<http://opensource.org/licenses/Artistic-Perl-1.0>).
=item bsd
The distribution is licensed under the BSD 3-Clause License
(L<http://opensource.org/licenses/BSD-3-Clause>).
=item open_source
The distribution is licensed under some other Open Source Initiative-approved
license listed at L<http://www.opensource.org/licenses/>.
=item unrestricted
The distribution is licensed under a license that is B<not> approved by
L<www.opensource.org|http://www.opensource.org/> but that allows distribution
without restrictions.
=item restrictive
The distribution may not be redistributed without special permission from the
author and/or copyright holder.
=back
=head2 distribution_type
Example:
distribution_type: module
(Spec 1.0) [optional] {string} What kind of stuff is contained in this
distribution. Most things on CPAN are C<module>s (which can also mean
a collection of modules), but some things are C<script>s.
Unfortunately this field is basically meaningless, since many
distributions are hybrids of several kinds of things, or some new
thing, or subjectively different in focus depending on who's using
them. Tools like Module::Build and MakeMaker will likely stop
generating this field.
=head2 requires
Example:
requires:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules this
distribution requires for proper operation. The keys are the module
names, and the values are version specifications as described in
L<Module::Build> for the "requires" parameter.
=head2 recommends
Example:
recommends:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules this
distribution recommends for enhanced operation.
I<ALTERNATIVE: It may be desirable to present to the user which
features depend on which modules so they can make an informed
decision about which recommended modules to install.>
Example:
optional_features:
- foo:
description: Provides the ability to blah.
requires:
Data::Dumper: 0
File::Find: 1.03
- bar:
description: This feature is not available on this platform.
excludes_os: MSWin32
I<(Spec 1.1) [optional] {map} A YAML sequence of names for optional features
which are made available when its requirements are met. For each
feature a description is provided along with any of L</requires>,
L</build_requires>, L</conflicts>, C<requires_packages>,
C<requires_os>, and C<excludes_os> which have the same meaning in
this subcontext as described elsewhere in this document.>
=head2 build_requires
Example:
build_requires:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules
required for building and/or testing of this distribution. These
dependencies are not required after the module is installed.
=head2 conflicts
Example:
conflicts:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules that
cannot be installed while this distribution is installed. This is a
pretty uncommon situation.
=head2 dynamic_config
Example:
dynamic_config: 0
(Spec 1.0) [optional] {boolean} A boolean flag indicating whether a F<Build.PL>
or F<Makefile.PL> (or similar) must be executed when building this
distribution, or whether it can be built, tested and installed solely
from consulting its
metadata file. The main reason to set this to a true value if that
your module performs some dynamic configuration (asking questions,
sensing the environment, etc.) as part of its build/install process.
Currently Module::Build doesn't actually do anything with this flag
- it's probably going to be up to higher-level tools like CPAN
to do something useful with it. It can potentially bring lots of
security, packaging, and convenience improvements.
If this field is omitted, it defaults to 1 (true).
=head2 private
I<(Deprecated)> (Spec 1.0) [optional] {map} This field has been renamed to
L</no_index>. See below.
=head2 provides
Example:
provides:
Foo::Bar:
file: lib/Foo/Bar.pm
version: 0.27_02
Foo::Bar::Blah:
file: lib/Foo/Bar/Blah.pm
Foo::Bar::Baz:
file: lib/Foo/Bar/Baz.pm
version: 0.3
(Spec 1.1) [optional] {map} A YAML mapping that describes all packages
provided by this distribution. This information can be (and, in some
cases, is) used by distribution and automation mechanisms like PAUSE,
CPAN, and search.cpan.org to build indexes saying in which
distribution various packages can be found.
When using tools like L<Module::Build> that can generate the
C<provides> mapping for your distribution automatically, make sure you
examine what it generates to make sure it makes sense - indexers will
usually trust the C<provides> field if it's present, rather than
scanning through the distribution files themselves to figure out
packages and versions. This is a good thing, because it means you can
use the C<provides> field to tell the indexers precisely what you want
indexed about your distribution, rather than relying on them to
essentially guess what you want indexed.
=head2 no_index
Example:
no_index:
file:
- My/Module.pm
dir:
- My/Private
package:
- My::Module::Stuff
namespace:
- My::Module::Stuff
(Spec 1.1) [optional] {map} A YAML mapping that describes any files,
directories, packages, and namespaces that are private
(i.e. implementation artifacts) that are not of interest to searching
and indexing tools. This is useful when no C<provides> field is
present.
I<(Note: I'm not actually sure who looks at this field, or exactly
what they do with it. This spec could be off in some way from actual
usage.)>
=head3 file
(Spec 1.1) [optional] Exclude any listed file(s).
=head3 dir
(Spec 1.1) [optional] Exclude anything below the listed
directory(ies).
=head3 package
(Spec 1.1) [optional] Exclude the listed package(s).
=head3 namespace
(Spec 1.1) [optional] Excludes anything below the listed namespace(s),
but I<not> the listed namespace(s) its self.
=head2 keywords
Example:
keywords:
- make
- build
- install
(Spec 1.1) [optional] {list} A sequence of keywords/phrases that describe
this distribution.
=head2 resources
Example:
resources:
license: http://dev.perl.org/licenses/
homepage: http://sourceforge.net/projects/module-build
bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Module-Build
MailingList: http://lists.sourceforge.net/lists/listinfo/module-build-general
(Spec 1.1) [optional] {map} A mapping of any URL resources related to
this distribution. All-lower-case keys, such as C<homepage>,
C<license>, and C<bugtracker>, are reserved by this specification, as
they have "official" meanings defined here in this specification. If
you'd like to add your own "special" entries (like the "MailingList"
entry above), use at least one upper-case letter.
The current set of official keys is:
=over 2
=item homepage
The official home of this project on the web.
=item license
An URL for an official statement of this distribution's license.
=item bugtracker
An URL for a bug tracker (e.g. Bugzilla or RT queue) for this project.
=back
=head2 generated_by
Example:
generated_by: Module::Build version 0.20
(Spec 1.0) [required] {string} Indicates the tool that was used to create this
F<META.yml> file. It's good form to include both the name of the tool
and its version, but this field is essentially opaque, at least for
the moment. If F<META.yml> was generated by hand, it is suggested that
the author be specified here.
[Note: My F<meta_stats.pl> script which I use to gather statistics
regarding F<META.yml> usage prefers the form listed above, i.e. it
splits on /\s+version\s+/ taking the first field as the name of the
tool that generated the file and the second field as version of that
tool. RWS]
=head1 SEE ALSO
L<CPAN|http://www.cpan.org/>
L<CPAN.pm|CPAN>
L<CPANPLUS>
L<Data::Dumper>
L<ExtUtils::MakeMaker>
L<Module::Build>
L<Module::Install>
L<XML|http://www.w3.org/XML/>
L<YAML|http://www.yaml.org/>
=head1 HISTORY
=over 4
=item March 14, 2003 (Pi day)
=over 2
=item *
Created version 1.0 of this document.
=back
=item May 8, 2003
=over 2
=item *
Added the L</dynamic_config> field, which was missing from the initial
version.
=back
=item November 13, 2003
=over 2
=item *
Added more YAML rationale articles.
=item *
Fixed existing link to YAML discussion thread to point to new
L<http://nntp.x.perl.org/group/> site.
=item *
Added and deprecated the L</private> field.
=item *
Added L</abstract>, C<configure>, C<requires_packages>,
C<requires_os>, C<excludes_os>, and L</no_index> fields.
=item *
Bumped version.
=back
=item November 16, 2003
=over 2
=item *
Added C<generation>, C<authored_by> fields.
=item *
Add alternative proposal to the L</recommends> field.
=item *
Add proposal for a C<requires_build_tools> field.
=back
=item December 9, 2003
=over 2
=item *
Added link to latest version of this specification on CPAN.
=item *
Added section L</"VERSION SPECIFICATIONS">.
=item *
Chang name from Module::Build::META-spec to CPAN::META::Specification.
=item *
Add proposal for C<auto_regenerate> field.
=back
=item December 15, 2003
=over 2
=item *
Add C<index> field as a compliment to L</no_index>
=item *
Add L</keywords> field as a means to aid searching distributions.
=item *
Add L</TERMINOLOGY> section to explain certain terms that may be
ambiguous.
=back
=item July 26, 2005
=over 2
=item *
Removed a bunch of items (generation, requires_build_tools,
requires_packages, configure, requires_os, excludes_os,
auto_regenerate) that have never actually been supported, but were
more like records of brainstorming.
=item *
Changed C<authored_by> to L</author>, since that's always been what
it's actually called in actual F<META.yml> files.
=item *
Added the "==" operator to the list of supported version-checking
operators.
=item *
Noted that the L</distribution_type> field is basically meaningless,
and shouldn't really be used.
=item *
Clarified L</dynamic_config> a bit.
=back
=item August 23, 2005
=over 2
=item *
Removed the name C<CPAN::META::Specification>, since that implies a
module that doesn't actually exist.
=back
=back

741
OGP64/usr/share/perl5/5.40/CPAN/Meta/History/Meta_1_3.pod Normal file
View file

@ -0,0 +1,741 @@
=for :stopwords MailingList PODs RWS subcontext
=head1 NAME
CPAN::Meta::History::Meta_1_3 - Version 1.3 metadata specification for META.yml
=head1 PREFACE
This is a historical copy of the version 1.3 specification for F<META.yml>
files, copyright by Ken Williams and licensed under the same terms as Perl
itself.
Modifications from the original:
=over
=item *
Various spelling corrections
=item *
Include list of valid licenses from L<Module::Build> 0.2805 rather than
linking to the module, with minor updates to text and links to reflect
versions at the time of publication.
=item *
Fixed some dead links to point to active resources.
=back
=head1 SYNOPSIS
--- #YAML:1.0
name: Module-Build
abstract: Build and install Perl modules
version: 0.20
author:
- Ken Williams <kwilliams@cpan.org>
license: perl
distribution_type: module
requires:
Config: 0
Cwd: 0
Data::Dumper: 0
ExtUtils::Install: 0
File::Basename: 0
File::Compare: 0
File::Copy: 0
File::Find: 0
File::Path: 0
File::Spec: 0
IO::File: 0
perl: 5.005_03
recommends:
Archive::Tar: 1.00
ExtUtils::Install: 0.3
ExtUtils::ParseXS: 2.02
Pod::Text: 0
YAML: 0.35
build_requires:
Test: 0
urls:
license: http://dev.perl.org/licenses/
meta-spec:
version: 1.3
url: http://module-build.sourceforge.net/META-spec-v1.3.html
generated_by: Module::Build version 0.20
=head1 DESCRIPTION
This document describes version 1.3 of the F<META.yml> specification.
The F<META.yml> file describes important properties of contributed
Perl distributions such as the ones found on CPAN. It is typically
created by tools like Module::Build, Module::Install, and
ExtUtils::MakeMaker.
The fields in the F<META.yml> file are meant to be helpful for people
maintaining module collections (like CPAN), for people writing
installation tools (like CPAN.pm or CPANPLUS), or just for people who
want to know some stuff about a distribution before downloading it and
starting to install it.
I<Note: The latest stable version of this specification can always be
found at L<http://module-build.sourceforge.net/META-spec-current.html>,
and the latest development version (which may include things that
won't make it into the stable version) can always be found at
L<http://module-build.sourceforge.net/META-spec-blead.html>.>
=head1 FORMAT
F<META.yml> files are written in the YAML format (see
L<http://www.yaml.org/>).
See the following links to learn why we chose YAML instead of, say,
XML or Data::Dumper:
=over 4
=item *
L<Module::Build design plans|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg407.html>
=item *
L<Not keen on YAML|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1353.html>
=item *
L<META Concerns|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1385.html>
=back
=head1 TERMINOLOGY
=over 4
=item distribution
This is the primary object described by the F<META.yml>
specification. In the context of this document it usually refers to a
collection of modules, scripts, and/or documents that are distributed
together for other developers to use. Examples of distributions are
C<Class-Container>, C<libwww-perl>, or C<DBI>.
=item module
This refers to a reusable library of code typically contained in a
single file. Currently, we primarily talk of perl modules, but this
specification should be open enough to apply to other languages as
well (ex. python, ruby). Examples of modules are C<Class::Container>,
C<LWP::Simple>, or C<DBD::File>.
=back
=head1 HEADER
The first line of a F<META.yml> file should be a valid YAML document
header like C<"--- #YAML:1.0">.
=head1 FIELDS
The rest of the F<META.yml> file is one big YAML mapping whose keys
are described here.
=head2 meta-spec
Example:
meta-spec:
version: 1.3
url: http://module-build.sourceforge.net/META-spec-v1.3.html
(Spec 1.1) [required] {URL} This field indicates the location of the
version of the META.yml specification used.
=head2 name
Example:
name: Module-Build
(Spec 1.0) [required] {string} The name of the distribution which is often
created by taking the "main module" in the distribution and changing
"::" to "-". Sometimes it's completely different, however, as in the
case of the libwww-perl distribution (see
L<http://search.cpan.org/dist/libwww-perl/>).
=head2 version
Example:
version: 0.20
(Spec 1.0) [required] {version} The version of the distribution to which the
F<META.yml> file refers.
=head2 abstract
Example:
abstract: Build and install Perl modules.
(Spec 1.1) [required] {string} A short description of the purpose of the
distribution.
=head2 author
Example:
author:
- Ken Williams <kwilliams@cpan.org>
(Spec 1.1) [required] {list of strings} A YAML sequence indicating the author(s) of the
distribution. The preferred form is author-name <email-address>.
=head2 license
Example:
license: perl
(Spec 1.0) [required] {string} The license under which this distribution may be
used and redistributed.
Must be one of the following licenses:
=over 4
=item apache
The distribution is licensed under the Apache Software License version 1.1
(L<http://opensource.org/licenses/Apache-1.1>).
=item artistic
The distribution is licensed under the Artistic License version 1, as specified
by the Artistic file in the standard perl distribution
(L<http://opensource.org/licenses/Artistic-Perl-1.0>).
=item bsd
The distribution is licensed under the BSD 3-Clause License
(L<http://opensource.org/licenses/BSD-3-Clause>).
=item gpl
The distribution is distributed under the terms of the GNU General Public
License version 2 (L<http://opensource.org/licenses/GPL-2.0>).
=item lgpl
The distribution is distributed under the terms of the GNU Lesser General
Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).
=item mit
The distribution is licensed under the MIT License
(L<http://opensource.org/licenses/MIT>).
=item mozilla
The distribution is licensed under the Mozilla Public License.
(L<http://opensource.org/licenses/MPL-1.0> or
L<http://opensource.org/licenses/MPL-1.1>)
=item open_source
The distribution is licensed under some other Open Source Initiative-approved
license listed at L<http://www.opensource.org/licenses/>.
=item perl
The distribution may be copied and redistributed under the same terms as perl
itself (this is by far the most common licensing option for modules on CPAN).
This is a dual license, in which the user may choose between either the GPL
version 1 or the Artistic version 1 license.
=item restrictive
The distribution may not be redistributed without special permission from the
author and/or copyright holder.
=item unrestricted
The distribution is licensed under a license that is not approved by
L<www.opensource.org|http://www.opensource.org/> but that allows distribution
without restrictions.
=back
=head2 distribution_type
Example:
distribution_type: module
(Spec 1.0) [optional] {string} What kind of stuff is contained in this
distribution. Most things on CPAN are C<module>s (which can also mean
a collection of modules), but some things are C<script>s.
Unfortunately this field is basically meaningless, since many
distributions are hybrids of several kinds of things, or some new
thing, or subjectively different in focus depending on who's using
them. Tools like Module::Build and MakeMaker will likely stop
generating this field.
=head2 requires
Example:
requires:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules this
distribution requires for proper operation. The keys are the module
names, and the values are version specifications as described in
L</"VERSION SPECIFICATIONS">.
=head2 recommends
Example:
recommends:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules
this distribution recommends for enhanced operation. The keys are the
module names, and the values are version specifications as described
in L</"VERSION SPECIFICATIONS">.
I<ALTERNATIVE: It may be desirable to present to the user which
features depend on which modules so they can make an informed decision
about which recommended modules to install.>
Example:
optional_features:
- foo:
description: Provides the ability to blah.
requires:
Data::Dumper: 0
File::Find: 1.03
- bar:
description: This feature is not available on this platform.
excludes_os: MSWin32
I<(Spec 1.1) [optional] {map} A YAML sequence of names for optional features
which are made available when its requirements are met. For each
feature a description is provided along with any of L</requires>,
L</build_requires>, L</conflicts>, C<requires_packages>,
C<requires_os>, and C<excludes_os> which have the same meaning in
this subcontext as described elsewhere in this document.>
=head2 build_requires
Example:
build_requires:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules
required for building and/or testing of this distribution. The keys
are the module names, and the values are version specifications as
described in L</"VERSION SPECIFICATIONS">. These dependencies are not
required after the module is installed.
=head2 conflicts
Example:
conflicts:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules that
cannot be installed while this distribution is installed. This is a
pretty uncommon situation. The keys for C<conflicts> are the module
names, and the values are version specifications as described in
L</"VERSION SPECIFICATIONS">.
=head2 dynamic_config
Example:
dynamic_config: 0
(Spec 1.0) [optional] {boolean} A boolean flag indicating whether a F<Build.PL>
or F<Makefile.PL> (or similar) must be executed when building this
distribution, or whether it can be built, tested and installed solely
from consulting its
metadata file. The main reason to set this to a true value is that
your module performs some dynamic configuration (asking questions,
sensing the environment, etc.) as part of its build/install process.
Currently Module::Build doesn't actually do anything with this flag
- it's probably going to be up to higher-level tools like CPAN
to do something useful with it. It can potentially bring lots of
security, packaging, and convenience improvements.
If this field is omitted, it defaults to 1 (true).
=head2 private
I<(Deprecated)> (Spec 1.0) [optional] {map} This field has been renamed to
L</no_index>. See below.
=head2 provides
Example:
provides:
Foo::Bar:
file: lib/Foo/Bar.pm
version: 0.27_02
Foo::Bar::Blah:
file: lib/Foo/Bar/Blah.pm
Foo::Bar::Baz:
file: lib/Foo/Bar/Baz.pm
version: 0.3
(Spec 1.1) [optional] {map} A YAML mapping that describes all packages
provided by this distribution. This information can be (and, in some
cases, is) used by distribution and automation mechanisms like PAUSE,
CPAN, and search.cpan.org to build indexes saying in which
distribution various packages can be found.
When using tools like L<Module::Build> that can generate the
C<provides> mapping for your distribution automatically, make sure you
examine what it generates to make sure it makes sense - indexers will
usually trust the C<provides> field if it's present, rather than
scanning through the distribution files themselves to figure out
packages and versions. This is a good thing, because it means you can
use the C<provides> field to tell the indexers precisely what you want
indexed about your distribution, rather than relying on them to
essentially guess what you want indexed.
=head2 no_index
Example:
no_index:
file:
- My/Module.pm
directory:
- My/Private
package:
- My::Module::Stuff
namespace:
- My::Module::Stuff
(Spec 1.1) [optional] {map} A YAML mapping that describes any files,
directories, packages, and namespaces that are private
(i.e. implementation artifacts) that are not of interest to searching
and indexing tools. This is useful when no C<provides> field is
present.
For example, L<http://search.cpan.org/> excludes items listed in C<no_index>
when searching for POD, meaning files in these directories will not
converted to HTML and made public - which is useful if you have
example or test PODs that you don't want the search engine to go
through.
=head3 file
(Spec 1.1) [optional] Exclude any listed file(s).
=head3 directory
(Spec 1.1) [optional] Exclude anything below the listed
directory(ies).
[Note: previous editions of the spec had C<dir> instead of
C<directory>, but I think MakeMaker and various users started using
C<directory>, so in deference we switched to that.]
=head3 package
(Spec 1.1) [optional] Exclude the listed package(s).
=head3 namespace
(Spec 1.1) [optional] Excludes anything below the listed namespace(s),
but I<not> the listed namespace(s) its self.
=head2 keywords
Example:
keywords:
- make
- build
- install
(Spec 1.1) [optional] {list} A sequence of keywords/phrases that describe
this distribution.
=head2 resources
Example:
resources:
license: http://dev.perl.org/licenses/
homepage: http://sourceforge.net/projects/module-build
bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Module-Build
repository: http://sourceforge.net/cvs/?group_id=45731
MailingList: http://lists.sourceforge.net/lists/listinfo/module-build-general
(Spec 1.1) [optional] {map} A mapping of any URL resources related to
this distribution. All-lower-case keys, such as C<homepage>,
C<license>, and C<bugtracker>, are reserved by this specification, as
they have "official" meanings defined here in this specification. If
you'd like to add your own "special" entries (like the "MailingList"
entry above), use at least one upper-case letter.
The current set of official keys is:
=over 2
=item homepage
The official home of this project on the web.
=item license
An URL for an official statement of this distribution's license.
=item bugtracker
An URL for a bug tracker (e.g. Bugzilla or RT queue) for this project.
=back
=head2 generated_by
Example:
generated_by: Module::Build version 0.20
(Spec 1.0) [required] {string} Indicates the tool that was used to create this
F<META.yml> file. It's good form to include both the name of the tool
and its version, but this field is essentially opaque, at least for
the moment. If F<META.yml> was generated by hand, it is suggested that
the author be specified here.
[Note: My F<meta_stats.pl> script which I use to gather statistics
regarding F<META.yml> usage prefers the form listed above, i.e. it
splits on /\s+version\s+/ taking the first field as the name of the
tool that generated the file and the second field as version of that
tool. RWS]
=head1 VERSION SPECIFICATIONS
Some fields require a version specification (ex. L</requires>,
L</recommends>, L</build_requires>, etc.) to indicate the particular
versionZ<>(s) of some other module that may be required as a
prerequisite. This section details the version specification formats
that are currently supported.
The simplest format for a version specification is just the version
number itself, e.g. C<2.4>. This means that B<at least> version 2.4
must be present. To indicate that B<any> version of a prerequisite is
okay, even if the prerequisite doesn't define a version at all, use
the version C<0>.
You may also use the operators E<lt> (less than), E<lt>= (less than or
equal), E<gt> (greater than), E<gt>= (greater than or equal), ==
(equal), and != (not equal). For example, the specification C<E<lt>
2.0> means that any version of the prerequisite less than 2.0 is
suitable.
For more complicated situations, version specifications may be AND-ed
together using commas. The specification C<E<gt>= 1.2, != 1.5, E<lt>
2.0> indicates a version that must be B<at least> 1.2, B<less than>
2.0, and B<not equal to> 1.5.
=head1 SEE ALSO
L<CPAN|http://www.cpan.org/>
L<CPAN.pm|CPAN>
L<CPANPLUS>
L<Data::Dumper>
L<ExtUtils::MakeMaker>
L<Module::Build>
L<Module::Install>
L<XML|http://www.w3.org/XML/>
L<YAML|http://www.yaml.org/>
=head1 HISTORY
=over 4
=item March 14, 2003 (Pi day)
=over 2
=item *
Created version 1.0 of this document.
=back
=item May 8, 2003
=over 2
=item *
Added the L</dynamic_config> field, which was missing from the initial
version.
=back
=item November 13, 2003
=over 2
=item *
Added more YAML rationale articles.
=item *
Fixed existing link to YAML discussion thread to point to new
L<http://nntp.x.perl.org/group/> site.
=item *
Added and deprecated the L</private> field.
=item *
Added L</abstract>, C<configure>, C<requires_packages>,
C<requires_os>, C<excludes_os>, and L</no_index> fields.
=item *
Bumped version.
=back
=item November 16, 2003
=over 2
=item *
Added C<generation>, C<authored_by> fields.
=item *
Add alternative proposal to the L</recommends> field.
=item *
Add proposal for a C<requires_build_tools> field.
=back
=item December 9, 2003
=over 2
=item *
Added link to latest version of this specification on CPAN.
=item *
Added section L</"VERSION SPECIFICATIONS">.
=item *
Chang name from Module::Build::META-spec to CPAN::META::Specification.
=item *
Add proposal for C<auto_regenerate> field.
=back
=item December 15, 2003
=over 2
=item *
Add C<index> field as a compliment to L</no_index>
=item *
Add L</keywords> field as a means to aid searching distributions.
=item *
Add L</TERMINOLOGY> section to explain certain terms that may be
ambiguous.
=back
=item July 26, 2005
=over 2
=item *
Removed a bunch of items (generation, requires_build_tools,
requires_packages, configure, requires_os, excludes_os,
auto_regenerate) that have never actually been supported, but were
more like records of brainstorming.
=item *
Changed C<authored_by> to L</author>, since that's always been what
it's actually called in actual F<META.yml> files.
=item *
Added the "==" operator to the list of supported version-checking
operators.
=item *
Noted that the L</distribution_type> field is basically meaningless,
and shouldn't really be used.
=item *
Clarified L</dynamic_config> a bit.
=back
=item August 23, 2005
=over 2
=item *
Removed the name C<CPAN::META::Specification>, since that implies a
module that doesn't actually exist.
=back
=back

765
OGP64/usr/share/perl5/5.40/CPAN/Meta/History/Meta_1_4.pod Normal file
View file

@ -0,0 +1,765 @@
=for :stopwords MailingList PODs RWS subcontext
=head1 NAME
CPAN::Meta::History::Meta_1_4 - Version 1.4 metadata specification for META.yml
=head1 PREFACE
This is a historical copy of the version 1.4 specification for F<META.yml>
files, copyright by Ken Williams and licensed under the same terms as Perl
itself.
Modifications from the original:
=over
=item *
Various spelling corrections
=item *
Include list of valid licenses from L<Module::Build> 0.2807 rather than
linking to the module, with minor updates to text and links to reflect
versions at the time of publication.
=item *
Fixed some dead links to point to active resources.
=back
=head1 SYNOPSIS
--- #YAML:1.0
name: Module-Build
abstract: Build and install Perl modules
version: 0.20
author:
- Ken Williams <kwilliams@cpan.org>
license: perl
distribution_type: module
requires:
Config: 0
Cwd: 0
Data::Dumper: 0
ExtUtils::Install: 0
File::Basename: 0
File::Compare: 0
File::Copy: 0
File::Find: 0
File::Path: 0
File::Spec: 0
IO::File: 0
perl: 5.005_03
recommends:
Archive::Tar: 1.00
ExtUtils::Install: 0.3
ExtUtils::ParseXS: 2.02
Pod::Text: 0
YAML: 0.35
build_requires:
Test: 0
resources:
license: http://dev.perl.org/licenses/
meta-spec:
version: 1.4
url: http://module-build.sourceforge.net/META-spec-v1.3.html
generated_by: Module::Build version 0.20
=head1 DESCRIPTION
This document describes version 1.4 of the F<META.yml> specification.
The F<META.yml> file describes important properties of contributed
Perl distributions such as the ones found on CPAN. It is typically
created by tools like Module::Build, Module::Install, and
ExtUtils::MakeMaker.
The fields in the F<META.yml> file are meant to be helpful for people
maintaining module collections (like CPAN), for people writing
installation tools (like CPAN.pm or CPANPLUS), or just for people who
want to know some stuff about a distribution before downloading it and
starting to install it.
I<Note: The latest stable version of this specification can always be
found at L<http://module-build.sourceforge.net/META-spec-current.html>,
and the latest development version (which may include things that
won't make it into the stable version) can always be found at
L<http://module-build.sourceforge.net/META-spec-blead.html>.>
=head1 FORMAT
F<META.yml> files are written in the YAML format (see
L<http://www.yaml.org/>).
See the following links to learn why we chose YAML instead of, say,
XML or Data::Dumper:
=over 4
=item *
L<Module::Build design plans|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg407.html>
=item *
L<Not keen on YAML|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1353.html>
=item *
L<META Concerns|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1385.html>
=back
=head1 TERMINOLOGY
=over 4
=item distribution
This is the primary object described by the F<META.yml>
specification. In the context of this document it usually refers to a
collection of modules, scripts, and/or documents that are distributed
together for other developers to use. Examples of distributions are
C<Class-Container>, C<libwww-perl>, or C<DBI>.
=item module
This refers to a reusable library of code typically contained in a
single file. Currently, we primarily talk of perl modules, but this
specification should be open enough to apply to other languages as
well (ex. python, ruby). Examples of modules are C<Class::Container>,
C<LWP::Simple>, or C<DBD::File>.
=back
=head1 HEADER
The first line of a F<META.yml> file should be a valid YAML document
header like C<"--- #YAML:1.0">.
=head1 FIELDS
The rest of the F<META.yml> file is one big YAML mapping whose keys
are described here.
=head2 meta-spec
Example:
meta-spec:
version: 1.4
url: http://module-build.sourceforge.net/META-spec-v1.3.html
(Spec 1.1) [required] {URL} This field indicates the location of the
version of the META.yml specification used.
=head2 name
Example:
name: Module-Build
(Spec 1.0) [required] {string} The name of the distribution which is often
created by taking the "main module" in the distribution and changing
"::" to "-". Sometimes it's completely different, however, as in the
case of the libwww-perl distribution (see
L<http://search.cpan.org/dist/libwww-perl/>).
=head2 version
Example:
version: 0.20
(Spec 1.0) [required] {version} The version of the distribution to which the
F<META.yml> file refers.
=head2 abstract
Example:
abstract: Build and install Perl modules.
(Spec 1.1) [required] {string} A short description of the purpose of the
distribution.
=head2 author
Example:
author:
- Ken Williams <kwilliams@cpan.org>
(Spec 1.1) [required] {list of strings} A YAML sequence indicating the author(s) of the
distribution. The preferred form is author-name <email-address>.
=head2 license
Example:
license: perl
(Spec 1.0) [required] {string} The license under which this
distribution may be used and redistributed.
Must be one of the following licenses:
=over 4
=item apache
The distribution is licensed under the Apache Software License version 1.1
(L<http://opensource.org/licenses/Apache-1.1>).
=item artistic
The distribution is licensed under the Artistic License version 1, as specified
by the Artistic file in the standard perl distribution
(L<http://opensource.org/licenses/Artistic-Perl-1.0>).
=item bsd
The distribution is licensed under the BSD 3-Clause License
(L<http://opensource.org/licenses/BSD-3-Clause>).
=item gpl
The distribution is distributed under the terms of the GNU General Public
License version 2 (L<http://opensource.org/licenses/GPL-2.0>).
=item lgpl
The distribution is distributed under the terms of the GNU Lesser General
Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).
=item mit
The distribution is licensed under the MIT License
(L<http://opensource.org/licenses/MIT>).
=item mozilla
The distribution is licensed under the Mozilla Public License.
(L<http://opensource.org/licenses/MPL-1.0> or
L<http://opensource.org/licenses/MPL-1.1>)
=item open_source
The distribution is licensed under some other Open Source Initiative-approved
license listed at L<http://www.opensource.org/licenses/>.
=item perl
The distribution may be copied and redistributed under the same terms as perl
itself (this is by far the most common licensing option for modules on CPAN).
This is a dual license, in which the user may choose between either the GPL or
the Artistic license.
=item restrictive
The distribution may not be redistributed without special permission from the
author and/or copyright holder.
=item unrestricted
The distribution is licensed under a license that is not approved by
L<www.opensource.org|http://www.opensource.org/> but that allows distribution
without restrictions.
=back
=head2 distribution_type
Example:
distribution_type: module
(Spec 1.0) [optional] {string} What kind of stuff is contained in this
distribution. Most things on CPAN are C<module>s (which can also mean
a collection of modules), but some things are C<script>s.
Unfortunately this field is basically meaningless, since many
distributions are hybrids of several kinds of things, or some new
thing, or subjectively different in focus depending on who's using
them. Tools like Module::Build and MakeMaker will likely stop
generating this field.
=head2 requires
Example:
requires:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl
prerequisites this distribution requires for proper operation. The
keys are the names of the prerequisites (module names or 'perl'), and
the values are version specifications as described in L<VERSION
SPECIFICATIONS>.
=head2 recommends
Example:
recommends:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl
prerequisites this distribution recommends for enhanced operation.
The keys are the names of the prerequisites (module names or 'perl'),
and the values are version specifications as described in L<VERSION
SPECIFICATIONS>.
I<ALTERNATIVE: It may be desirable to present to the user which
features depend on which modules so they can make an informed decision
about which recommended modules to install.>
Example:
optional_features:
foo:
description: Provides the ability to blah.
requires:
Data::Dumper: 0
File::Find: 1.03
I<(Spec 1.1) [optional] {map} A YAML mapping of names for optional features
which are made available when its requirements are met. For each
feature a description is provided along with any of L</requires>,
L</build_requires>, and L</conflicts>, which have the same meaning in
this subcontext as described elsewhere in this document.>
=head2 build_requires
Example:
build_requires:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl
prerequisites required for building and/or testing of this
distribution. The keys are the names of the prerequisites (module
names or 'perl'), and the values are version specifications as
described in L</"VERSION SPECIFICATIONS">. These dependencies are not
required after the distribution is installed.
=head2 configure_requires
Example:
configure_requires:
Module::Build: 0.2809
Data::Dumper: 0
File::Find: 1.03
(Spec 1.4) [optional] {map} A YAML mapping indicating the Perl prerequisites
required before configuring this distribution. The keys are the
names of the prerequisites (module names or 'perl'), and the values are version
specifications as described in L</"VERSION SPECIFICATIONS">. These
dependencies are not required after the distribution is installed.
=head2 conflicts
Example:
conflicts:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating any items that
cannot be installed while this distribution is installed. This is a
pretty uncommon situation. The keys for C<conflicts> are the item
names (module names or 'perl'), and the values are version
specifications as described in L</"VERSION SPECIFICATIONS">.
=head2 dynamic_config
Example:
dynamic_config: 0
(Spec 1.0) [optional] {boolean} A boolean flag indicating whether a F<Build.PL>
or F<Makefile.PL> (or similar) must be executed when building this
distribution, or whether it can be built, tested and installed solely
from consulting its
metadata file. The main reason to set this to a true value is that
your module performs some dynamic configuration (asking questions,
sensing the environment, etc.) as part of its build/install process.
Currently Module::Build doesn't actually do anything with this flag
- it's probably going to be up to higher-level tools like CPAN
to do something useful with it. It can potentially bring lots of
security, packaging, and convenience improvements.
If this field is omitted, it defaults to 1 (true).
=head2 private
I<(Deprecated)> (Spec 1.0) [optional] {map} This field has been renamed to
L</no_index>. See below.
=head2 provides
Example:
provides:
Foo::Bar:
file: lib/Foo/Bar.pm
version: 0.27_02
Foo::Bar::Blah:
file: lib/Foo/Bar/Blah.pm
Foo::Bar::Baz:
file: lib/Foo/Bar/Baz.pm
version: 0.3
(Spec 1.1) [optional] {map} A YAML mapping that describes all packages
provided by this distribution. This information can be (and, in some
cases, is) used by distribution and automation mechanisms like PAUSE,
CPAN, and search.cpan.org to build indexes saying in which
distribution various packages can be found.
When using tools like L<Module::Build> that can generate the
C<provides> mapping for your distribution automatically, make sure you
examine what it generates to make sure it makes sense - indexers will
usually trust the C<provides> field if it's present, rather than
scanning through the distribution files themselves to figure out
packages and versions. This is a good thing, because it means you can
use the C<provides> field to tell the indexers precisely what you want
indexed about your distribution, rather than relying on them to
essentially guess what you want indexed.
=head2 no_index
Example:
no_index:
file:
- My/Module.pm
directory:
- My/Private
package:
- My::Module::Stuff
namespace:
- My::Module::Stuff
(Spec 1.1) [optional] {map} A YAML mapping that describes any files,
directories, packages, and namespaces that are private
(i.e. implementation artifacts) that are not of interest to searching
and indexing tools. This is useful when no C<provides> field is
present.
For example, L<http://search.cpan.org/> excludes items listed in C<no_index>
when searching for POD, meaning files in these directories will not
converted to HTML and made public - which is useful if you have
example or test PODs that you don't want the search engine to go
through.
=head3 file
(Spec 1.1) [optional] Exclude any listed file(s).
=head3 directory
(Spec 1.1) [optional] Exclude anything below the listed
directory(ies).
[Note: previous editions of the spec had C<dir> instead of
C<directory>, but I think MakeMaker and various users started using
C<directory>, so in deference we switched to that.]
=head3 package
(Spec 1.1) [optional] Exclude the listed package(s).
=head3 namespace
(Spec 1.1) [optional] Excludes anything below the listed namespace(s),
but I<not> the listed namespace(s) its self.
=head2 keywords
Example:
keywords:
- make
- build
- install
(Spec 1.1) [optional] {list} A sequence of keywords/phrases that describe
this distribution.
=head2 resources
Example:
resources:
license: http://dev.perl.org/licenses/
homepage: http://sourceforge.net/projects/module-build
bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Module-Build
repository: http://sourceforge.net/cvs/?group_id=45731
MailingList: http://lists.sourceforge.net/lists/listinfo/module-build-general
(Spec 1.1) [optional] {map} A mapping of any URL resources related to
this distribution. All-lower-case keys, such as C<homepage>,
C<license>, and C<bugtracker>, are reserved by this specification, as
they have "official" meanings defined here in this specification. If
you'd like to add your own "special" entries (like the "MailingList"
entry above), use at least one upper-case letter.
The current set of official keys is:
=over 2
=item homepage
The official home of this project on the web.
=item license
An URL for an official statement of this distribution's license.
=item bugtracker
An URL for a bug tracker (e.g. Bugzilla or RT queue) for this project.
=back
=head2 generated_by
Example:
generated_by: Module::Build version 0.20
(Spec 1.0) [required] {string} Indicates the tool that was used to create this
F<META.yml> file. It's good form to include both the name of the tool
and its version, but this field is essentially opaque, at least for
the moment. If F<META.yml> was generated by hand, it is suggested that
the author be specified here.
[Note: My F<meta_stats.pl> script which I use to gather statistics
regarding F<META.yml> usage prefers the form listed above, i.e. it
splits on /\s+version\s+/ taking the first field as the name of the
tool that generated the file and the second field as version of that
tool. RWS]
=head1 VERSION SPECIFICATIONS
Some fields require a version specification (ex. L</requires>,
L</recommends>, L</build_requires>, etc.) to indicate the particular
versionZ<>(s) of some other module that may be required as a
prerequisite. This section details the version specification formats
that are currently supported.
The simplest format for a version specification is just the version
number itself, e.g. C<2.4>. This means that B<at least> version 2.4
must be present. To indicate that B<any> version of a prerequisite is
okay, even if the prerequisite doesn't define a version at all, use
the version C<0>.
You may also use the operators E<lt> (less than), E<lt>= (less than or
equal), E<gt> (greater than), E<gt>= (greater than or equal), ==
(equal), and != (not equal). For example, the specification C<E<lt>
2.0> means that any version of the prerequisite less than 2.0 is
suitable.
For more complicated situations, version specifications may be AND-ed
together using commas. The specification C<E<gt>= 1.2, != 1.5, E<lt>
2.0> indicates a version that must be B<at least> 1.2, B<less than>
2.0, and B<not equal to> 1.5.
=head1 SEE ALSO
L<CPAN|http://www.cpan.org/>
L<CPAN.pm|CPAN>
L<CPANPLUS>
L<Data::Dumper>
L<ExtUtils::MakeMaker>
L<Module::Build>
L<Module::Install>
L<XML|http://www.w3.org/XML/>
L<YAML|http://www.yaml.org/>
=head1 HISTORY
=over 4
=item March 14, 2003 (Pi day)
=over 2
=item *
Created version 1.0 of this document.
=back
=item May 8, 2003
=over 2
=item *
Added the L</dynamic_config> field, which was missing from the initial
version.
=back
=item November 13, 2003
=over 2
=item *
Added more YAML rationale articles.
=item *
Fixed existing link to YAML discussion thread to point to new
L<http://nntp.x.perl.org/group/> site.
=item *
Added and deprecated the L</private> field.
=item *
Added L</abstract>, C<configure>, C<requires_packages>,
C<requires_os>, C<excludes_os>, and L</no_index> fields.
=item *
Bumped version.
=back
=item November 16, 2003
=over 2
=item *
Added C<generation>, C<authored_by> fields.
=item *
Add alternative proposal to the L</recommends> field.
=item *
Add proposal for a C<requires_build_tools> field.
=back
=item December 9, 2003
=over 2
=item *
Added link to latest version of this specification on CPAN.
=item *
Added section L</"VERSION SPECIFICATIONS">.
=item *
Chang name from Module::Build::META-spec to CPAN::META::Specification.
=item *
Add proposal for C<auto_regenerate> field.
=back
=item December 15, 2003
=over 2
=item *
Add C<index> field as a compliment to L</no_index>
=item *
Add L</keywords> field as a means to aid searching distributions.
=item *
Add L</TERMINOLOGY> section to explain certain terms that may be
ambiguous.
=back
=item July 26, 2005
=over 2
=item *
Removed a bunch of items (generation, requires_build_tools,
requires_packages, configure, requires_os, excludes_os,
auto_regenerate) that have never actually been supported, but were
more like records of brainstorming.
=item *
Changed C<authored_by> to L</author>, since that's always been what
it's actually called in actual F<META.yml> files.
=item *
Added the "==" operator to the list of supported version-checking
operators.
=item *
Noted that the L</distribution_type> field is basically meaningless,
and shouldn't really be used.
=item *
Clarified L</dynamic_config> a bit.
=back
=item August 23, 2005
=over 2
=item *
Removed the name C<CPAN::META::Specification>, since that implies a
module that doesn't actually exist.
=back
=item June 12, 2007
=over 2
=item *
Added L</configure_requires>.
=back
=back

351
OGP64/usr/share/perl5/5.40/CPAN/Meta/Merge.pm Normal file
View file

@ -0,0 +1,351 @@
use strict;
use warnings;
package CPAN::Meta::Merge;
our $VERSION = '2.150010';
use Carp qw/croak/;
use Scalar::Util qw/blessed/;
use CPAN::Meta::Converter 2.141170;
sub _is_identical {
my ($left, $right) = @_;
return
(not defined $left and not defined $right)
# if either of these are references, we compare the serialized value
|| (defined $left and defined $right and $left eq $right);
}
sub _identical {
my ($left, $right, $path) = @_;
croak sprintf "Can't merge attribute %s: '%s' does not equal '%s'", join('.', @{$path}), $left, $right
unless _is_identical($left, $right);
return $left;
}
sub _merge {
my ($current, $next, $mergers, $path) = @_;
for my $key (keys %{$next}) {
if (not exists $current->{$key}) {
$current->{$key} = $next->{$key};
}
elsif (my $merger = $mergers->{$key}) {
$current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
}
elsif ($merger = $mergers->{':default'}) {
$current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
}
else {
croak sprintf "Can't merge unknown attribute '%s'", join '.', @{$path}, $key;
}
}
return $current;
}
sub _uniq {
my %seen = ();
return grep { not $seen{$_}++ } @_;
}
sub _set_addition {
my ($left, $right) = @_;
return [ +_uniq(@{$left}, @{$right}) ];
}
sub _uniq_map {
my ($left, $right, $path) = @_;
for my $key (keys %{$right}) {
if (not exists $left->{$key}) {
$left->{$key} = $right->{$key};
}
# identical strings or references are merged identically
elsif (_is_identical($left->{$key}, $right->{$key})) {
1; # do nothing - keep left
}
elsif (ref $left->{$key} eq 'HASH' and ref $right->{$key} eq 'HASH') {
$left->{$key} = _uniq_map($left->{$key}, $right->{$key}, [ @{$path}, $key ]);
}
else {
croak 'Duplication of element ' . join '.', @{$path}, $key;
}
}
return $left;
}
sub _improvise {
my ($left, $right, $path) = @_;
my ($name) = reverse @{$path};
if ($name =~ /^x_/) {
if (ref($left) eq 'ARRAY') {
return _set_addition($left, $right, $path);
}
elsif (ref($left) eq 'HASH') {
return _uniq_map($left, $right, $path);
}
else {
return _identical($left, $right, $path);
}
}
croak sprintf "Can't merge '%s'", join '.', @{$path};
}
sub _optional_features {
my ($left, $right, $path) = @_;
for my $key (keys %{$right}) {
if (not exists $left->{$key}) {
$left->{$key} = $right->{$key};
}
else {
for my $subkey (keys %{ $right->{$key} }) {
next if $subkey eq 'prereqs';
if (not exists $left->{$key}{$subkey}) {
$left->{$key}{$subkey} = $right->{$key}{$subkey};
}
else {
Carp::croak "Cannot merge two optional_features named '$key' with different '$subkey' values"
if do { no warnings 'uninitialized'; $left->{$key}{$subkey} ne $right->{$key}{$subkey} };
}
}
require CPAN::Meta::Prereqs;
$left->{$key}{prereqs} =
CPAN::Meta::Prereqs->new($left->{$key}{prereqs})
->with_merged_prereqs(CPAN::Meta::Prereqs->new($right->{$key}{prereqs}))
->as_string_hash;
}
}
return $left;
}
my %default = (
abstract => \&_identical,
author => \&_set_addition,
dynamic_config => sub {
my ($left, $right) = @_;
return $left || $right;
},
generated_by => sub {
my ($left, $right) = @_;
return join ', ', _uniq(split(/, /, $left), split(/, /, $right));
},
license => \&_set_addition,
'meta-spec' => {
version => \&_identical,
url => \&_identical
},
name => \&_identical,
release_status => \&_identical,
version => \&_identical,
description => \&_identical,
keywords => \&_set_addition,
no_index => { map { ($_ => \&_set_addition) } qw/file directory package namespace/ },
optional_features => \&_optional_features,
prereqs => sub {
require CPAN::Meta::Prereqs;
my ($left, $right) = map { CPAN::Meta::Prereqs->new($_) } @_[0,1];
return $left->with_merged_prereqs($right)->as_string_hash;
},
provides => \&_uniq_map,
resources => {
license => \&_set_addition,
homepage => \&_identical,
bugtracker => \&_uniq_map,
repository => \&_uniq_map,
':default' => \&_improvise,
},
':default' => \&_improvise,
);
sub new {
my ($class, %arguments) = @_;
croak 'default version required' if not exists $arguments{default_version};
my %mapping = %default;
my %extra = %{ $arguments{extra_mappings} || {} };
for my $key (keys %extra) {
if (ref($mapping{$key}) eq 'HASH') {
$mapping{$key} = { %{ $mapping{$key} }, %{ $extra{$key} } };
}
else {
$mapping{$key} = $extra{$key};
}
}
return bless {
default_version => $arguments{default_version},
mapping => _coerce_mapping(\%mapping, []),
}, $class;
}
my %coderef_for = (
set_addition => \&_set_addition,
uniq_map => \&_uniq_map,
identical => \&_identical,
improvise => \&_improvise,
improvize => \&_improvise, # [sic] for backwards compatibility
);
sub _coerce_mapping {
my ($orig, $map_path) = @_;
my %ret;
for my $key (keys %{$orig}) {
my $value = $orig->{$key};
if (ref($orig->{$key}) eq 'CODE') {
$ret{$key} = $value;
}
elsif (ref($value) eq 'HASH') {
my $mapping = _coerce_mapping($value, [ @{$map_path}, $key ]);
$ret{$key} = sub {
my ($left, $right, $path) = @_;
return _merge($left, $right, $mapping, [ @{$path} ]);
};
}
elsif ($coderef_for{$value}) {
$ret{$key} = $coderef_for{$value};
}
else {
croak "Don't know what to do with " . join '.', @{$map_path}, $key;
}
}
return \%ret;
}
sub merge {
my ($self, @items) = @_;
my $current = {};
for my $next (@items) {
if ( blessed($next) && $next->isa('CPAN::Meta') ) {
$next = $next->as_struct;
}
elsif ( ref($next) eq 'HASH' ) {
my $cmc = CPAN::Meta::Converter->new(
$next, default_version => $self->{default_version}
);
$next = $cmc->upgrade_fragment;
}
else {
croak "Don't know how to merge '$next'";
}
$current = _merge($current, $next, $self->{mapping}, []);
}
return $current;
}
1;
# ABSTRACT: Merging CPAN Meta fragments
# vim: ts=2 sts=2 sw=2 et :
__END__
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::Merge - Merging CPAN Meta fragments
=head1 VERSION
version 2.150010
=head1 SYNOPSIS
my $merger = CPAN::Meta::Merge->new(default_version => "2");
my $meta = $merger->merge($base, @additional);
=head1 DESCRIPTION
=head1 METHODS
=head2 new
This creates a CPAN::Meta::Merge object. It takes one mandatory named
argument, C<version>, declaring the version of the meta-spec that must be
used for the merge. It can optionally take an C<extra_mappings> argument
that allows one to add additional merging functions for specific elements.
The C<extra_mappings> arguments takes a hash ref with the same type of
structure as described in L<CPAN::Meta::Spec>, except with its values as
one of the L<defined merge strategies|/"MERGE STRATEGIES"> or a code ref
to a merging function.
my $merger = CPAN::Meta::Merge->new(
default_version => '2',
extra_mappings => {
'optional_features' => \&custom_merge_function,
'x_custom' => 'set_addition',
'x_meta_meta' => {
name => 'identical',
tags => 'set_addition',
}
}
);
=head2 merge(@fragments)
Merge all C<@fragments> together. It will accept both CPAN::Meta objects and
(possibly incomplete) hashrefs of metadata.
=head1 MERGE STRATEGIES
C<merge> uses various strategies to combine different elements of the CPAN::Meta objects. The following strategies can be used with the extra_mappings argument of C<new>:
=over
=item identical
The elements must be identical
=item set_addition
The union of two array refs
[ a, b ] U [ a, c] = [ a, b, c ]
=item uniq_map
Key value pairs from the right hash are merged to the left hash. Key
collisions are only allowed if their values are the same. This merge
function will recurse into nested hash refs following the same merge
rules.
=item improvise
This merge strategy will try to pick the appropriate predefined strategy
based on what element type. Array refs will try to use the
C<set_addition> strategy, Hash refs will try to use the C<uniq_map>
strategy, and everything else will try the C<identical> strategy.
=back
=head1 AUTHORS
=over 4
=item *
David Golden <dagolden@cpan.org>
=item *
Ricardo Signes <rjbs@cpan.org>
=item *
Adam Kennedy <adamk@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

481
OGP64/usr/share/perl5/5.40/CPAN/Meta/Prereqs.pm Normal file
View file

@ -0,0 +1,481 @@
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Prereqs;
our $VERSION = '2.150010';
#pod =head1 DESCRIPTION
#pod
#pod A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN
#pod distribution or one of its optional features. Each set of prereqs is
#pod organized by phase and type, as described in L<CPAN::Meta::Prereqs>.
#pod
#pod =cut
use Carp qw(confess);
use Scalar::Util qw(blessed);
use CPAN::Meta::Requirements 2.121;
#pod =method new
#pod
#pod my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec );
#pod
#pod This method returns a new set of Prereqs. The input should look like the
#pod contents of the C<prereqs> field described in L<CPAN::Meta::Spec>, meaning
#pod something more or less like this:
#pod
#pod my $prereq = CPAN::Meta::Prereqs->new({
#pod runtime => {
#pod requires => {
#pod 'Some::Module' => '1.234',
#pod ...,
#pod },
#pod ...,
#pod },
#pod ...,
#pod });
#pod
#pod You can also construct an empty set of prereqs with:
#pod
#pod my $prereqs = CPAN::Meta::Prereqs->new;
#pod
#pod This empty set of prereqs is useful for accumulating new prereqs before finally
#pod dumping the whole set into a structure or string.
#pod
#pod =cut
# note we also accept anything matching /\Ax_/i
sub __legal_phases { qw(configure build test runtime develop) }
sub __legal_types { qw(requires recommends suggests conflicts) }
# expect a prereq spec from META.json -- rjbs, 2010-04-11
sub new {
my ($class, $prereq_spec) = @_;
$prereq_spec ||= {};
my %is_legal_phase = map {; $_ => 1 } $class->__legal_phases;
my %is_legal_type = map {; $_ => 1 } $class->__legal_types;
my %guts;
PHASE: for my $phase (keys %$prereq_spec) {
next PHASE unless $phase =~ /\Ax_/i or $is_legal_phase{$phase};
my $phase_spec = $prereq_spec->{ $phase };
next PHASE unless keys %$phase_spec;
TYPE: for my $type (keys %$phase_spec) {
next TYPE unless $type =~ /\Ax_/i or $is_legal_type{$type};
my $spec = $phase_spec->{ $type };
next TYPE unless keys %$spec;
$guts{prereqs}{$phase}{$type} = CPAN::Meta::Requirements->from_string_hash(
$spec
);
}
}
return bless \%guts => $class;
}
#pod =method requirements_for
#pod
#pod my $requirements = $prereqs->requirements_for( $phase, $type );
#pod
#pod This method returns a L<CPAN::Meta::Requirements> object for the given
#pod phase/type combination. If no prerequisites are registered for that
#pod combination, a new CPAN::Meta::Requirements object will be returned, and it may
#pod be added to as needed.
#pod
#pod If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will
#pod be raised.
#pod
#pod =cut
sub requirements_for {
my ($self, $phase, $type) = @_;
confess "requirements_for called without phase" unless defined $phase;
confess "requirements_for called without type" unless defined $type;
unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) {
confess "requested requirements for unknown phase: $phase";
}
unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) {
confess "requested requirements for unknown type: $type";
}
my $req = ($self->{prereqs}{$phase}{$type} ||= CPAN::Meta::Requirements->new);
$req->finalize if $self->is_finalized;
return $req;
}
#pod =method phases
#pod
#pod my @phases = $prereqs->phases;
#pod
#pod This method returns the list of all phases currently populated in the prereqs
#pod object, suitable for iterating.
#pod
#pod =cut
sub phases {
my ($self) = @_;
my %is_legal_phase = map {; $_ => 1 } $self->__legal_phases;
grep { /\Ax_/i or $is_legal_phase{$_} } keys %{ $self->{prereqs} };
}
#pod =method types_in
#pod
#pod my @runtime_types = $prereqs->types_in('runtime');
#pod
#pod This method returns the list of all types currently populated in the prereqs
#pod object for the provided phase, suitable for iterating.
#pod
#pod =cut
sub types_in {
my ($self, $phase) = @_;
return unless $phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases;
my %is_legal_type = map {; $_ => 1 } $self->__legal_types;
grep { /\Ax_/i or $is_legal_type{$_} } keys %{ $self->{prereqs}{$phase} };
}
#pod =method with_merged_prereqs
#pod
#pod my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs );
#pod
#pod my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs );
#pod
#pod This method returns a new CPAN::Meta::Prereqs objects in which all the
#pod other prerequisites given are merged into the current set. This is primarily
#pod provided for combining a distribution's core prereqs with the prereqs of one of
#pod its optional features.
#pod
#pod The new prereqs object has no ties to the originals, and altering it further
#pod will not alter them.
#pod
#pod =cut
sub with_merged_prereqs {
my ($self, $other) = @_;
my @other = blessed($other) ? $other : @$other;
my @prereq_objs = ($self, @other);
my %new_arg;
for my $phase (__uniq(map { $_->phases } @prereq_objs)) {
for my $type (__uniq(map { $_->types_in($phase) } @prereq_objs)) {
my $req = CPAN::Meta::Requirements->new;
for my $prereq (@prereq_objs) {
my $this_req = $prereq->requirements_for($phase, $type);
next unless $this_req->required_modules;
$req->add_requirements($this_req);
}
next unless $req->required_modules;
$new_arg{ $phase }{ $type } = $req->as_string_hash;
}
}
return (ref $self)->new(\%new_arg);
}
#pod =method merged_requirements
#pod
#pod my $new_reqs = $prereqs->merged_requirements( \@phases, \@types );
#pod my $new_reqs = $prereqs->merged_requirements( \@phases );
#pod my $new_reqs = $prereqs->merged_requirements();
#pod
#pod This method joins together all requirements across a number of phases
#pod and types into a new L<CPAN::Meta::Requirements> object. If arguments
#pod are omitted, it defaults to "runtime", "build" and "test" for phases
#pod and "requires" and "recommends" for types.
#pod
#pod =cut
sub merged_requirements {
my ($self, $phases, $types) = @_;
$phases = [qw/runtime build test/] unless defined $phases;
$types = [qw/requires recommends/] unless defined $types;
confess "merged_requirements phases argument must be an arrayref"
unless ref $phases eq 'ARRAY';
confess "merged_requirements types argument must be an arrayref"
unless ref $types eq 'ARRAY';
my $req = CPAN::Meta::Requirements->new;
for my $phase ( @$phases ) {
unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) {
confess "requested requirements for unknown phase: $phase";
}
for my $type ( @$types ) {
unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) {
confess "requested requirements for unknown type: $type";
}
$req->add_requirements( $self->requirements_for($phase, $type) );
}
}
$req->finalize if $self->is_finalized;
return $req;
}
#pod =method as_string_hash
#pod
#pod This method returns a hashref containing structures suitable for dumping into a
#pod distmeta data structure. It is made up of hashes and strings, only; there will
#pod be no Prereqs, CPAN::Meta::Requirements, or C<version> objects inside it.
#pod
#pod =cut
sub as_string_hash {
my ($self) = @_;
my %hash;
for my $phase ($self->phases) {
for my $type ($self->types_in($phase)) {
my $req = $self->requirements_for($phase, $type);
next unless $req->required_modules;
$hash{ $phase }{ $type } = $req->as_string_hash;
}
}
return \%hash;
}
#pod =method is_finalized
#pod
#pod This method returns true if the set of prereqs has been marked "finalized," and
#pod cannot be altered.
#pod
#pod =cut
sub is_finalized { $_[0]{finalized} }
#pod =method finalize
#pod
#pod Calling C<finalize> on a Prereqs object will close it for further modification.
#pod Attempting to make any changes that would actually alter the prereqs will
#pod result in an exception being thrown.
#pod
#pod =cut
sub finalize {
my ($self) = @_;
$self->{finalized} = 1;
for my $phase (keys %{ $self->{prereqs} }) {
$_->finalize for values %{ $self->{prereqs}{$phase} };
}
}
#pod =method clone
#pod
#pod my $cloned_prereqs = $prereqs->clone;
#pod
#pod This method returns a Prereqs object that is identical to the original object,
#pod but can be altered without affecting the original object. Finalization does
#pod not survive cloning, meaning that you may clone a finalized set of prereqs and
#pod then modify the clone.
#pod
#pod =cut
sub clone {
my ($self) = @_;
my $clone = (ref $self)->new( $self->as_string_hash );
}
sub __uniq {
my (%s, $u);
grep { defined($_) ? !$s{$_}++ : !$u++ } @_;
}
1;
# ABSTRACT: a set of distribution prerequisites by phase and type
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::Prereqs - a set of distribution prerequisites by phase and type
=head1 VERSION
version 2.150010
=head1 DESCRIPTION
A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN
distribution or one of its optional features. Each set of prereqs is
organized by phase and type, as described in L<CPAN::Meta::Prereqs>.
=head1 METHODS
=head2 new
my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec );
This method returns a new set of Prereqs. The input should look like the
contents of the C<prereqs> field described in L<CPAN::Meta::Spec>, meaning
something more or less like this:
my $prereq = CPAN::Meta::Prereqs->new({
runtime => {
requires => {
'Some::Module' => '1.234',
...,
},
...,
},
...,
});
You can also construct an empty set of prereqs with:
my $prereqs = CPAN::Meta::Prereqs->new;
This empty set of prereqs is useful for accumulating new prereqs before finally
dumping the whole set into a structure or string.
=head2 requirements_for
my $requirements = $prereqs->requirements_for( $phase, $type );
This method returns a L<CPAN::Meta::Requirements> object for the given
phase/type combination. If no prerequisites are registered for that
combination, a new CPAN::Meta::Requirements object will be returned, and it may
be added to as needed.
If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will
be raised.
=head2 phases
my @phases = $prereqs->phases;
This method returns the list of all phases currently populated in the prereqs
object, suitable for iterating.
=head2 types_in
my @runtime_types = $prereqs->types_in('runtime');
This method returns the list of all types currently populated in the prereqs
object for the provided phase, suitable for iterating.
=head2 with_merged_prereqs
my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs );
my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs );
This method returns a new CPAN::Meta::Prereqs objects in which all the
other prerequisites given are merged into the current set. This is primarily
provided for combining a distribution's core prereqs with the prereqs of one of
its optional features.
The new prereqs object has no ties to the originals, and altering it further
will not alter them.
=head2 merged_requirements
my $new_reqs = $prereqs->merged_requirements( \@phases, \@types );
my $new_reqs = $prereqs->merged_requirements( \@phases );
my $new_reqs = $prereqs->merged_requirements();
This method joins together all requirements across a number of phases
and types into a new L<CPAN::Meta::Requirements> object. If arguments
are omitted, it defaults to "runtime", "build" and "test" for phases
and "requires" and "recommends" for types.
=head2 as_string_hash
This method returns a hashref containing structures suitable for dumping into a
distmeta data structure. It is made up of hashes and strings, only; there will
be no Prereqs, CPAN::Meta::Requirements, or C<version> objects inside it.
=head2 is_finalized
This method returns true if the set of prereqs has been marked "finalized," and
cannot be altered.
=head2 finalize
Calling C<finalize> on a Prereqs object will close it for further modification.
Attempting to make any changes that would actually alter the prereqs will
result in an exception being thrown.
=head2 clone
my $cloned_prereqs = $prereqs->clone;
This method returns a Prereqs object that is identical to the original object,
but can be altered without affecting the original object. Finalization does
not survive cloning, meaning that you may clone a finalized set of prereqs and
then modify the clone.
=head1 BUGS
Please report any bugs or feature using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.
=head1 AUTHORS
=over 4
=item *
David Golden <dagolden@cpan.org>
=item *
Ricardo Signes <rjbs@cpan.org>
=item *
Adam Kennedy <adamk@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__
# vim: ts=2 sts=2 sw=2 et :

834
OGP64/usr/share/perl5/5.40/CPAN/Meta/Requirements.pm Normal file
View file

@ -0,0 +1,834 @@
use v5.10;
use strict;
use warnings;
package CPAN::Meta::Requirements;
# ABSTRACT: a set of version requirements for a CPAN dist
our $VERSION = '2.143';
use CPAN::Meta::Requirements::Range;
#pod =head1 SYNOPSIS
#pod
#pod use CPAN::Meta::Requirements;
#pod
#pod my $build_requires = CPAN::Meta::Requirements->new;
#pod
#pod $build_requires->add_minimum('Library::Foo' => 1.208);
#pod
#pod $build_requires->add_minimum('Library::Foo' => 2.602);
#pod
#pod $build_requires->add_minimum('Module::Bar' => 'v1.2.3');
#pod
#pod $METAyml->{build_requires} = $build_requires->as_string_hash;
#pod
#pod =head1 DESCRIPTION
#pod
#pod A CPAN::Meta::Requirements object models a set of version constraints like
#pod those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
#pod and as defined by L<CPAN::Meta::Spec>.
#pod It can be built up by adding more and more constraints, and it will reduce them
#pod to the simplest representation.
#pod
#pod Logically impossible constraints will be identified immediately by thrown
#pod exceptions.
#pod
#pod =cut
use Carp ();
#pod =method new
#pod
#pod my $req = CPAN::Meta::Requirements->new;
#pod
#pod This returns a new CPAN::Meta::Requirements object. It takes an optional
#pod hash reference argument. Currently, only one key is supported:
#pod
#pod =for :list
#pod * C<bad_version_hook> -- if provided, when a version cannot be parsed into
#pod a version object, this code reference will be called with the invalid
#pod version string as first argument, and the module name as second
#pod argument. It must return a valid version object.
#pod
#pod All other keys are ignored.
#pod
#pod =cut
my @valid_options = qw( bad_version_hook );
sub new {
my ($class, $options) = @_;
$options ||= {};
Carp::croak "Argument to $class\->new() must be a hash reference"
unless ref $options eq 'HASH';
my %self = map {; $_ => $options->{$_}} @valid_options;
return bless \%self => $class;
}
#pod =method add_minimum
#pod
#pod $req->add_minimum( $module => $version );
#pod
#pod This adds a new minimum version requirement. If the new requirement is
#pod redundant to the existing specification, this has no effect.
#pod
#pod Minimum requirements are inclusive. C<$version> is required, along with any
#pod greater version number.
#pod
#pod This method returns the requirements object.
#pod
#pod =method add_maximum
#pod
#pod $req->add_maximum( $module => $version );
#pod
#pod This adds a new maximum version requirement. If the new requirement is
#pod redundant to the existing specification, this has no effect.
#pod
#pod Maximum requirements are inclusive. No version strictly greater than the given
#pod version is allowed.
#pod
#pod This method returns the requirements object.
#pod
#pod =method add_exclusion
#pod
#pod $req->add_exclusion( $module => $version );
#pod
#pod This adds a new excluded version. For example, you might use these three
#pod method calls:
#pod
#pod $req->add_minimum( $module => '1.00' );
#pod $req->add_maximum( $module => '1.82' );
#pod
#pod $req->add_exclusion( $module => '1.75' );
#pod
#pod Any version between 1.00 and 1.82 inclusive would be acceptable, except for
#pod 1.75.
#pod
#pod This method returns the requirements object.
#pod
#pod =method exact_version
#pod
#pod $req->exact_version( $module => $version );
#pod
#pod This sets the version required for the given module to I<exactly> the given
#pod version. No other version would be considered acceptable.
#pod
#pod This method returns the requirements object.
#pod
#pod =cut
BEGIN {
for my $type (qw(maximum exclusion exact_version)) {
my $method = "with_$type";
my $to_add = $type eq 'exact_version' ? $type : "add_$type";
my $code = sub {
my ($self, $name, $version) = @_;
$self->__modify_entry_for($name, $method, $version);
return $self;
};
no strict 'refs';
*$to_add = $code;
}
}
# add_minimum is optimized compared to generated subs above because
# it is called frequently and with "0" or equivalent input
sub add_minimum {
my ($self, $name, $version) = @_;
# stringify $version so that version->new("0.00")->stringify ne "0"
# which preserves the user's choice of "0.00" as the requirement
if (not defined $version or "$version" eq '0') {
return $self if $self->__entry_for($name);
Carp::croak("can't add new requirements to finalized requirements")
if $self->is_finalized;
$self->{requirements}{ $name } =
CPAN::Meta::Requirements::Range->with_minimum('0', $name);
}
else {
$self->__modify_entry_for($name, 'with_minimum', $version);
}
return $self;
}
#pod =method version_range_for_module
#pod
#pod $req->version_range_for_module( $another_req_object );
#pod
#pod =cut
sub version_range_for_module {
my ($self, $module) = @_;
return $self->{requirements}{$module};
}
#pod =method add_requirements
#pod
#pod $req->add_requirements( $another_req_object );
#pod
#pod This method adds all the requirements in the given CPAN::Meta::Requirements
#pod object to the requirements object on which it was called. If there are any
#pod conflicts, an exception is thrown.
#pod
#pod This method returns the requirements object.
#pod
#pod =cut
sub add_requirements {
my ($self, $req) = @_;
for my $module ($req->required_modules) {
my $new_range = $req->version_range_for_module($module);
$self->__modify_entry_for($module, 'with_range', $new_range);
}
return $self;
}
#pod =method accepts_module
#pod
#pod my $bool = $req->accepts_module($module => $version);
#pod
#pod Given an module and version, this method returns true if the version
#pod specification for the module accepts the provided version. In other words,
#pod given:
#pod
#pod Module => '>= 1.00, < 2.00'
#pod
#pod We will accept 1.00 and 1.75 but not 0.50 or 2.00.
#pod
#pod For modules that do not appear in the requirements, this method will return
#pod true.
#pod
#pod =cut
sub accepts_module {
my ($self, $module, $version) = @_;
return 1 unless my $range = $self->__entry_for($module);
return $range->accepts($version);
}
#pod =method clear_requirement
#pod
#pod $req->clear_requirement( $module );
#pod
#pod This removes the requirement for a given module from the object.
#pod
#pod This method returns the requirements object.
#pod
#pod =cut
sub clear_requirement {
my ($self, $module) = @_;
return $self unless $self->__entry_for($module);
Carp::croak("can't clear requirements on finalized requirements")
if $self->is_finalized;
delete $self->{requirements}{ $module };
return $self;
}
#pod =method requirements_for_module
#pod
#pod $req->requirements_for_module( $module );
#pod
#pod This returns a string containing the version requirements for a given module in
#pod the format described in L<CPAN::Meta::Spec> or undef if the given module has no
#pod requirements. This should only be used for informational purposes such as error
#pod messages and should not be interpreted or used for comparison (see
#pod L</accepts_module> instead).
#pod
#pod =cut
sub requirements_for_module {
my ($self, $module) = @_;
my $entry = $self->__entry_for($module);
return unless $entry;
return $entry->as_string;
}
#pod =method structured_requirements_for_module
#pod
#pod $req->structured_requirements_for_module( $module );
#pod
#pod This returns a data structure containing the version requirements for a given
#pod module or undef if the given module has no requirements. This should
#pod not be used for version checks (see L</accepts_module> instead).
#pod
#pod Added in version 2.134.
#pod
#pod =cut
sub structured_requirements_for_module {
my ($self, $module) = @_;
my $entry = $self->__entry_for($module);
return unless $entry;
return $entry->as_struct;
}
#pod =method required_modules
#pod
#pod This method returns a list of all the modules for which requirements have been
#pod specified.
#pod
#pod =cut
sub required_modules { keys %{ $_[0]{requirements} } }
#pod =method clone
#pod
#pod $req->clone;
#pod
#pod This method returns a clone of the invocant. The clone and the original object
#pod can then be changed independent of one another.
#pod
#pod =cut
sub clone {
my ($self) = @_;
my $new = (ref $self)->new;
return $new->add_requirements($self);
}
sub __entry_for { $_[0]{requirements}{ $_[1] } }
sub __modify_entry_for {
my ($self, $name, $method, $version) = @_;
my $fin = $self->is_finalized;
my $old = $self->__entry_for($name);
Carp::croak("can't add new requirements to finalized requirements")
if $fin and not $old;
my $new = ($old || 'CPAN::Meta::Requirements::Range')
->$method($version, $name, $self->{bad_version_hook});
Carp::croak("can't modify finalized requirements")
if $fin and $old->as_string ne $new->as_string;
$self->{requirements}{ $name } = $new;
}
#pod =method is_simple
#pod
#pod This method returns true if and only if all requirements are inclusive minimums
#pod -- that is, if their string expression is just the version number.
#pod
#pod =cut
sub is_simple {
my ($self) = @_;
for my $module ($self->required_modules) {
# XXX: This is a complete hack, but also entirely correct.
return if not $self->__entry_for($module)->is_simple;
}
return 1;
}
#pod =method is_finalized
#pod
#pod This method returns true if the requirements have been finalized by having the
#pod C<finalize> method called on them.
#pod
#pod =cut
sub is_finalized { $_[0]{finalized} }
#pod =method finalize
#pod
#pod This method marks the requirements finalized. Subsequent attempts to change
#pod the requirements will be fatal, I<if> they would result in a change. If they
#pod would not alter the requirements, they have no effect.
#pod
#pod If a finalized set of requirements is cloned, the cloned requirements are not
#pod also finalized.
#pod
#pod =cut
sub finalize { $_[0]{finalized} = 1 }
#pod =method as_string_hash
#pod
#pod This returns a reference to a hash describing the requirements using the
#pod strings in the L<CPAN::Meta::Spec> specification.
#pod
#pod For example after the following program:
#pod
#pod my $req = CPAN::Meta::Requirements->new;
#pod
#pod $req->add_minimum('CPAN::Meta::Requirements' => 0.102);
#pod
#pod $req->add_minimum('Library::Foo' => 1.208);
#pod
#pod $req->add_maximum('Library::Foo' => 2.602);
#pod
#pod $req->add_minimum('Module::Bar' => 'v1.2.3');
#pod
#pod $req->add_exclusion('Module::Bar' => 'v1.2.8');
#pod
#pod $req->exact_version('Xyzzy' => '6.01');
#pod
#pod my $hashref = $req->as_string_hash;
#pod
#pod C<$hashref> would contain:
#pod
#pod {
#pod 'CPAN::Meta::Requirements' => '0.102',
#pod 'Library::Foo' => '>= 1.208, <= 2.206',
#pod 'Module::Bar' => '>= v1.2.3, != v1.2.8',
#pod 'Xyzzy' => '== 6.01',
#pod }
#pod
#pod =cut
sub as_string_hash {
my ($self) = @_;
my %hash = map {; $_ => $self->{requirements}{$_}->as_string }
$self->required_modules;
return \%hash;
}
#pod =method add_string_requirement
#pod
#pod $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206');
#pod $req->add_string_requirement('Library::Foo' => v1.208);
#pod
#pod This method parses the passed in string and adds the appropriate requirement
#pod for the given module. A version can be a Perl "v-string". It understands
#pod version ranges as described in the L<CPAN::Meta::Spec/Version Ranges>. For
#pod example:
#pod
#pod =over 4
#pod
#pod =item 1.3
#pod
#pod =item >= 1.3
#pod
#pod =item <= 1.3
#pod
#pod =item == 1.3
#pod
#pod =item != 1.3
#pod
#pod =item > 1.3
#pod
#pod =item < 1.3
#pod
#pod =item >= 1.3, != 1.5, <= 2.0
#pod
#pod A version number without an operator is equivalent to specifying a minimum
#pod (C<E<gt>=>). Extra whitespace is allowed.
#pod
#pod =back
#pod
#pod =cut
sub add_string_requirement {
my ($self, $module, $req) = @_;
$self->__modify_entry_for($module, 'with_string_requirement', $req);
}
#pod =method from_string_hash
#pod
#pod my $req = CPAN::Meta::Requirements->from_string_hash( \%hash );
#pod my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts );
#pod
#pod This is an alternate constructor for a CPAN::Meta::Requirements
#pod object. It takes a hash of module names and version requirement
#pod strings and returns a new CPAN::Meta::Requirements object. As with
#pod add_string_requirement, a version can be a Perl "v-string". Optionally,
#pod you can supply a hash-reference of options, exactly as with the L</new>
#pod method.
#pod
#pod =cut
sub from_string_hash {
my ($class, $hash, $options) = @_;
my $self = $class->new($options);
for my $module (keys %$hash) {
my $req = $hash->{$module};
$self->add_string_requirement($module, $req);
}
return $self;
}
1;
# vim: ts=2 sts=2 sw=2 et:
__END__
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::Requirements - a set of version requirements for a CPAN dist
=head1 VERSION
version 2.143
=head1 SYNOPSIS
use CPAN::Meta::Requirements;
my $build_requires = CPAN::Meta::Requirements->new;
$build_requires->add_minimum('Library::Foo' => 1.208);
$build_requires->add_minimum('Library::Foo' => 2.602);
$build_requires->add_minimum('Module::Bar' => 'v1.2.3');
$METAyml->{build_requires} = $build_requires->as_string_hash;
=head1 DESCRIPTION
A CPAN::Meta::Requirements object models a set of version constraints like
those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
and as defined by L<CPAN::Meta::Spec>.
It can be built up by adding more and more constraints, and it will reduce them
to the simplest representation.
Logically impossible constraints will be identified immediately by thrown
exceptions.
=head1 METHODS
=head2 new
my $req = CPAN::Meta::Requirements->new;
This returns a new CPAN::Meta::Requirements object. It takes an optional
hash reference argument. Currently, only one key is supported:
=over 4
=item *
C<bad_version_hook> -- if provided, when a version cannot be parsed into a version object, this code reference will be called with the invalid version string as first argument, and the module name as second argument. It must return a valid version object.
=back
All other keys are ignored.
=head2 add_minimum
$req->add_minimum( $module => $version );
This adds a new minimum version requirement. If the new requirement is
redundant to the existing specification, this has no effect.
Minimum requirements are inclusive. C<$version> is required, along with any
greater version number.
This method returns the requirements object.
=head2 add_maximum
$req->add_maximum( $module => $version );
This adds a new maximum version requirement. If the new requirement is
redundant to the existing specification, this has no effect.
Maximum requirements are inclusive. No version strictly greater than the given
version is allowed.
This method returns the requirements object.
=head2 add_exclusion
$req->add_exclusion( $module => $version );
This adds a new excluded version. For example, you might use these three
method calls:
$req->add_minimum( $module => '1.00' );
$req->add_maximum( $module => '1.82' );
$req->add_exclusion( $module => '1.75' );
Any version between 1.00 and 1.82 inclusive would be acceptable, except for
1.75.
This method returns the requirements object.
=head2 exact_version
$req->exact_version( $module => $version );
This sets the version required for the given module to I<exactly> the given
version. No other version would be considered acceptable.
This method returns the requirements object.
=head2 version_range_for_module
$req->version_range_for_module( $another_req_object );
=head2 add_requirements
$req->add_requirements( $another_req_object );
This method adds all the requirements in the given CPAN::Meta::Requirements
object to the requirements object on which it was called. If there are any
conflicts, an exception is thrown.
This method returns the requirements object.
=head2 accepts_module
my $bool = $req->accepts_module($module => $version);
Given an module and version, this method returns true if the version
specification for the module accepts the provided version. In other words,
given:
Module => '>= 1.00, < 2.00'
We will accept 1.00 and 1.75 but not 0.50 or 2.00.
For modules that do not appear in the requirements, this method will return
true.
=head2 clear_requirement
$req->clear_requirement( $module );
This removes the requirement for a given module from the object.
This method returns the requirements object.
=head2 requirements_for_module
$req->requirements_for_module( $module );
This returns a string containing the version requirements for a given module in
the format described in L<CPAN::Meta::Spec> or undef if the given module has no
requirements. This should only be used for informational purposes such as error
messages and should not be interpreted or used for comparison (see
L</accepts_module> instead).
=head2 structured_requirements_for_module
$req->structured_requirements_for_module( $module );
This returns a data structure containing the version requirements for a given
module or undef if the given module has no requirements. This should
not be used for version checks (see L</accepts_module> instead).
Added in version 2.134.
=head2 required_modules
This method returns a list of all the modules for which requirements have been
specified.
=head2 clone
$req->clone;
This method returns a clone of the invocant. The clone and the original object
can then be changed independent of one another.
=head2 is_simple
This method returns true if and only if all requirements are inclusive minimums
-- that is, if their string expression is just the version number.
=head2 is_finalized
This method returns true if the requirements have been finalized by having the
C<finalize> method called on them.
=head2 finalize
This method marks the requirements finalized. Subsequent attempts to change
the requirements will be fatal, I<if> they would result in a change. If they
would not alter the requirements, they have no effect.
If a finalized set of requirements is cloned, the cloned requirements are not
also finalized.
=head2 as_string_hash
This returns a reference to a hash describing the requirements using the
strings in the L<CPAN::Meta::Spec> specification.
For example after the following program:
my $req = CPAN::Meta::Requirements->new;
$req->add_minimum('CPAN::Meta::Requirements' => 0.102);
$req->add_minimum('Library::Foo' => 1.208);
$req->add_maximum('Library::Foo' => 2.602);
$req->add_minimum('Module::Bar' => 'v1.2.3');
$req->add_exclusion('Module::Bar' => 'v1.2.8');
$req->exact_version('Xyzzy' => '6.01');
my $hashref = $req->as_string_hash;
C<$hashref> would contain:
{
'CPAN::Meta::Requirements' => '0.102',
'Library::Foo' => '>= 1.208, <= 2.206',
'Module::Bar' => '>= v1.2.3, != v1.2.8',
'Xyzzy' => '== 6.01',
}
=head2 add_string_requirement
$req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206');
$req->add_string_requirement('Library::Foo' => v1.208);
This method parses the passed in string and adds the appropriate requirement
for the given module. A version can be a Perl "v-string". It understands
version ranges as described in the L<CPAN::Meta::Spec/Version Ranges>. For
example:
=over 4
=item 1.3
=item >= 1.3
=item <= 1.3
=item == 1.3
=item != 1.3
=item > 1.3
=item < 1.3
=item >= 1.3, != 1.5, <= 2.0
A version number without an operator is equivalent to specifying a minimum
(C<E<gt>=>). Extra whitespace is allowed.
=back
=head2 from_string_hash
my $req = CPAN::Meta::Requirements->from_string_hash( \%hash );
my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts );
This is an alternate constructor for a CPAN::Meta::Requirements
object. It takes a hash of module names and version requirement
strings and returns a new CPAN::Meta::Requirements object. As with
add_string_requirement, a version can be a Perl "v-string". Optionally,
you can supply a hash-reference of options, exactly as with the L</new>
method.
=for :stopwords cpan testmatrix url bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
=head1 SUPPORT
=head2 Bugs / Feature Requests
Please report any bugs or feature requests through the issue tracker
at L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements/issues>.
You will be notified automatically of any progress on your issue.
=head2 Source Code
This is open source software. The code repository is available for
public review and contribution under the terms of the license.
L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements>
git clone https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements.git
=head1 AUTHORS
=over 4
=item *
David Golden <dagolden@cpan.org>
=item *
Ricardo Signes <rjbs@cpan.org>
=back
=head1 CONTRIBUTORS
=for stopwords Ed J Graham Knop Karen Etheridge Leon Timmermans Paul Howarth Ricardo Signes robario Tatsuhiko Miyagawa
=over 4
=item *
Ed J <mohawk2@users.noreply.github.com>
=item *
Graham Knop <haarg@haarg.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Leon Timmermans <fawaka@gmail.com>
=item *
Paul Howarth <paul@city-fan.org>
=item *
Ricardo Signes <rjbs@semiotic.systems>
=item *
robario <webmaster@robario.com>
=item *
Tatsuhiko Miyagawa <miyagawa@bulknews.net>
=item *
Tatsuhiko Miyagawa <miyagawa@gmail.com>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden and Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

776
OGP64/usr/share/perl5/5.40/CPAN/Meta/Requirements/Range.pm Normal file
View file

@ -0,0 +1,776 @@
use v5.10;
use strict;
use warnings;
package CPAN::Meta::Requirements::Range;
# ABSTRACT: a set of version requirements for a CPAN dist
our $VERSION = '2.143';
use Carp ();
#pod =head1 SYNOPSIS
#pod
#pod use CPAN::Meta::Requirements::Range;
#pod
#pod my $range = CPAN::Meta::Requirements::Range->with_minimum(1);
#pod
#pod $range = $range->with_maximum('v2.2');
#pod
#pod my $stringified = $range->as_string;
#pod
#pod =head1 DESCRIPTION
#pod
#pod A CPAN::Meta::Requirements::Range object models a set of version constraints like
#pod those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
#pod and as defined by L<CPAN::Meta::Spec>;
#pod It can be built up by adding more and more constraints, and it will reduce them
#pod to the simplest representation.
#pod
#pod Logically impossible constraints will be identified immediately by thrown
#pod exceptions.
#pod
#pod =cut
use Carp ();
package
CPAN::Meta::Requirements::Range::_Base;
# To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls
# before 5.10, we fall back to the EUMM bundled compatibility version module if
# that's the only thing available. This shouldn't ever happen in a normal CPAN
# install of CPAN::Meta::Requirements, as version.pm will be picked up from
# prereqs and be available at runtime.
BEGIN {
eval "use version ()"; ## no critic
if ( my $err = $@ ) {
eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic
}
}
# from version::vpp
sub _find_magic_vstring {
my $value = shift;
my $tvalue = '';
require B;
my $sv = B::svref_2object(\$value);
my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
while ( $magic ) {
if ( $magic->TYPE eq 'V' ) {
$tvalue = $magic->PTR;
$tvalue =~ s/^v?(.+)$/v$1/;
last;
}
else {
$magic = $magic->MOREMAGIC;
}
}
return $tvalue;
}
# Perl 5.10.0 didn't have "is_qv" in version.pm
*_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} };
# construct once, reuse many times
my $V0 = version->new(0);
# safe if given an unblessed reference
sub _isa_version {
UNIVERSAL::isa( $_[0], 'UNIVERSAL' ) && $_[0]->isa('version')
}
sub _version_object {
my ($self, $version, $module, $bad_version_hook) = @_;
my ($vobj, $err);
if (not defined $version or (!ref($version) && $version eq '0')) {
return $V0;
}
elsif ( ref($version) eq 'version' || ( ref($version) && _isa_version($version) ) ) {
$vobj = $version;
}
else {
# hack around version::vpp not handling <3 character vstring literals
if ( $INC{'version/vpp.pm'} || $INC{'ExtUtils/MakeMaker/version/vpp.pm'} ) {
my $magic = _find_magic_vstring( $version );
$version = $magic if length $magic;
}
# pad to 3 characters if before 5.8.1 and appears to be a v-string
if ( $] < 5.008001 && $version !~ /\A[0-9]/ && substr($version,0,1) ne 'v' && length($version) < 3 ) {
$version .= "\0" x (3 - length($version));
}
eval {
local $SIG{__WARN__} = sub { die "Invalid version: $_[0]" };
# avoid specific segfault on some older version.pm versions
die "Invalid version: $version" if $version eq 'version';
$vobj = version->new($version);
};
if ( my $err = $@ ) {
$vobj = eval { $bad_version_hook->($version, $module) }
if ref $bad_version_hook eq 'CODE';
unless (eval { $vobj->isa("version") }) {
$err =~ s{ at .* line \d+.*$}{};
die "Can't convert '$version': $err";
}
}
}
# ensure no leading '.'
if ( $vobj =~ m{\A\.} ) {
$vobj = version->new("0$vobj");
}
# ensure normal v-string form
if ( _is_qv($vobj) ) {
$vobj = version->new($vobj->normal);
}
return $vobj;
}
#pod =method with_string_requirement
#pod
#pod $req->with_string_requirement('>= 1.208, <= 2.206');
#pod $req->with_string_requirement(v1.208);
#pod
#pod This method parses the passed in string and adds the appropriate requirement.
#pod A version can be a Perl "v-string". It understands version ranges as described
#pod in the L<CPAN::Meta::Spec/Version Ranges>. For example:
#pod
#pod =over 4
#pod
#pod =item 1.3
#pod
#pod =item >= 1.3
#pod
#pod =item <= 1.3
#pod
#pod =item == 1.3
#pod
#pod =item != 1.3
#pod
#pod =item > 1.3
#pod
#pod =item < 1.3
#pod
#pod =item >= 1.3, != 1.5, <= 2.0
#pod
#pod A version number without an operator is equivalent to specifying a minimum
#pod (C<E<gt>=>). Extra whitespace is allowed.
#pod
#pod =back
#pod
#pod =cut
my %methods_for_op = (
'==' => [ qw(with_exact_version) ],
'!=' => [ qw(with_exclusion) ],
'>=' => [ qw(with_minimum) ],
'<=' => [ qw(with_maximum) ],
'>' => [ qw(with_minimum with_exclusion) ],
'<' => [ qw(with_maximum with_exclusion) ],
);
sub with_string_requirement {
my ($self, $req, $module, $bad_version_hook) = @_;
$module //= 'module';
unless ( defined $req && length $req ) {
$req = 0;
Carp::carp("Undefined requirement for $module treated as '0'");
}
my $magic = _find_magic_vstring( $req );
if (length $magic) {
return $self->with_minimum($magic, $module, $bad_version_hook);
}
my @parts = split qr{\s*,\s*}, $req;
for my $part (@parts) {
my ($op, $ver) = $part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z};
if (! defined $op) {
$self = $self->with_minimum($part, $module, $bad_version_hook);
} else {
Carp::croak("illegal requirement string: $req")
unless my $methods = $methods_for_op{ $op };
$self = $self->$_($ver, $module, $bad_version_hook) for @$methods;
}
}
return $self;
}
#pod =method with_range
#pod
#pod $range->with_range($other_range)
#pod
#pod This creates a new range object that is a merge two others.
#pod
#pod =cut
sub with_range {
my ($self, $other, $module, $bad_version_hook) = @_;
for my $modifier($other->_as_modifiers) {
my ($method, $arg) = @$modifier;
$self = $self->$method($arg, $module, $bad_version_hook);
}
return $self;
}
package CPAN::Meta::Requirements::Range;
our @ISA = 'CPAN::Meta::Requirements::Range::_Base';
sub _clone {
return (bless { } => $_[0]) unless ref $_[0];
my ($s) = @_;
my %guts = (
(exists $s->{minimum} ? (minimum => version->new($s->{minimum})) : ()),
(exists $s->{maximum} ? (maximum => version->new($s->{maximum})) : ()),
(exists $s->{exclusions}
? (exclusions => [ map { version->new($_) } @{ $s->{exclusions} } ])
: ()),
);
bless \%guts => ref($s);
}
#pod =method with_exact_version
#pod
#pod $range->with_exact_version( $version );
#pod
#pod This sets the version required to I<exactly> the given
#pod version. No other version would be considered acceptable.
#pod
#pod This method returns the version range object.
#pod
#pod =cut
sub with_exact_version {
my ($self, $version, $module, $bad_version_hook) = @_;
$module //= 'module';
$self = $self->_clone;
$version = $self->_version_object($version, $module, $bad_version_hook);
unless ($self->accepts($version)) {
$self->_reject_requirements(
$module,
"exact specification $version outside of range " . $self->as_string
);
}
return CPAN::Meta::Requirements::Range::_Exact->_new($version);
}
sub _simplify {
my ($self, $module) = @_;
if (defined $self->{minimum} and defined $self->{maximum}) {
if ($self->{minimum} == $self->{maximum}) {
if (grep { $_ == $self->{minimum} } @{ $self->{exclusions} || [] }) {
$self->_reject_requirements(
$module,
"minimum and maximum are both $self->{minimum}, which is excluded",
);
}
return CPAN::Meta::Requirements::Range::_Exact->_new($self->{minimum});
}
if ($self->{minimum} > $self->{maximum}) {
$self->_reject_requirements(
$module,
"minimum $self->{minimum} exceeds maximum $self->{maximum}",
);
}
}
# eliminate irrelevant exclusions
if ($self->{exclusions}) {
my %seen;
@{ $self->{exclusions} } = grep {
(! defined $self->{minimum} or $_ >= $self->{minimum})
and
(! defined $self->{maximum} or $_ <= $self->{maximum})
and
! $seen{$_}++
} @{ $self->{exclusions} };
}
return $self;
}
#pod =method with_minimum
#pod
#pod $range->with_minimum( $version );
#pod
#pod This adds a new minimum version requirement. If the new requirement is
#pod redundant to the existing specification, this has no effect.
#pod
#pod Minimum requirements are inclusive. C<$version> is required, along with any
#pod greater version number.
#pod
#pod This method returns the version range object.
#pod
#pod =cut
sub with_minimum {
my ($self, $minimum, $module, $bad_version_hook) = @_;
$module //= 'module';
$self = $self->_clone;
$minimum = $self->_version_object( $minimum, $module, $bad_version_hook );
if (defined (my $old_min = $self->{minimum})) {
$self->{minimum} = (sort { $b cmp $a } ($minimum, $old_min))[0];
} else {
$self->{minimum} = $minimum;
}
return $self->_simplify($module);
}
#pod =method with_maximum
#pod
#pod $range->with_maximum( $version );
#pod
#pod This adds a new maximum version requirement. If the new requirement is
#pod redundant to the existing specification, this has no effect.
#pod
#pod Maximum requirements are inclusive. No version strictly greater than the given
#pod version is allowed.
#pod
#pod This method returns the version range object.
#pod
#pod =cut
sub with_maximum {
my ($self, $maximum, $module, $bad_version_hook) = @_;
$module //= 'module';
$self = $self->_clone;
$maximum = $self->_version_object( $maximum, $module, $bad_version_hook );
if (defined (my $old_max = $self->{maximum})) {
$self->{maximum} = (sort { $a cmp $b } ($maximum, $old_max))[0];
} else {
$self->{maximum} = $maximum;
}
return $self->_simplify($module);
}
#pod =method with_exclusion
#pod
#pod $range->with_exclusion( $version );
#pod
#pod This adds a new excluded version. For example, you might use these three
#pod method calls:
#pod
#pod $range->with_minimum( '1.00' );
#pod $range->with_maximum( '1.82' );
#pod
#pod $range->with_exclusion( '1.75' );
#pod
#pod Any version between 1.00 and 1.82 inclusive would be acceptable, except for
#pod 1.75.
#pod
#pod This method returns the requirements object.
#pod
#pod =cut
sub with_exclusion {
my ($self, $exclusion, $module, $bad_version_hook) = @_;
$module //= 'module';
$self = $self->_clone;
$exclusion = $self->_version_object( $exclusion, $module, $bad_version_hook );
push @{ $self->{exclusions} ||= [] }, $exclusion;
return $self->_simplify($module);
}
sub _as_modifiers {
my ($self) = @_;
my @mods;
push @mods, [ with_minimum => $self->{minimum} ] if exists $self->{minimum};
push @mods, [ with_maximum => $self->{maximum} ] if exists $self->{maximum};
push @mods, map {; [ with_exclusion => $_ ] } @{$self->{exclusions} || []};
return @mods;
}
#pod =method as_struct
#pod
#pod $range->as_struct( $module );
#pod
#pod This returns a data structure containing the version requirements. This should
#pod not be used for version checks (see L</accepts_module> instead).
#pod
#pod =cut
sub as_struct {
my ($self) = @_;
return 0 if ! keys %$self;
my @exclusions = @{ $self->{exclusions} || [] };
my @parts;
for my $tuple (
[ qw( >= > minimum ) ],
[ qw( <= < maximum ) ],
) {
my ($op, $e_op, $k) = @$tuple;
if (exists $self->{$k}) {
my @new_exclusions = grep { $_ != $self->{ $k } } @exclusions;
if (@new_exclusions == @exclusions) {
push @parts, [ $op, "$self->{ $k }" ];
} else {
push @parts, [ $e_op, "$self->{ $k }" ];
@exclusions = @new_exclusions;
}
}
}
push @parts, map {; [ "!=", "$_" ] } @exclusions;
return \@parts;
}
#pod =method as_string
#pod
#pod $range->as_string;
#pod
#pod This returns a string containing the version requirements in the format
#pod described in L<CPAN::Meta::Spec>. This should only be used for informational
#pod purposes such as error messages and should not be interpreted or used for
#pod comparison (see L</accepts> instead).
#pod
#pod =cut
sub as_string {
my ($self) = @_;
my @parts = @{ $self->as_struct };
return $parts[0][1] if @parts == 1 and $parts[0][0] eq '>=';
return join q{, }, map {; join q{ }, @$_ } @parts;
}
sub _reject_requirements {
my ($self, $module, $error) = @_;
Carp::croak("illegal requirements for $module: $error")
}
#pod =method accepts
#pod
#pod my $bool = $range->accepts($version);
#pod
#pod Given a version, this method returns true if the version specification
#pod accepts the provided version. In other words, given:
#pod
#pod '>= 1.00, < 2.00'
#pod
#pod We will accept 1.00 and 1.75 but not 0.50 or 2.00.
#pod
#pod =cut
sub accepts {
my ($self, $version) = @_;
return if defined $self->{minimum} and $version < $self->{minimum};
return if defined $self->{maximum} and $version > $self->{maximum};
return if defined $self->{exclusions}
and grep { $version == $_ } @{ $self->{exclusions} };
return 1;
}
#pod =method is_simple
#pod
#pod This method returns true if and only if the range is an inclusive minimum
#pod -- that is, if their string expression is just the version number.
#pod
#pod =cut
sub is_simple {
my ($self) = @_;
# XXX: This is a complete hack, but also entirely correct.
return if $self->as_string =~ /\s/;
return 1;
}
package
CPAN::Meta::Requirements::Range::_Exact;
our @ISA = 'CPAN::Meta::Requirements::Range::_Base';
our $VERSION = '2.141';
BEGIN {
eval "use version ()"; ## no critic
if ( my $err = $@ ) {
eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic
}
}
sub _new { bless { version => $_[1] } => $_[0] }
sub accepts { return $_[0]{version} == $_[1] }
sub _reject_requirements {
my ($self, $module, $error) = @_;
Carp::croak("illegal requirements for $module: $error")
}
sub _clone {
(ref $_[0])->_new( version->new( $_[0]{version} ) )
}
sub with_exact_version {
my ($self, $version, $module, $bad_version_hook) = @_;
$module //= 'module';
$version = $self->_version_object($version, $module, $bad_version_hook);
return $self->_clone if $self->accepts($version);
$self->_reject_requirements(
$module,
"can't be exactly $version when exact requirement is already $self->{version}",
);
}
sub with_minimum {
my ($self, $minimum, $module, $bad_version_hook) = @_;
$module //= 'module';
$minimum = $self->_version_object( $minimum, $module, $bad_version_hook );
return $self->_clone if $self->{version} >= $minimum;
$self->_reject_requirements(
$module,
"minimum $minimum exceeds exact specification $self->{version}",
);
}
sub with_maximum {
my ($self, $maximum, $module, $bad_version_hook) = @_;
$module //= 'module';
$maximum = $self->_version_object( $maximum, $module, $bad_version_hook );
return $self->_clone if $self->{version} <= $maximum;
$self->_reject_requirements(
$module,
"maximum $maximum below exact specification $self->{version}",
);
}
sub with_exclusion {
my ($self, $exclusion, $module, $bad_version_hook) = @_;
$module //= 'module';
$exclusion = $self->_version_object( $exclusion, $module, $bad_version_hook );
return $self->_clone unless $exclusion == $self->{version};
$self->_reject_requirements(
$module,
"tried to exclude $exclusion, which is already exactly specified",
);
}
sub as_string { return "== $_[0]{version}" }
sub as_struct { return [ [ '==', "$_[0]{version}" ] ] }
sub _as_modifiers { return [ with_exact_version => $_[0]{version} ] }
1;
# vim: ts=2 sts=2 sw=2 et:
__END__
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::Requirements::Range - a set of version requirements for a CPAN dist
=head1 VERSION
version 2.143
=head1 SYNOPSIS
use CPAN::Meta::Requirements::Range;
my $range = CPAN::Meta::Requirements::Range->with_minimum(1);
$range = $range->with_maximum('v2.2');
my $stringified = $range->as_string;
=head1 DESCRIPTION
A CPAN::Meta::Requirements::Range object models a set of version constraints like
those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
and as defined by L<CPAN::Meta::Spec>;
It can be built up by adding more and more constraints, and it will reduce them
to the simplest representation.
Logically impossible constraints will be identified immediately by thrown
exceptions.
=head1 METHODS
=head2 with_string_requirement
$req->with_string_requirement('>= 1.208, <= 2.206');
$req->with_string_requirement(v1.208);
This method parses the passed in string and adds the appropriate requirement.
A version can be a Perl "v-string". It understands version ranges as described
in the L<CPAN::Meta::Spec/Version Ranges>. For example:
=over 4
=item 1.3
=item >= 1.3
=item <= 1.3
=item == 1.3
=item != 1.3
=item > 1.3
=item < 1.3
=item >= 1.3, != 1.5, <= 2.0
A version number without an operator is equivalent to specifying a minimum
(C<E<gt>=>). Extra whitespace is allowed.
=back
=head2 with_range
$range->with_range($other_range)
This creates a new range object that is a merge two others.
=head2 with_exact_version
$range->with_exact_version( $version );
This sets the version required to I<exactly> the given
version. No other version would be considered acceptable.
This method returns the version range object.
=head2 with_minimum
$range->with_minimum( $version );
This adds a new minimum version requirement. If the new requirement is
redundant to the existing specification, this has no effect.
Minimum requirements are inclusive. C<$version> is required, along with any
greater version number.
This method returns the version range object.
=head2 with_maximum
$range->with_maximum( $version );
This adds a new maximum version requirement. If the new requirement is
redundant to the existing specification, this has no effect.
Maximum requirements are inclusive. No version strictly greater than the given
version is allowed.
This method returns the version range object.
=head2 with_exclusion
$range->with_exclusion( $version );
This adds a new excluded version. For example, you might use these three
method calls:
$range->with_minimum( '1.00' );
$range->with_maximum( '1.82' );
$range->with_exclusion( '1.75' );
Any version between 1.00 and 1.82 inclusive would be acceptable, except for
1.75.
This method returns the requirements object.
=head2 as_struct
$range->as_struct( $module );
This returns a data structure containing the version requirements. This should
not be used for version checks (see L</accepts_module> instead).
=head2 as_string
$range->as_string;
This returns a string containing the version requirements in the format
described in L<CPAN::Meta::Spec>. This should only be used for informational
purposes such as error messages and should not be interpreted or used for
comparison (see L</accepts> instead).
=head2 accepts
my $bool = $range->accepts($version);
Given a version, this method returns true if the version specification
accepts the provided version. In other words, given:
'>= 1.00, < 2.00'
We will accept 1.00 and 1.75 but not 0.50 or 2.00.
=head2 is_simple
This method returns true if and only if the range is an inclusive minimum
-- that is, if their string expression is just the version number.
=head1 AUTHORS
=over 4
=item *
David Golden <dagolden@cpan.org>
=item *
Ricardo Signes <rjbs@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden and Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

1244
OGP64/usr/share/perl5/5.40/CPAN/Meta/Spec.pm Normal file
View file

File diff suppressed because it is too large Load diff

1214
OGP64/usr/share/perl5/5.40/CPAN/Meta/Validator.pm Normal file
View file

File diff suppressed because it is too large Load diff

951
OGP64/usr/share/perl5/5.40/CPAN/Meta/YAML.pm Normal file
View file

@ -0,0 +1,951 @@
use 5.008001; # sane UTF-8 support
use strict;
use warnings;
package CPAN::Meta::YAML; # git description: v1.68-2-gcc5324e
# XXX-INGY is 5.8.1 too old/broken for utf8?
# XXX-XDG Lancaster consensus was that it was sufficient until
# proven otherwise
$CPAN::Meta::YAML::VERSION = '0.018';
; # original $VERSION removed by Doppelgaenger
#####################################################################
# The CPAN::Meta::YAML API.
#
# These are the currently documented API functions/methods and
# exports:
use Exporter;
our @ISA = qw{ Exporter };
our @EXPORT = qw{ Load Dump };
our @EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };
###
# Functional/Export API:
sub Dump {
return CPAN::Meta::YAML->new(@_)->_dump_string;
}
# XXX-INGY Returning last document seems a bad behavior.
# XXX-XDG I think first would seem more natural, but I don't know
# that it's worth changing now
sub Load {
my $self = CPAN::Meta::YAML->_load_string(@_);
if ( wantarray ) {
return @$self;
} else {
# To match YAML.pm, return the last document
return $self->[-1];
}
}
# XXX-INGY Do we really need freeze and thaw?
# XXX-XDG I don't think so. I'd support deprecating them.
BEGIN {
*freeze = \&Dump;
*thaw = \&Load;
}
sub DumpFile {
my $file = shift;
return CPAN::Meta::YAML->new(@_)->_dump_file($file);
}
sub LoadFile {
my $file = shift;
my $self = CPAN::Meta::YAML->_load_file($file);
if ( wantarray ) {
return @$self;
} else {
# Return only the last document to match YAML.pm,
return $self->[-1];
}
}
###
# Object Oriented API:
# Create an empty CPAN::Meta::YAML object
# XXX-INGY Why do we use ARRAY object?
# NOTE: I get it now, but I think it's confusing and not needed.
# Will change it on a branch later, for review.
#
# XXX-XDG I don't support changing it yet. It's a very well-documented
# "API" of CPAN::Meta::YAML. I'd support deprecating it, but Adam suggested
# we not change it until YAML.pm's own OO API is established so that
# users only have one API change to digest, not two
sub new {
my $class = shift;
bless [ @_ ], $class;
}
# XXX-INGY It probably doesn't matter, and it's probably too late to
# change, but 'read/write' are the wrong names. Read and Write
# are actions that take data from storage to memory
# characters/strings. These take the data to/from storage to native
# Perl objects, which the terms dump and load are meant. As long as
# this is a legacy quirk to CPAN::Meta::YAML it's ok, but I'd prefer not
# to add new {read,write}_* methods to this API.
sub read_string {
my $self = shift;
$self->_load_string(@_);
}
sub write_string {
my $self = shift;
$self->_dump_string(@_);
}
sub read {
my $self = shift;
$self->_load_file(@_);
}
sub write {
my $self = shift;
$self->_dump_file(@_);
}
#####################################################################
# Constants
# Printed form of the unprintable characters in the lowest range
# of ASCII characters, listed by ASCII ordinal position.
my @UNPRINTABLE = qw(
0 x01 x02 x03 x04 x05 x06 a
b t n v f r x0E x0F
x10 x11 x12 x13 x14 x15 x16 x17
x18 x19 x1A e x1C x1D x1E x1F
);
# Printable characters for escapes
my %UNESCAPES = (
0 => "\x00", z => "\x00", N => "\x85",
a => "\x07", b => "\x08", t => "\x09",
n => "\x0a", v => "\x0b", f => "\x0c",
r => "\x0d", e => "\x1b", '\\' => '\\',
);
# XXX-INGY
# I(ngy) need to decide if these values should be quoted in
# CPAN::Meta::YAML or not. Probably yes.
# These 3 values have special meaning when unquoted and using the
# default YAML schema. They need quotes if they are strings.
my %QUOTE = map { $_ => 1 } qw{
null true false
};
# The commented out form is simpler, but overloaded the Perl regex
# engine due to recursion and backtracking problems on strings
# larger than 32,000ish characters. Keep it for reference purposes.
# qr/\"((?:\\.|[^\"])*)\"/
my $re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;
my $re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/;
# unquoted re gets trailing space that needs to be stripped
my $re_capture_unquoted_key = qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/;
my $re_trailing_comment = qr/(?:\s+\#.*)?/;
my $re_key_value_separator = qr/\s*:(?:\s+(?:\#.*)?|$)/;
#####################################################################
# CPAN::Meta::YAML Implementation.
#
# These are the private methods that do all the work. They may change
# at any time.
###
# Loader functions:
# Create an object from a file
sub _load_file {
my $class = ref $_[0] ? ref shift : shift;
# Check the file
my $file = shift or $class->_error( 'You did not specify a file name' );
$class->_error( "File '$file' does not exist" )
unless -e $file;
$class->_error( "'$file' is a directory, not a file" )
unless -f _;
$class->_error( "Insufficient permissions to read '$file'" )
unless -r _;
# Open unbuffered with strict UTF-8 decoding and no translation layers
open( my $fh, "<:unix:encoding(UTF-8)", $file );
unless ( $fh ) {
$class->_error("Failed to open file '$file': $!");
}
# flock if available (or warn if not possible for OS-specific reasons)
if ( _can_flock() ) {
flock( $fh, Fcntl::LOCK_SH() )
or warn "Couldn't lock '$file' for reading: $!";
}
# slurp the contents
my $contents = eval {
use warnings FATAL => 'utf8';
local $/;
<$fh>
};
if ( my $err = $@ ) {
$class->_error("Error reading from file '$file': $err");
}
# close the file (release the lock)
unless ( close $fh ) {
$class->_error("Failed to close file '$file': $!");
}
$class->_load_string( $contents );
}
# Create an object from a string
sub _load_string {
my $class = ref $_[0] ? ref shift : shift;
my $self = bless [], $class;
my $string = $_[0];
eval {
unless ( defined $string ) {
die \"Did not provide a string to load";
}
# Check if Perl has it marked as characters, but it's internally
# inconsistent. E.g. maybe latin1 got read on a :utf8 layer
if ( utf8::is_utf8($string) && ! utf8::valid($string) ) {
die \<<'...';
Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set).
Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"?
...
}
# Ensure Unicode character semantics, even for 0x80-0xff
utf8::upgrade($string);
# Check for and strip any leading UTF-8 BOM
$string =~ s/^\x{FEFF}//;
# Check for some special cases
return $self unless length $string;
# Split the file into lines
my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
split /(?:\015{1,2}\012|\015|\012)/, $string;
# Strip the initial YAML header
@lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
# A nibbling parser
my $in_document = 0;
while ( @lines ) {
# Do we have a document header?
if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
# Handle scalar documents
shift @lines;
if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
push @$self,
$self->_load_scalar( "$1", [ undef ], \@lines );
next;
}
$in_document = 1;
}
if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
# A naked document
push @$self, undef;
while ( @lines and $lines[0] !~ /^---/ ) {
shift @lines;
}
$in_document = 0;
# XXX The final '-+$' is to look for -- which ends up being an
# error later.
} elsif ( ! $in_document && @$self ) {
# only the first document can be explicit
die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
} elsif ( $lines[0] =~ /^\s*\-(?:\s|$|-+$)/ ) {
# An array at the root
my $document = [ ];
push @$self, $document;
$self->_load_array( $document, [ 0 ], \@lines );
} elsif ( $lines[0] =~ /^(\s*)\S/ ) {
# A hash at the root
my $document = { };
push @$self, $document;
$self->_load_hash( $document, [ length($1) ], \@lines );
} else {
# Shouldn't get here. @lines have whitespace-only lines
# stripped, and previous match is a line with any
# non-whitespace. So this clause should only be reachable via
# a perlbug where \s is not symmetric with \S
# uncoverable statement
die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
}
}
};
my $err = $@;
if ( ref $err eq 'SCALAR' ) {
$self->_error(${$err});
} elsif ( $err ) {
$self->_error($err);
}
return $self;
}
sub _unquote_single {
my ($self, $string) = @_;
return '' unless length $string;
$string =~ s/\'\'/\'/g;
return $string;
}
sub _unquote_double {
my ($self, $string) = @_;
return '' unless length $string;
$string =~ s/\\"/"/g;
$string =~
s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))}
{(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex;
return $string;
}
# Load a YAML scalar string to the actual Perl scalar
sub _load_scalar {
my ($self, $string, $indent, $lines) = @_;
# Trim trailing whitespace
$string =~ s/\s*\z//;
# Explitic null/undef
return undef if $string eq '~';
# Single quote
if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) {
return $self->_unquote_single($1);
}
# Double quote.
if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) {
return $self->_unquote_double($1);
}
# Special cases
if ( $string =~ /^[\'\"!&]/ ) {
die \"CPAN::Meta::YAML does not support a feature in line '$string'";
}
return {} if $string =~ /^{}(?:\s+\#.*)?\z/;
return [] if $string =~ /^\[\](?:\s+\#.*)?\z/;
# Regular unquoted string
if ( $string !~ /^[>|]/ ) {
die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'"
if $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or
$string =~ /:(?:\s|$)/;
$string =~ s/\s+#.*\z//;
return $string;
}
# Error
die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines;
# Check the indent depth
$lines->[0] =~ /^(\s*)/;
$indent->[-1] = length("$1");
if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
}
# Pull the lines
my @multiline = ();
while ( @$lines ) {
$lines->[0] =~ /^(\s*)/;
last unless length($1) >= $indent->[-1];
push @multiline, substr(shift(@$lines), length($1));
}
my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
my $t = (substr($string, 1, 1) eq '-') ? '' : "\n";
return join( $j, @multiline ) . $t;
}
# Load an array
sub _load_array {
my ($self, $array, $indent, $lines) = @_;
while ( @$lines ) {
# Check for a new document
if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
while ( @$lines and $lines->[0] !~ /^---/ ) {
shift @$lines;
}
return 1;
}
# Check the indent level
$lines->[0] =~ /^(\s*)/;
if ( length($1) < $indent->[-1] ) {
return 1;
} elsif ( length($1) > $indent->[-1] ) {
die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
}
if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
# Inline nested hash
my $indent2 = length("$1");
$lines->[0] =~ s/-/ /;
push @$array, { };
$self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
} elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
shift @$lines;
unless ( @$lines ) {
push @$array, undef;
return 1;
}
if ( $lines->[0] =~ /^(\s*)\-/ ) {
my $indent2 = length("$1");
if ( $indent->[-1] == $indent2 ) {
# Null array entry
push @$array, undef;
} else {
# Naked indenter
push @$array, [ ];
$self->_load_array(
$array->[-1], [ @$indent, $indent2 ], $lines
);
}
} elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
push @$array, { };
$self->_load_hash(
$array->[-1], [ @$indent, length("$1") ], $lines
);
} else {
die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
}
} elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
# Array entry with a value
shift @$lines;
push @$array, $self->_load_scalar(
"$2", [ @$indent, undef ], $lines
);
} elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
# This is probably a structure like the following...
# ---
# foo:
# - list
# bar: value
#
# ... so lets return and let the hash parser handle it
return 1;
} else {
die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
}
}
return 1;
}
# Load a hash
sub _load_hash {
my ($self, $hash, $indent, $lines) = @_;
while ( @$lines ) {
# Check for a new document
if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
while ( @$lines and $lines->[0] !~ /^---/ ) {
shift @$lines;
}
return 1;
}
# Check the indent level
$lines->[0] =~ /^(\s*)/;
if ( length($1) < $indent->[-1] ) {
return 1;
} elsif ( length($1) > $indent->[-1] ) {
die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
}
# Find the key
my $key;
# Quoted keys
if ( $lines->[0] =~
s/^\s*$re_capture_single_quoted$re_key_value_separator//
) {
$key = $self->_unquote_single($1);
}
elsif ( $lines->[0] =~
s/^\s*$re_capture_double_quoted$re_key_value_separator//
) {
$key = $self->_unquote_double($1);
}
elsif ( $lines->[0] =~
s/^\s*$re_capture_unquoted_key$re_key_value_separator//
) {
$key = $1;
$key =~ s/\s+$//;
}
elsif ( $lines->[0] =~ /^\s*\?/ ) {
die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'";
}
else {
die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
}
if ( exists $hash->{$key} ) {
warn "CPAN::Meta::YAML found a duplicate key '$key' in line '$lines->[0]'";
}
# Do we have a value?
if ( length $lines->[0] ) {
# Yes
$hash->{$key} = $self->_load_scalar(
shift(@$lines), [ @$indent, undef ], $lines
);
} else {
# An indent
shift @$lines;
unless ( @$lines ) {
$hash->{$key} = undef;
return 1;
}
if ( $lines->[0] =~ /^(\s*)-/ ) {
$hash->{$key} = [];
$self->_load_array(
$hash->{$key}, [ @$indent, length($1) ], $lines
);
} elsif ( $lines->[0] =~ /^(\s*)./ ) {
my $indent2 = length("$1");
if ( $indent->[-1] >= $indent2 ) {
# Null hash entry
$hash->{$key} = undef;
} else {
$hash->{$key} = {};
$self->_load_hash(
$hash->{$key}, [ @$indent, length($1) ], $lines
);
}
}
}
}
return 1;
}
###
# Dumper functions:
# Save an object to a file
sub _dump_file {
my $self = shift;
require Fcntl;
# Check the file
my $file = shift or $self->_error( 'You did not specify a file name' );
my $fh;
# flock if available (or warn if not possible for OS-specific reasons)
if ( _can_flock() ) {
# Open without truncation (truncate comes after lock)
my $flags = Fcntl::O_WRONLY()|Fcntl::O_CREAT();
sysopen( $fh, $file, $flags );
unless ( $fh ) {
$self->_error("Failed to open file '$file' for writing: $!");
}
# Use no translation and strict UTF-8
binmode( $fh, ":raw:encoding(UTF-8)");
flock( $fh, Fcntl::LOCK_EX() )
or warn "Couldn't lock '$file' for reading: $!";
# truncate and spew contents
truncate $fh, 0;
seek $fh, 0, 0;
}
else {
open $fh, ">:unix:encoding(UTF-8)", $file;
}
# serialize and spew to the handle
print {$fh} $self->_dump_string;
# close the file (release the lock)
unless ( close $fh ) {
$self->_error("Failed to close file '$file': $!");
}
return 1;
}
# Save an object to a string
sub _dump_string {
my $self = shift;
return '' unless ref $self && @$self;
# Iterate over the documents
my $indent = 0;
my @lines = ();
eval {
foreach my $cursor ( @$self ) {
push @lines, '---';
# An empty document
if ( ! defined $cursor ) {
# Do nothing
# A scalar document
} elsif ( ! ref $cursor ) {
$lines[-1] .= ' ' . $self->_dump_scalar( $cursor );
# A list at the root
} elsif ( ref $cursor eq 'ARRAY' ) {
unless ( @$cursor ) {
$lines[-1] .= ' []';
next;
}
push @lines, $self->_dump_array( $cursor, $indent, {} );
# A hash at the root
} elsif ( ref $cursor eq 'HASH' ) {
unless ( %$cursor ) {
$lines[-1] .= ' {}';
next;
}
push @lines, $self->_dump_hash( $cursor, $indent, {} );
} else {
die \("Cannot serialize " . ref($cursor));
}
}
};
if ( ref $@ eq 'SCALAR' ) {
$self->_error(${$@});
} elsif ( $@ ) {
$self->_error($@);
}
join '', map { "$_\n" } @lines;
}
sub _has_internal_string_value {
my $value = shift;
my $b_obj = B::svref_2object(\$value); # for round trip problem
return $b_obj->FLAGS & B::SVf_POK();
}
sub _dump_scalar {
my $string = $_[1];
my $is_key = $_[2];
# Check this before checking length or it winds up looking like a string!
my $has_string_flag = _has_internal_string_value($string);
return '~' unless defined $string;
return "''" unless length $string;
if (Scalar::Util::looks_like_number($string)) {
# keys and values that have been used as strings get quoted
if ( $is_key || $has_string_flag ) {
return qq['$string'];
}
else {
return $string;
}
}
if ( $string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/ ) {
$string =~ s/\\/\\\\/g;
$string =~ s/"/\\"/g;
$string =~ s/\n/\\n/g;
$string =~ s/[\x85]/\\N/g;
$string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
$string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge;
return qq|"$string"|;
}
if ( $string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or
$QUOTE{$string}
) {
return "'$string'";
}
return $string;
}
sub _dump_array {
my ($self, $array, $indent, $seen) = @_;
if ( $seen->{refaddr($array)}++ ) {
die \"CPAN::Meta::YAML does not support circular references";
}
my @lines = ();
foreach my $el ( @$array ) {
my $line = (' ' x $indent) . '-';
my $type = ref $el;
if ( ! $type ) {
$line .= ' ' . $self->_dump_scalar( $el );
push @lines, $line;
} elsif ( $type eq 'ARRAY' ) {
if ( @$el ) {
push @lines, $line;
push @lines, $self->_dump_array( $el, $indent + 1, $seen );
} else {
$line .= ' []';
push @lines, $line;
}
} elsif ( $type eq 'HASH' ) {
if ( keys %$el ) {
push @lines, $line;
push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
} else {
$line .= ' {}';
push @lines, $line;
}
} else {
die \"CPAN::Meta::YAML does not support $type references";
}
}
@lines;
}
sub _dump_hash {
my ($self, $hash, $indent, $seen) = @_;
if ( $seen->{refaddr($hash)}++ ) {
die \"CPAN::Meta::YAML does not support circular references";
}
my @lines = ();
foreach my $name ( sort keys %$hash ) {
my $el = $hash->{$name};
my $line = (' ' x $indent) . $self->_dump_scalar($name, 1) . ":";
my $type = ref $el;
if ( ! $type ) {
$line .= ' ' . $self->_dump_scalar( $el );
push @lines, $line;
} elsif ( $type eq 'ARRAY' ) {
if ( @$el ) {
push @lines, $line;
push @lines, $self->_dump_array( $el, $indent + 1, $seen );
} else {
$line .= ' []';
push @lines, $line;
}
} elsif ( $type eq 'HASH' ) {
if ( keys %$el ) {
push @lines, $line;
push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
} else {
$line .= ' {}';
push @lines, $line;
}
} else {
die \"CPAN::Meta::YAML does not support $type references";
}
}
@lines;
}
#####################################################################
# DEPRECATED API methods:
# Error storage (DEPRECATED as of 1.57)
our $errstr = '';
# Set error
sub _error {
require Carp;
$errstr = $_[1];
$errstr =~ s/ at \S+ line \d+.*//;
Carp::croak( $errstr );
}
# Retrieve error
my $errstr_warned;
sub errstr {
require Carp;
Carp::carp( "CPAN::Meta::YAML->errstr and \$CPAN::Meta::YAML::errstr is deprecated" )
unless $errstr_warned++;
$errstr;
}
#####################################################################
# Helper functions. Possibly not needed.
# Use to detect nv or iv
use B;
# XXX-INGY Is flock CPAN::Meta::YAML's responsibility?
# Some platforms can't flock :-(
# XXX-XDG I think it is. When reading and writing files, we ought
# to be locking whenever possible. People (foolishly) use YAML
# files for things like session storage, which has race issues.
my $HAS_FLOCK;
sub _can_flock {
if ( defined $HAS_FLOCK ) {
return $HAS_FLOCK;
}
else {
require Config;
my $c = \%Config::Config;
$HAS_FLOCK = grep { $c->{$_} } qw/d_flock d_fcntl_can_lock d_lockf/;
require Fcntl if $HAS_FLOCK;
return $HAS_FLOCK;
}
}
# XXX-INGY Is this core in 5.8.1? Can we remove this?
# XXX-XDG Scalar::Util 1.18 didn't land until 5.8.8, so we need this
#####################################################################
# Use Scalar::Util if possible, otherwise emulate it
use Scalar::Util ();
BEGIN {
local $@;
if ( eval { Scalar::Util->VERSION(1.18); } ) {
*refaddr = *Scalar::Util::refaddr;
}
else {
eval <<'END_PERL';
# Scalar::Util failed to load or too old
sub refaddr {
my $pkg = ref($_[0]) or return undef;
if ( !! UNIVERSAL::can($_[0], 'can') ) {
bless $_[0], 'Scalar::Util::Fake';
} else {
$pkg = undef;
}
"$_[0]" =~ /0x(\w+)/;
my $i = do { no warnings 'portable'; hex $1 };
bless $_[0], $pkg if defined $pkg;
$i;
}
END_PERL
}
}
delete $CPAN::Meta::YAML::{refaddr};
1;
# XXX-INGY Doc notes I'm putting up here. Changing the doc when it's wrong
# but leaving grey area stuff up here.
#
# I would like to change Read/Write to Load/Dump below without
# changing the actual API names.
#
# It might be better to put Load/Dump API in the SYNOPSIS instead of the
# dubious OO API.
#
# null and bool explanations may be outdated.
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::YAML - Read and write a subset of YAML for CPAN Meta files
=head1 VERSION
version 0.018
=head1 SYNOPSIS
use CPAN::Meta::YAML;
# reading a META file
open $fh, "<:utf8", "META.yml";
$yaml_text = do { local $/; <$fh> };
$yaml = CPAN::Meta::YAML->read_string($yaml_text)
or die CPAN::Meta::YAML->errstr;
# finding the metadata
$meta = $yaml->[0];
# writing a META file
$yaml_text = $yaml->write_string
or die CPAN::Meta::YAML->errstr;
open $fh, ">:utf8", "META.yml";
print $fh $yaml_text;
=head1 DESCRIPTION
This module implements a subset of the YAML specification for use in reading
and writing CPAN metadata files like F<META.yml> and F<MYMETA.yml>. It should
not be used for any other general YAML parsing or generation task.
NOTE: F<META.yml> (and F<MYMETA.yml>) files should be UTF-8 encoded. Users are
responsible for proper encoding and decoding. In particular, the C<read> and
C<write> methods do B<not> support UTF-8 and should not be used.
=head1 SUPPORT
This module is currently derived from L<YAML::Tiny> by Adam Kennedy. If
there are bugs in how it parses a particular META.yml file, please file
a bug report in the YAML::Tiny bugtracker:
L<https://github.com/Perl-Toolchain-Gang/YAML-Tiny/issues>
=head1 SEE ALSO
L<YAML::Tiny>, L<YAML>, L<YAML::XS>
=head1 AUTHORS
=over 4
=item *
Adam Kennedy <adamk@cpan.org>
=item *
David Golden <dagolden@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by Adam Kennedy.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__
# ABSTRACT: Read and write a subset of YAML for CPAN Meta files

638
OGP64/usr/share/perl5/5.40/CPAN/Mirrors.pm Normal file
View file

@ -0,0 +1,638 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
=head1 NAME
CPAN::Mirrors - Get CPAN mirror information and select a fast one
=head1 SYNOPSIS
use CPAN::Mirrors;
my $mirrors = CPAN::Mirrors->new( $mirrored_by_file );
my $seen = {};
my $best_continent = $mirrors->find_best_continents( { seen => $seen } );
my @mirrors = $mirrors->get_mirrors_by_continents( $best_continent );
my $callback = sub {
my( $m ) = @_;
printf "%s = %s\n", $m->hostname, $m->rtt
};
$mirrors->get_mirrors_timings( \@mirrors, $seen, $callback, %args );
@mirrors = sort { $a->rtt <=> $b->rtt } @mirrors;
print "Best mirrors are ", map( { $_->rtt } @mirrors[0..3] ), "\n";
=head1 DESCRIPTION
=over
=cut
package CPAN::Mirrors;
use strict;
use vars qw($VERSION $urllist $silent);
$VERSION = "2.27";
use Carp;
use FileHandle;
use Fcntl ":flock";
use Net::Ping ();
use CPAN::Version;
=item new( LOCAL_FILE_NAME )
Create a new CPAN::Mirrors object from LOCAL_FILE_NAME. This file
should look like that in http://www.cpan.org/MIRRORED.BY .
=cut
sub new {
my ($class, $file) = @_;
croak "CPAN::Mirrors->new requires a filename" unless defined $file;
croak "The file [$file] was not found" unless -e $file;
my $self = bless {
mirrors => [],
geography => {},
}, $class;
$self->parse_mirrored_by( $file );
return $self;
}
sub parse_mirrored_by {
my ($self, $file) = @_;
my $handle = FileHandle->new;
$handle->open($file)
or croak "Couldn't open $file: $!";
flock $handle, LOCK_SH;
$self->_parse($file,$handle);
flock $handle, LOCK_UN;
$handle->close;
}
=item continents()
Return a list of continents based on those defined in F<MIRRORED.BY>.
=cut
sub continents {
my ($self) = @_;
return sort keys %{$self->{geography} || {}};
}
=item countries( [CONTINENTS] )
Return a list of countries based on those defined in F<MIRRORED.BY>.
It only returns countries for the continents you specify (as defined
in C<continents>). If you don't specify any continents, it returns all
of the countries listed in F<MIRRORED.BY>.
=cut
sub countries {
my ($self, @continents) = @_;
@continents = $self->continents unless @continents;
my @countries;
for my $c (@continents) {
push @countries, sort keys %{ $self->{geography}{$c} || {} };
}
return @countries;
}
=item mirrors( [COUNTRIES] )
Return a list of mirrors based on those defined in F<MIRRORED.BY>.
It only returns mirrors for the countries you specify (as defined
in C<countries>). If you don't specify any countries, it returns all
of the mirrors listed in F<MIRRORED.BY>.
=cut
sub mirrors {
my ($self, @countries) = @_;
return @{$self->{mirrors}} unless @countries;
my %wanted = map { $_ => 1 } @countries;
my @found;
for my $m (@{$self->{mirrors}}) {
push @found, $m if exists $wanted{$m->country};
}
return @found;
}
=item get_mirrors_by_countries( [COUNTRIES] )
A more sensible synonym for mirrors.
=cut
sub get_mirrors_by_countries { &mirrors }
=item get_mirrors_by_continents( [CONTINENTS] )
Return a list of mirrors for all of continents you specify. If you don't
specify any continents, it returns all of the mirrors.
You can specify a single continent or an array reference of continents.
=cut
sub get_mirrors_by_continents {
my ($self, $continents ) = @_;
$continents = [ $continents ] unless ref $continents;
eval {
$self->mirrors( $self->get_countries_by_continents( @$continents ) );
};
}
=item get_countries_by_continents( [CONTINENTS] )
A more sensible synonym for countries.
=cut
sub get_countries_by_continents { &countries }
=item default_mirror
Returns the default mirror, http://www.cpan.org/ . This mirror uses
dynamic DNS to give a close mirror.
=cut
sub default_mirror {
CPAN::Mirrored::By->new({ http => 'http://www.cpan.org/'});
}
=item best_mirrors
C<best_mirrors> checks for the best mirrors based on the list of
continents you pass, or, without that, all continents, as defined
by C<CPAN::Mirrored::By>. It pings each mirror, up to the value of
C<how_many>. In list context, it returns up to C<how_many> mirrors.
In scalar context, it returns the single best mirror.
Arguments
how_many - the number of mirrors to return. Default: 1
callback - a callback for find_best_continents
verbose - true or false on all the whining and moaning. Default: false
continents - an array ref of the continents to check
external_ping - if true, use external ping via Net::Ping::External. Default: false
If you don't specify the continents, C<best_mirrors> calls
C<find_best_continents> to get the list of continents to check.
If you don't have L<Net::Ping> v2.13 or later, needed for timings,
this returns the default mirror.
C<external_ping> should be set and then C<Net::Ping::External> needs
to be installed, if the local network has a transparent proxy.
=cut
sub best_mirrors {
my ($self, %args) = @_;
my $how_many = $args{how_many} || 1;
my $callback = $args{callback};
my $verbose = defined $args{verbose} ? $args{verbose} : 0;
my $continents = $args{continents} || [];
$continents = [$continents] unless ref $continents;
$args{external_ping} = 0 unless defined $args{external_ping};
my $external_ping = $args{external_ping};
# Old Net::Ping did not do timings at all
my $min_version = '2.13';
unless( CPAN::Version->vgt(Net::Ping->VERSION, $min_version) ) {
carp sprintf "Net::Ping version is %s (< %s). Returning %s",
Net::Ping->VERSION, $min_version, $self->default_mirror;
return $self->default_mirror;
}
my $seen = {};
if ( ! @$continents ) {
print "Searching for the best continent ...\n" if $verbose;
my @best_continents = $self->find_best_continents(
seen => $seen,
verbose => $verbose,
callback => $callback,
external_ping => $external_ping,
);
# Only add enough continents to find enough mirrors
my $count = 0;
for my $continent ( @best_continents ) {
push @$continents, $continent;
$count += $self->mirrors( $self->countries($continent) );
last if $count >= $how_many;
}
}
return $self->default_mirror unless @$continents;
print "Scanning " . join(", ", @$continents) . " ...\n" if $verbose;
my $trial_mirrors = $self->get_n_random_mirrors_by_continents( 3 * $how_many, $continents->[0] );
my $timings = $self->get_mirrors_timings(
$trial_mirrors,
$seen,
$callback,
%args,
);
return $self->default_mirror unless @$timings;
$how_many = @$timings if $how_many > @$timings;
return wantarray ? @{$timings}[0 .. $how_many-1] : $timings->[0];
}
=item get_n_random_mirrors_by_continents( N, [CONTINENTS] )
Returns up to N random mirrors for the specified continents. Specify the
continents as an array reference.
=cut
sub get_n_random_mirrors_by_continents {
my( $self, $n, $continents ) = @_;
$n ||= 3;
$continents = [ $continents ] unless ref $continents;
if ( $n <= 0 ) {
return wantarray ? () : [];
}
my @long_list = $self->get_mirrors_by_continents( $continents );
if ( $n eq '*' or $n > @long_list ) {
return wantarray ? @long_list : \@long_list;
}
@long_list = map {$_->[0]}
sort {$a->[1] <=> $b->[1]}
map {[$_, rand]} @long_list;
splice @long_list, $n; # truncate
\@long_list;
}
=item get_mirrors_timings( MIRROR_LIST, SEEN, CALLBACK, %ARGS );
Pings the listed mirrors and returns a list of mirrors sorted in
ascending ping times.
C<MIRROR_LIST> is an anonymous array of C<CPAN::Mirrored::By> objects to
ping.
The optional argument C<SEEN> is a hash reference used to track the
mirrors you've already pinged.
The optional argument C<CALLBACK> is a subroutine reference to call
after each ping. It gets the C<CPAN::Mirrored::By> object after each
ping.
=cut
sub get_mirrors_timings {
my( $self, $mirror_list, $seen, $callback, %args ) = @_;
$seen = {} unless defined $seen;
croak "The mirror list argument must be an array reference"
unless ref $mirror_list eq ref [];
croak "The seen argument must be a hash reference"
unless ref $seen eq ref {};
croak "callback must be a subroutine"
if( defined $callback and ref $callback ne ref sub {} );
my $timings = [];
for my $m ( @$mirror_list ) {
$seen->{$m->hostname} = $m;
next unless eval{ $m->http };
if( $self->_try_a_ping( $seen, $m, ) ) {
my $ping = $m->ping(%args);
next unless defined $ping;
# printf "m %s ping %s\n", $m, $ping;
push @$timings, $m;
$callback->( $m ) if $callback;
}
else {
push @$timings, $seen->{$m->hostname}
if defined $seen->{$m->hostname}->rtt;
}
}
my @best = sort {
if( defined $a->rtt and defined $b->rtt ) {
$a->rtt <=> $b->rtt
}
elsif( defined $a->rtt and ! defined $b->rtt ) {
return -1;
}
elsif( ! defined $a->rtt and defined $b->rtt ) {
return 1;
}
elsif( ! defined $a->rtt and ! defined $b->rtt ) {
return 0;
}
} @$timings;
return wantarray ? @best : \@best;
}
=item find_best_continents( HASH_REF );
C<find_best_continents> goes through each continent and pings C<N>
random mirrors on that continent. It then orders the continents by
ascending median ping time. In list context, it returns the ordered list
of continent. In scalar context, it returns the same list as an
anonymous array.
Arguments:
n - the number of hosts to ping for each continent. Default: 3
seen - a hashref of cached hostname ping times
verbose - true or false for noisy or quiet. Default: false
callback - a subroutine to run after each ping.
ping_cache_limit - how long, in seconds, to reuse previous ping times.
Default: 1 day
The C<seen> hash has hostnames as keys and anonymous arrays as values.
The anonymous array is a triplet of a C<CPAN::Mirrored::By> object, a
ping time, and the epoch time for the measurement.
The callback subroutine gets the C<CPAN::Mirrored::By> object, the ping
time, and measurement time (the same things in the C<seen> hashref) as
arguments. C<find_best_continents> doesn't care what the callback does
and ignores the return value.
With a low value for C<N>, a single mirror might skew the results enough
to choose a worse continent. If you have that problem, try a larger
value.
=cut
sub find_best_continents {
my ($self, %args) = @_;
$args{n} ||= 3;
$args{verbose} = 0 unless defined $args{verbose};
$args{seen} = {} unless defined $args{seen};
croak "The seen argument must be a hash reference"
unless ref $args{seen} eq ref {};
$args{ping_cache_limit} = 24 * 60 * 60
unless defined $args{ping_cache_limit};
croak "callback must be a subroutine"
if( defined $args{callback} and ref $args{callback} ne ref sub {} );
my %medians;
CONT: for my $c ( $self->continents ) {
my @mirrors = $self->mirrors( $self->countries($c) );
printf "Testing %s (%d mirrors)\n", $c, scalar @mirrors
if $args{verbose};
next CONT unless @mirrors;
my $n = (@mirrors < $args{n}) ? @mirrors : $args{n};
my @tests;
my $tries = 0;
RANDOM: while ( @mirrors && @tests < $n && $tries++ < 15 ) {
my $m = splice( @mirrors, int(rand(@mirrors)), 1 );
if( $self->_try_a_ping(
$args{seen}, $m, $args{ping_cache_limit}
)) {
$self->get_mirrors_timings(
[ $m ],
$args{seen},
$args{callback},
%args,
);
next RANDOM unless defined $args{seen}{$m->hostname}->rtt;
}
printf "(%s -> %0.2f ms)",
$m->hostname,
join ' ', 1000 * $args{seen}{$m->hostname}->rtt
if $args{verbose};
push @tests, $args{seen}{$m->hostname}->rtt;
}
my $median = $self->_get_median_ping_time( \@tests, $args{verbose} );
$medians{$c} = $median if defined $median;
}
my @best_cont = sort { $medians{$a} <=> $medians{$b} } keys %medians;
if ( $args{verbose} ) {
print "Median result by continent:\n";
if ( @best_cont ) {
for my $c ( @best_cont ) {
printf( " %7.2f ms %s\n", $medians{$c}*1000, $c );
}
} else {
print " **** No results found ****\n"
}
}
return wantarray ? @best_cont : $best_cont[0];
}
# retry if
sub _try_a_ping {
my ($self, $seen, $mirror, $ping_cache_limit ) = @_;
( ! exists $seen->{$mirror->hostname}
or
! defined $seen->{$mirror->hostname}->rtt
or
! defined $ping_cache_limit
or
time - $seen->{$mirror->hostname}->ping_time
> $ping_cache_limit
)
}
sub _get_median_ping_time {
my ($self, $tests, $verbose ) = @_;
my @sorted = sort { $a <=> $b } @$tests;
my $median = do {
if ( @sorted == 0 ) { undef }
elsif ( @sorted == 1 ) { $sorted[0] }
elsif ( @sorted % 2 ) { $sorted[ int(@sorted / 2) ] }
else {
my $mid_high = int(@sorted/2);
($sorted[$mid_high-1] + $sorted[$mid_high])/2;
}
};
if ($verbose){
if ($median) {
printf " => median time: %.2f ms\n", $median * 1000
} else {
printf " => **** no median time ****\n";
}
}
return $median;
}
# Adapted from Parse::CPAN::MirroredBy by Adam Kennedy
sub _parse {
my ($self, $file, $handle) = @_;
my $output = $self->{mirrors};
my $geo = $self->{geography};
local $/ = "\012";
my $line = 0;
my $mirror = undef;
while ( 1 ) {
# Next line
my $string = <$handle>;
last if ! defined $string;
$line = $line + 1;
# Remove the useless lines
chomp( $string );
next if $string =~ /^\s*$/;
next if $string =~ /^\s*#/;
# Hostname or property?
if ( $string =~ /^\s/ ) {
# Property
unless ( $string =~ /^\s+(\w+)\s+=\s+\"(.*)\"$/ ) {
croak("Invalid property on line $line");
}
my ($prop, $value) = ($1,$2);
$mirror ||= {};
if ( $prop eq 'dst_location' ) {
my (@location,$continent,$country);
@location = (split /\s*,\s*/, $value)
and ($continent, $country) = @location[-1,-2];
$continent =~ s/\s\(.*//;
$continent =~ s/\W+$//; # if Jarkko doesn't know latitude/longitude
$geo->{$continent}{$country} = 1 if $continent && $country;
$mirror->{continent} = $continent || "unknown";
$mirror->{country} = $country || "unknown";
}
elsif ( $prop eq 'dst_http' ) {
$mirror->{http} = $value;
}
elsif ( $prop eq 'dst_ftp' ) {
$mirror->{ftp} = $value;
}
elsif ( $prop eq 'dst_rsync' ) {
$mirror->{rsync} = $value;
}
else {
$prop =~ s/^dst_//;
$mirror->{$prop} = $value;
}
} else {
# Hostname
unless ( $string =~ /^([\w\.-]+)\:\s*$/ ) {
croak("Invalid host name on line $line");
}
my $current = $mirror;
$mirror = { hostname => "$1" };
if ( $current ) {
push @$output, CPAN::Mirrored::By->new($current);
}
}
}
if ( $mirror ) {
push @$output, CPAN::Mirrored::By->new($mirror);
}
return;
}
#--------------------------------------------------------------------------#
package CPAN::Mirrored::By;
use strict;
use Net::Ping ();
sub new {
my($self,$arg) = @_;
$arg ||= {};
bless $arg, $self;
}
sub hostname { shift->{hostname} }
sub continent { shift->{continent} }
sub country { shift->{country} }
sub http { shift->{http} || '' }
sub ftp { shift->{ftp} || '' }
sub rsync { shift->{rsync} || '' }
sub rtt { shift->{rtt} }
sub ping_time { shift->{ping_time} }
sub url {
my $self = shift;
return $self->{http} || $self->{ftp};
}
sub ping {
my($self, %args) = @_;
my $external_ping = $args{external_ping};
if ($external_ping) {
eval { require Net::Ping::External }
or die "Net::Ping::External required to use external ping command";
}
my $ping = Net::Ping->new(
$external_ping ? 'external' : $^O eq 'VMS' ? 'icmp' : 'tcp',
1
);
my ($proto) = $self->url =~ m{^([^:]+)};
my $port = $proto eq 'http' ? 80 : 21;
return unless $port;
if ( $ping->can('port_number') ) {
$ping->port_number($port);
}
else {
$ping->{'port_num'} = $port;
}
$ping->hires(1) if $ping->can('hires');
my ($alive,$rtt) = eval { $ping->ping($self->hostname); };
my $verbose = $args{verbose};
if ($verbose && !$alive) {
printf "(host %s not alive)", $self->hostname;
}
$self->{rtt} = $alive ? $rtt : undef;
$self->{ping_time} = time;
$self->rtt;
}
1;
=back
=head1 AUTHOR
Andreas Koenig C<< <andk@cpan.org> >>, David Golden C<< <dagolden@cpan.org> >>,
brian d foy C<< <bdfoy@cpan.org> >>
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<http://www.perl.com/perl/misc/Artistic.html>
=cut

702
OGP64/usr/share/perl5/5.40/CPAN/Module.pm Normal file
View file

@ -0,0 +1,702 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Module;
use strict;
@CPAN::Module::ISA = qw(CPAN::InfoObj);
use vars qw(
$VERSION
);
$VERSION = "5.5003";
BEGIN {
# alarm() is not implemented in perl 5.6.x and earlier under Windows
*ALARM_IMPLEMENTED = sub () { $] >= 5.007 || $^O !~ /MSWin/ };
}
# Accessors
#-> sub CPAN::Module::userid
sub userid {
my $self = shift;
my $ro = $self->ro;
return unless $ro;
return $ro->{userid} || $ro->{CPAN_USERID};
}
#-> sub CPAN::Module::description
sub description {
my $self = shift;
my $ro = $self->ro or return "";
$ro->{description}
}
#-> sub CPAN::Module::distribution
sub distribution {
my($self) = @_;
CPAN::Shell->expand("Distribution",$self->cpan_file);
}
#-> sub CPAN::Module::_is_representative_module
sub _is_representative_module {
my($self) = @_;
return $self->{_is_representative_module} if defined $self->{_is_representative_module};
my $pm = $self->cpan_file or return $self->{_is_representative_module} = 0;
$pm =~ s|.+/||;
$pm =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i; # see base_id
$pm =~ s|-\d+\.\d+.+$||;
$pm =~ s|-[\d\.]+$||;
$pm =~ s/-/::/g;
$self->{_is_representative_module} = $pm eq $self->{ID} ? 1 : 0;
# warn "DEBUG: $pm eq $self->{ID} => $self->{_is_representative_module}";
$self->{_is_representative_module};
}
#-> sub CPAN::Module::undelay
sub undelay {
my $self = shift;
delete $self->{later};
if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
$dist->undelay;
}
}
# mark as dirty/clean
#-> sub CPAN::Module::color_cmd_tmps ;
sub color_cmd_tmps {
my($self) = shift;
my($depth) = shift || 0;
my($color) = shift || 0;
my($ancestors) = shift || [];
# a module needs to recurse to its cpan_file
return if exists $self->{incommandcolor}
&& $color==1
&& $self->{incommandcolor}==$color;
return if $color==0 && !$self->{incommandcolor};
if ($color>=1) {
if ( $self->uptodate ) {
$self->{incommandcolor} = $color;
return;
} elsif (my $have_version = $self->available_version) {
# maybe what we have is good enough
if (@$ancestors) {
my $who_asked_for_me = $ancestors->[-1];
my $obj = CPAN::Shell->expandany($who_asked_for_me);
if (0) {
} elsif ($obj->isa("CPAN::Bundle")) {
# bundles cannot specify a minimum version
return;
} elsif ($obj->isa("CPAN::Distribution")) {
if (my $prereq_pm = $obj->prereq_pm) {
for my $k (keys %$prereq_pm) {
if (my $want_version = $prereq_pm->{$k}{$self->id}) {
if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
$self->{incommandcolor} = $color;
return;
}
}
}
}
}
}
}
} else {
$self->{incommandcolor} = $color; # set me before recursion,
# so we can break it
}
if ($depth>=$CPAN::MAX_RECURSION) {
my $e = CPAN::Exception::RecursiveDependency->new($ancestors);
if ($e->is_resolvable) {
return $self->{incommandcolor}=2;
} else {
die $e;
}
}
# warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
$dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
}
# unreached code?
# if ($color==0) {
# delete $self->{badtestcnt};
# }
$self->{incommandcolor} = $color;
}
#-> sub CPAN::Module::as_glimpse ;
sub as_glimpse {
my($self) = @_;
my(@m);
my $class = ref($self);
$class =~ s/^CPAN:://;
my $color_on = "";
my $color_off = "";
if (
$CPAN::Shell::COLOR_REGISTERED
&&
$CPAN::META->has_inst("Term::ANSIColor")
&&
$self->description
) {
$color_on = Term::ANSIColor::color("green");
$color_off = Term::ANSIColor::color("reset");
}
my $uptodateness = " ";
unless ($class eq "Bundle") {
my $u = $self->uptodate;
$uptodateness = $u ? "=" : "<" if defined $u;
};
my $id = do {
my $d = $self->distribution;
$d ? $d -> pretty_id : $self->cpan_userid;
};
push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
$class,
$uptodateness,
$color_on,
$self->id,
$color_off,
$id,
);
join "", @m;
}
#-> sub CPAN::Module::dslip_status
sub dslip_status {
my($self) = @_;
my($stat);
# development status
@{$stat->{D}}{qw,i c a b R M S,} = qw,idea
pre-alpha alpha beta released
mature standard,;
# support level
@{$stat->{S}}{qw,m d u n a,} = qw,mailing-list
developer comp.lang.perl.*
none abandoned,;
# language
@{$stat->{L}}{qw,p c + o h,} = qw,perl C C++ other hybrid,;
# interface
@{$stat->{I}}{qw,f r O p h n,} = qw,functions
references+ties
object-oriented pragma
hybrid none,;
# public licence
@{$stat->{P}}{qw,p g l b a 2 o d r n,} = qw,Standard-Perl
GPL LGPL
BSD Artistic Artistic_2
open-source
distribution_allowed
restricted_distribution
no_licence,;
for my $x (qw(d s l i p)) {
$stat->{$x}{' '} = 'unknown';
$stat->{$x}{'?'} = 'unknown';
}
my $ro = $self->ro;
return +{} unless $ro && $ro->{statd};
return {
D => $ro->{statd},
S => $ro->{stats},
L => $ro->{statl},
I => $ro->{stati},
P => $ro->{statp},
DV => $stat->{D}{$ro->{statd}},
SV => $stat->{S}{$ro->{stats}},
LV => $stat->{L}{$ro->{statl}},
IV => $stat->{I}{$ro->{stati}},
PV => $stat->{P}{$ro->{statp}},
};
}
#-> sub CPAN::Module::as_string ;
sub as_string {
my($self) = @_;
my(@m);
CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
my $class = ref($self);
$class =~ s/^CPAN:://;
local($^W) = 0;
push @m, $class, " id = $self->{ID}\n";
my $sprintf = " %-12s %s\n";
push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
if $self->description;
my $sprintf2 = " %-12s %s (%s)\n";
my($userid);
$userid = $self->userid;
if ( $userid ) {
my $author;
if ($author = CPAN::Shell->expand('Author',$userid)) {
my $email = "";
my $m; # old perls
if ($m = $author->email) {
$email = " <$m>";
}
push @m, sprintf(
$sprintf2,
'CPAN_USERID',
$userid,
$author->fullname . $email
);
}
}
push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
if $self->cpan_version;
if (my $cpan_file = $self->cpan_file) {
push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
my $upload_date = $dist->upload_date;
if ($upload_date) {
push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
}
}
}
my $sprintf3 = " %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
my $dslip = $self->dslip_status;
push @m, sprintf(
$sprintf3,
'DSLIP_STATUS',
@{$dslip}{qw(D S L I P DV SV LV IV PV)},
) if $dslip->{D};
my $local_file = $self->inst_file;
unless ($self->{MANPAGE}) {
my $manpage;
if ($local_file) {
$manpage = $self->manpage_headline($local_file);
} else {
# If we have already untarred it, we should look there
my $dist = $CPAN::META->instance('CPAN::Distribution',
$self->cpan_file);
# warn "dist[$dist]";
# mff=manifest file; mfh=manifest handle
my($mff,$mfh);
if (
$dist->{build_dir}
and
(-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
and
$mfh = FileHandle->new($mff)
) {
CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
my $lfre = $self->id; # local file RE
$lfre =~ s/::/./g;
$lfre .= "\\.pm\$";
my($lfl); # local file file
local $/ = "\n";
my(@mflines) = <$mfh>;
for (@mflines) {
s/^\s+//;
s/\s.*//s;
}
while (length($lfre)>5 and !$lfl) {
($lfl) = grep /$lfre/, @mflines;
CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
$lfre =~ s/.+?\.//;
}
$lfl =~ s/\s.*//; # remove comments
$lfl =~ s/\s+//g; # chomp would maybe be too system-specific
my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
# warn "lfl_abs[$lfl_abs]";
if (-f $lfl_abs) {
$manpage = $self->manpage_headline($lfl_abs);
}
}
}
$self->{MANPAGE} = $manpage if $manpage;
}
my($item);
for $item (qw/MANPAGE/) {
push @m, sprintf($sprintf, $item, $self->{$item})
if exists $self->{$item};
}
for $item (qw/CONTAINS/) {
push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
if exists $self->{$item} && @{$self->{$item}};
}
push @m, sprintf($sprintf, 'INST_FILE',
$local_file || "(not installed)");
push @m, sprintf($sprintf, 'INST_VERSION',
$self->inst_version) if $local_file;
if (%{$CPAN::META->{is_tested}||{}}) { # XXX needs to be methodified somehow
my $available_file = $self->available_file;
if ($available_file && $available_file ne $local_file) {
push @m, sprintf($sprintf, 'AVAILABLE_FILE', $available_file);
push @m, sprintf($sprintf, 'AVAILABLE_VERSION', $self->available_version);
}
}
join "", @m, "\n";
}
#-> sub CPAN::Module::manpage_headline
sub manpage_headline {
my($self,$local_file) = @_;
my(@local_file) = $local_file;
$local_file =~ s/\.pm(?!\n)\Z/.pod/;
push @local_file, $local_file;
my(@result,$locf);
for $locf (@local_file) {
next unless -f $locf;
my $fh = FileHandle->new($locf)
or $Carp::Frontend->mydie("Couldn't open $locf: $!");
my $inpod = 0;
local $/ = "\n";
while (<$fh>) {
$inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
next unless $inpod;
next if /^=/;
next if /^\s+$/;
chomp;
push @result, $_;
}
close $fh;
last if @result;
}
for (@result) {
s/^\s+//;
s/\s+$//;
}
join " ", @result;
}
#-> sub CPAN::Module::cpan_file ;
# Note: also inherited by CPAN::Bundle
sub cpan_file {
my $self = shift;
# CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
unless ($self->ro) {
CPAN::Index->reload;
}
my $ro = $self->ro;
if ($ro && defined $ro->{CPAN_FILE}) {
return $ro->{CPAN_FILE};
} else {
my $userid = $self->userid;
if ( $userid ) {
if ($CPAN::META->exists("CPAN::Author",$userid)) {
my $author = $CPAN::META->instance("CPAN::Author",
$userid);
my $fullname = $author->fullname;
my $email = $author->email;
unless (defined $fullname && defined $email) {
return sprintf("Contact Author %s",
$userid,
);
}
return "Contact Author $fullname <$email>";
} else {
return "Contact Author $userid (Email address not available)";
}
} else {
return "N/A";
}
}
}
#-> sub CPAN::Module::cpan_version ;
sub cpan_version {
my $self = shift;
my $ro = $self->ro;
unless ($ro) {
# Can happen with modules that are not on CPAN
$ro = {};
}
$ro->{CPAN_VERSION} = 'undef'
unless defined $ro->{CPAN_VERSION};
$ro->{CPAN_VERSION};
}
#-> sub CPAN::Module::force ;
sub force {
my($self) = @_;
$self->{force_update} = 1;
}
#-> sub CPAN::Module::fforce ;
sub fforce {
my($self) = @_;
$self->{force_update} = 2;
}
#-> sub CPAN::Module::notest ;
sub notest {
my($self) = @_;
# $CPAN::Frontend->mywarn("XDEBUG: set notest for Module");
$self->{notest}++;
}
#-> sub CPAN::Module::rematein ;
sub rematein {
my($self,$meth) = @_;
$CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
$meth,
$self->id));
my $cpan_file = $self->cpan_file;
if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/) {
$CPAN::Frontend->mywarn(sprintf qq{
The module %s isn\'t available on CPAN.
Either the module has not yet been uploaded to CPAN, or it is
temporary unavailable. Please contact the author to find out
more about the status. Try 'i %s'.
},
$self->id,
$self->id,
);
return;
}
my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
$pack->called_for($self->id);
if (exists $self->{force_update}) {
if ($self->{force_update} == 2) {
$pack->fforce($meth);
} else {
$pack->force($meth);
}
}
$pack->notest($meth) if exists $self->{notest} && $self->{notest};
$pack->{reqtype} ||= "";
CPAN->debug("dist-reqtype[$pack->{reqtype}]".
"self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
if ($pack->{reqtype}) {
if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
$pack->{reqtype} = $self->{reqtype};
if (
exists $pack->{install}
&&
(
UNIVERSAL::can($pack->{install},"failed") ?
$pack->{install}->failed :
$pack->{install} =~ /^NO/
)
) {
delete $pack->{install};
$CPAN::Frontend->mywarn
("Promoting $pack->{ID} from 'build_requires' to 'requires'");
}
}
} else {
$pack->{reqtype} = $self->{reqtype};
}
my $success = eval {
$pack->$meth();
};
my $err = $@;
$pack->unforce if $pack->can("unforce") && exists $self->{force_update};
$pack->unnotest if $pack->can("unnotest") && exists $self->{notest};
delete $self->{force_update};
delete $self->{notest};
if ($err) {
die $err;
}
return $success;
}
#-> sub CPAN::Module::perldoc ;
sub perldoc { shift->rematein('perldoc') }
#-> sub CPAN::Module::readme ;
sub readme { shift->rematein('readme') }
#-> sub CPAN::Module::look ;
sub look { shift->rematein('look') }
#-> sub CPAN::Module::cvs_import ;
sub cvs_import { shift->rematein('cvs_import') }
#-> sub CPAN::Module::get ;
sub get { shift->rematein('get',@_) }
#-> sub CPAN::Module::make ;
sub make { shift->rematein('make') }
#-> sub CPAN::Module::test ;
sub test {
my $self = shift;
# $self->{badtestcnt} ||= 0;
$self->rematein('test',@_);
}
#-> sub CPAN::Module::deprecated_in_core ;
sub deprecated_in_core {
my ($self) = @_;
return unless $CPAN::META->has_inst('Module::CoreList') && Module::CoreList->can('is_deprecated');
return Module::CoreList::is_deprecated($self->{ID});
}
#-> sub CPAN::Module::inst_deprecated;
# Indicates whether the *installed* version of the module is a deprecated *and*
# installed as part of the Perl core library path
sub inst_deprecated {
my ($self) = @_;
my $inst_file = $self->inst_file or return;
return $self->deprecated_in_core && $self->_in_priv_or_arch($inst_file);
}
#-> sub CPAN::Module::uptodate ;
sub uptodate {
my ($self) = @_;
local ($_);
my $inst = $self->inst_version or return 0;
my $cpan = $self->cpan_version;
return 0 if CPAN::Version->vgt($cpan,$inst) || $self->inst_deprecated;
CPAN->debug
(join
("",
"returning uptodate. ",
"cpan[$cpan]inst[$inst]",
)) if $CPAN::DEBUG;
return 1;
}
# returns true if installed in privlib or archlib
sub _in_priv_or_arch {
my($self,$inst_file) = @_;
foreach my $pair (
[qw(sitearchexp archlibexp)],
[qw(sitelibexp privlibexp)]
) {
my ($site, $priv) = @Config::Config{@$pair};
if ($^O eq 'VMS') {
for my $d ($site, $priv) { $d = VMS::Filespec::unixify($d) };
}
s!/*$!!g foreach $site, $priv;
next if $site eq $priv;
if ($priv eq substr($inst_file,0,length($priv))) {
return 1;
}
}
return 0;
}
#-> sub CPAN::Module::install ;
sub install {
my($self) = @_;
my($doit) = 0;
if ($self->uptodate
&&
not exists $self->{force_update}
) {
$CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
$self->id,
$self->inst_version,
));
} else {
$doit = 1;
}
my $ro = $self->ro;
if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
$CPAN::Frontend->mywarn(qq{
\n\n\n ***WARNING***
The module $self->{ID} has no active maintainer (CPAN support level flag 'abandoned').\n\n\n
});
$CPAN::Frontend->mysleep(5);
}
return $doit ? $self->rematein('install') : 1;
}
#-> sub CPAN::Module::clean ;
sub clean { shift->rematein('clean') }
#-> sub CPAN::Module::inst_file ;
sub inst_file {
my($self) = @_;
$self->_file_in_path([@INC]);
}
#-> sub CPAN::Module::available_file ;
sub available_file {
my($self) = @_;
my $sep = $Config::Config{path_sep};
my $perllib = $ENV{PERL5LIB};
$perllib = $ENV{PERLLIB} unless defined $perllib;
my @perllib = split(/$sep/,$perllib) if defined $perllib;
my @cpan_perl5inc;
if ($CPAN::Perl5lib_tempfile) {
my $yaml = CPAN->_yaml_loadfile($CPAN::Perl5lib_tempfile);
@cpan_perl5inc = @{$yaml->[0]{inc} || []};
}
$self->_file_in_path([@cpan_perl5inc,@perllib,@INC]);
}
#-> sub CPAN::Module::file_in_path ;
sub _file_in_path {
my($self,$path) = @_;
my($dir,@packpath);
@packpath = split /::/, $self->{ID};
$packpath[-1] .= ".pm";
if (@packpath == 1 && $packpath[0] eq "readline.pm") {
unshift @packpath, "Term", "ReadLine"; # historical reasons
}
foreach $dir (@$path) {
my $pmfile = File::Spec->catfile($dir,@packpath);
if (-f $pmfile) {
return $pmfile;
}
}
return;
}
#-> sub CPAN::Module::xs_file ;
sub xs_file {
my($self) = @_;
my($dir,@packpath);
@packpath = split /::/, $self->{ID};
push @packpath, $packpath[-1];
$packpath[-1] .= "." . $Config::Config{'dlext'};
foreach $dir (@INC) {
my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
if (-f $xsfile) {
return $xsfile;
}
}
return;
}
#-> sub CPAN::Module::inst_version ;
sub inst_version {
my($self) = @_;
my $parsefile = $self->inst_file or return;
my $have = $self->parse_version($parsefile);
$have;
}
#-> sub CPAN::Module::inst_version ;
sub available_version {
my($self) = @_;
my $parsefile = $self->available_file or return;
my $have = $self->parse_version($parsefile);
$have;
}
#-> sub CPAN::Module::parse_version ;
sub parse_version {
my($self,$parsefile) = @_;
if (ALARM_IMPLEMENTED) {
my $timeout = (exists($CPAN::Config{'version_timeout'}))
? $CPAN::Config{'version_timeout'}
: 15;
alarm($timeout);
}
my $have = eval {
local $SIG{ALRM} = sub { die "alarm\n" };
MM->parse_version($parsefile);
};
if ($@) {
$CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n");
}
alarm(0) if ALARM_IMPLEMENTED;
my $leastsanity = eval { defined $have && length $have; };
$have = "undef" unless $leastsanity;
$have =~ s/^ //; # since the %vd hack these two lines here are needed
$have =~ s/ $//; # trailing whitespace happens all the time
$have = CPAN::Version->readable($have);
$have =~ s/\s*//g; # stringify to float around floating point issues
$have; # no stringify needed, \s* above matches always
}
#-> sub CPAN::Module::reports
sub reports {
my($self) = @_;
$self->distribution->reports;
}
1;

52
OGP64/usr/share/perl5/5.40/CPAN/Nox.pm Normal file
View file

@ -0,0 +1,52 @@
package CPAN::Nox;
use strict;
use vars qw($VERSION @EXPORT);
BEGIN{
$CPAN::Suppress_readline=1 unless defined $CPAN::term;
}
use Exporter ();
@CPAN::ISA = ('Exporter');
use CPAN;
$VERSION = "5.5001";
$CPAN::META->has_inst('Digest::MD5','no');
$CPAN::META->has_inst('LWP','no');
$CPAN::META->has_inst('Compress::Zlib','no');
@EXPORT = @CPAN::EXPORT;
*AUTOLOAD = \&CPAN::AUTOLOAD;
1;
__END__
=head1 NAME
CPAN::Nox - Wrapper around CPAN.pm without using any XS module
=head1 SYNOPSIS
Interactive mode:
perl -MCPAN::Nox -e shell;
=head1 DESCRIPTION
This package has the same functionality as CPAN.pm, but tries to
prevent the usage of compiled extensions during its own
execution. Its primary purpose is a rescue in case you upgraded perl
and broke binary compatibility somehow.
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 SEE ALSO
L<CPAN>
=cut

145
OGP64/usr/share/perl5/5.40/CPAN/Plugin.pm Normal file
View file

@ -0,0 +1,145 @@
package CPAN::Plugin;
use strict;
use warnings;
our $VERSION = '0.97';
require CPAN;
######################################################################
sub new { # ;
my ($class, %params) = @_;
my $self = +{
(ref $class ? (%$class) : ()),
%params,
};
$self = bless $self, ref $class ? ref $class : $class;
unless (ref $class) {
local $_;
no warnings 'once';
$CPAN::META->use_inst ($_) for $self->plugin_requires;
}
$self;
}
######################################################################
sub plugin_requires { # ;
}
######################################################################
sub distribution_object { # ;
my ($self) = @_;
$self->{distribution_object};
}
######################################################################
sub distribution { # ;
my ($self) = @_;
my $distribution = $self->distribution_object->id;
CPAN::Shell->expand("Distribution",$distribution)
or $self->frontend->mydie("Unknowns distribution '$distribution'\n");
}
######################################################################
sub distribution_info { # ;
my ($self) = @_;
CPAN::DistnameInfo->new ($self->distribution->id);
}
######################################################################
sub build_dir { # ;
my ($self) = @_;
my $build_dir = $self->distribution->{build_dir}
or $self->frontend->mydie("Distribution has not been built yet, cannot proceed");
}
######################################################################
sub is_xs { #
my ($self) = @_;
my @xs = glob File::Spec->catfile ($self->build_dir, '*.xs'); # quick try
unless (@xs) {
require ExtUtils::Manifest;
my $manifest_file = File::Spec->catfile ($self->build_dir, "MANIFEST");
my $manifest = ExtUtils::Manifest::maniread($manifest_file);
@xs = grep /\.xs$/, keys %$manifest;
}
scalar @xs;
}
######################################################################
package CPAN::Plugin;
1;
__END__
=pod
=head1 NAME
CPAN::Plugin - Base class for CPAN shell extensions
=head1 SYNOPSIS
package CPAN::Plugin::Flurb;
use parent 'CPAN::Plugin';
sub post_test {
my ($self, $distribution_object) = @_;
$self = $self->new (distribution_object => $distribution_object);
...;
}
=head1 DESCRIPTION
=head2 Alpha Status
The plugin system in the CPAN shell was introduced in version 2.07 and
is still considered experimental.
=head2 How Plugins work?
See L<CPAN/"Plugin support">.
=head1 METHODS
=head2 plugin_requires
returns list of packages given plugin requires for functionality.
This list is evaluated using C<< CPAN->use_inst >> method.
=head2 distribution_object
Get current distribution object.
=head2 distribution
=head2 distribution_info
=head2 build_dir
Simple delegatees for misc parameters derived from distribution
=head2 is_xs
Predicate to detect whether package contains XS.
=head1 AUTHOR
Branislav Zahradnik <barney@cpan.org>
=cut

263
OGP64/usr/share/perl5/5.40/CPAN/Plugin/Specfile.pm Normal file
View file

@ -0,0 +1,263 @@
=head1 NAME
CPAN::Plugin::Specfile - Proof of concept implementation of a trivial CPAN::Plugin
=head1 SYNOPSIS
# once in the cpan shell
o conf plugin_list push CPAN::Plugin::Specfile
# make permanent
o conf commit
# any time in the cpan shell to write a spec file
test Acme::Meta
# disable
# if it is the last in plugin_list:
o conf plugin_list pop
# otherwise, determine the index to splice:
o conf plugin_list
# and then use splice, e.g. to splice position 3:
o conf plugin_list splice 3 1
=head1 DESCRIPTION
Implemented as a post-test hook, this plugin writes a specfile after
every successful test run. The content is also written to the
terminal.
As a side effect, the timestamps of the written specfiles reflect the
linear order of all dependencies.
B<WARNING:> This code is just a small demo how to use the plugin
system of the CPAN shell, not a full fledged spec file writer. Do not
expect new features in this plugin.
=head2 OPTIONS
The target directory to store the spec files in can be set using C<dir>
as in
o conf plugin_list push CPAN::Plugin::Specfile=dir,/tmp/specfiles-000042
The default directory for this is the
C<plugins/CPAN::Plugin::Specfile> directory in the I<cpan_home>
directory.
=head1 AUTHOR
Andreas Koenig <andk@cpan.org>, Branislav Zahradnik <barney@cpan.org>
=cut
package CPAN::Plugin::Specfile;
our $VERSION = '0.02';
use File::Path;
use File::Spec;
sub __accessor {
my ($class, $key) = @_;
no strict 'refs';
*{$class . '::' . $key} = sub {
my $self = shift;
if (@_) {
$self->{$key} = shift;
}
return $self->{$key};
};
}
BEGIN { __PACKAGE__->__accessor($_) for qw(dir dir_default) }
sub new {
my($class, @rest) = @_;
my $self = bless {}, $class;
while (my($arg,$val) = splice @rest, 0, 2) {
$self->$arg($val);
}
$self->dir_default(File::Spec->catdir($CPAN::Config->{cpan_home},"plugins",__PACKAGE__));
$self;
}
sub post_test {
my $self = shift;
my $distribution_object = shift;
my $distribution = $distribution_object->pretty_id;
unless ($CPAN::META->has_inst("CPAN::DistnameInfo")){
$CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
}
my $d = CPAN::Shell->expand("Distribution",$distribution)
or $CPAN::Frontend->mydie("Unknowns distribution '$distribution'\n");
my $build_dir = $d->{build_dir} or $CPAN::Frontend->mydie("Distribution has not been built yet, cannot proceed");
my %contains = map {($_ => undef)} $d->containsmods;
my @m;
my $width = 16;
my $header = sub {
my($header,$value) = @_;
push @m, sprintf("%-s:%*s%s\n", $header, $width-length($header), "", $value);
};
my $dni = CPAN::DistnameInfo->new($distribution);
my $dist = $dni->dist;
my $summary = CPAN::Shell->_guess_manpage($d,\%contains,$dist);
$header->("Name", "perl-$dist");
my $version = $dni->version;
$header->("Version", $version);
$header->("Release", "1%{?dist}");
#Summary: Template processing system
#Group: Development/Libraries
#License: GPL+ or Artistic
#URL: http://www.template-toolkit.org/
#Source0: http://search.cpan.org/CPAN/authors/id/A/AB/ABW/Template-Toolkit-%{version}.tar.gz
#Patch0: Template-2.22-SREZIC-01.patch
#BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n)
for my $h_tuple
([Summary => $summary],
[Group => "Development/Libraries"],
[License =>],
[URL =>],
[BuildRoot => "%{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n)"],
[Requires => "perl(:MODULE_COMPAT_%(eval \"`%{__perl} -V:version`\"; echo \$version))"],
) {
my($h,$v) = @$h_tuple;
$v = "unknown" unless defined $v;
$header->($h, $v);
}
$header->("Source0", sprintf(
"http://search.cpan.org/CPAN/authors/id/%s/%s/%s",
substr($distribution,0,1),
substr($distribution,0,2),
$distribution
));
require POSIX;
my @xs = glob "$build_dir/*.xs"; # quick try
unless (@xs) {
require ExtUtils::Manifest;
my $manifest_file = "$build_dir/MANIFEST";
my $manifest = ExtUtils::Manifest::maniread($manifest_file);
@xs = grep /\.xs$/, keys %$manifest;
}
if (! @xs) {
$header->('BuildArch', 'noarch');
}
for my $k (sort keys %contains) {
my $m = CPAN::Shell->expand("Module",$k);
my $v = $contains{$k} = $m->cpan_version;
my $vspec = $v eq "undef" ? "" : " = $v";
$header->("Provides", "perl($k)$vspec");
}
if (my $prereq_pm = $d->{prereq_pm}) {
my %req;
for my $reqkey (keys %$prereq_pm) {
while (my($k,$v) = each %{$prereq_pm->{$reqkey}}) {
$req{$k} = $v;
}
}
if (-e "$build_dir/Build.PL" && ! exists $req{"Module::Build"}) {
$req{"Module::Build"} = 0;
}
for my $k (sort keys %req) {
next if $k eq "perl";
my $v = $req{$k};
my $vspec = defined $v && length $v && $v > 0 ? " >= $v" : "";
$header->(BuildRequires => "perl($k)$vspec");
next if $k =~ /^(Module::Build)$/; # MB is always only a
# BuildRequires; if we
# turn it into a
# Requires, then we
# would have to make it
# a BuildRequires
# everywhere we depend
# on *one* MB built
# module.
$header->(Requires => "perl($k)$vspec");
}
}
push @m, "\n%define _use_internal_dependency_generator 0
%define __find_requires %{nil}
%define __find_provides %{nil}
";
push @m, "\n%description\n%{summary}.\n";
push @m, "\n%prep\n%setup -q -n $dist-%{version}\n";
if (-e "$build_dir/Build.PL") {
# see http://www.redhat.com/archives/rpm-list/2002-July/msg00110.html about RPM_BUILD_ROOT vs %{buildroot}
push @m, <<'EOF';
%build
%{__perl} Build.PL --installdirs=vendor --libdoc installvendorman3dir
./Build
%install
rm -rf $RPM_BUILD_ROOT
./Build install destdir=$RPM_BUILD_ROOT create_packlist=0
find $RPM_BUILD_ROOT -depth -type d -exec rmdir {} 2>/dev/null \;
%{_fixperms} $RPM_BUILD_ROOT/*
%check
./Build test
EOF
} elsif (-e "$build_dir/Makefile.PL") {
push @m, <<'EOF';
%build
%{__perl} Makefile.PL INSTALLDIRS=vendor
make %{?_smp_mflags}
%install
rm -rf $RPM_BUILD_ROOT
make pure_install DESTDIR=$RPM_BUILD_ROOT
find $RPM_BUILD_ROOT -type f -name .packlist -exec rm -f {} ';'
find $RPM_BUILD_ROOT -depth -type d -exec rmdir {} 2>/dev/null ';'
%{_fixperms} $RPM_BUILD_ROOT/*
%check
make test
EOF
} else {
$CPAN::Frontend->mydie("'$distribution' has neither a Build.PL nor a Makefile.PL\n");
}
push @m, "\n%clean\nrm -rf \$RPM_BUILD_ROOT\n";
my $vendorlib = @xs ? "vendorarch" : "vendorlib";
my $date = POSIX::strftime("%a %b %d %Y", gmtime);
my @doc = grep { -e "$build_dir/$_" } qw(README Changes);
my $exe_stanza = "\n";
if (my $exe_files = $d->_exe_files) {
if (@$exe_files) {
$exe_stanza = "%{_mandir}/man1/*.1*\n";
for my $e (@$exe_files) {
unless (CPAN->has_inst("File::Basename")) {
$CPAN::Frontend->mydie("File::Basename not installed, cannot continue");
}
my $basename = File::Basename::basename($e);
$exe_stanza .= "/usr/bin/$basename\n";
}
}
}
push @m, <<EOF;
%files
%defattr(-,root,root,-)
%doc @doc
%{perl_$vendorlib}/*
%{_mandir}/man3/*.3*
$exe_stanza
%changelog
* $date <specfile\@specfile.cpan.org> - $version-1
- autogenerated by CPAN::Plugin::Specfile()
EOF
my $ret = join "", @m;
$CPAN::Frontend->myprint($ret);
my $target_dir = $self->dir || $self->dir_default;
File::Path::mkpath($target_dir);
my $outfile = File::Spec->catfile($target_dir, "perl-$dist.spec");
open my $specout, ">", $outfile
or $CPAN::Frontend->mydie("Could not open >$outfile: $!");
print $specout $ret;
$CPAN::Frontend->myprint("Wrote $outfile");
$ret;
}
1;

29
OGP64/usr/share/perl5/5.40/CPAN/Prompt.pm Normal file
View file

@ -0,0 +1,29 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Prompt;
use overload '""' => "as_string";
use vars qw($prompt);
use vars qw(
$VERSION
);
$VERSION = "5.5";
$prompt = "cpan> ";
$CPAN::CurrentCommandId ||= 0;
sub new {
bless {}, shift;
}
sub as_string {
my $word = "cpan";
unless ($CPAN::META->{LOCK}) {
$word = "nolock_cpan";
}
if ($CPAN::Config->{commandnumber_in_prompt}) {
sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
} else {
"$word> ";
}
}
1;

234
OGP64/usr/share/perl5/5.40/CPAN/Queue.pm Normal file
View file

@ -0,0 +1,234 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
use strict;
package CPAN::Queue::Item;
# CPAN::Queue::Item::new ;
sub new {
my($class,@attr) = @_;
my $self = bless { @attr }, $class;
return $self;
}
sub as_string {
my($self) = @_;
$self->{qmod};
}
# r => requires, b => build_requires, c => commandline
sub reqtype {
my($self) = @_;
$self->{reqtype};
}
sub optional {
my($self) = @_;
$self->{optional};
}
package CPAN::Queue;
# One use of the queue is to determine if we should or shouldn't
# announce the availability of a new CPAN module
# Now we try to use it for dependency tracking. For that to happen
# we need to draw a dependency tree and do the leaves first. This can
# easily be reached by running CPAN.pm recursively, but we don't want
# to waste memory and run into deep recursion. So what we can do is
# this:
# CPAN::Queue is the package where the queue is maintained. Dependencies
# often have high priority and must be brought to the head of the queue,
# possibly by jumping the queue if they are already there. My first code
# attempt tried to be extremely correct. Whenever a module needed
# immediate treatment, I either unshifted it to the front of the queue,
# or, if it was already in the queue, I spliced and let it bypass the
# others. This became a too correct model that made it impossible to put
# an item more than once into the queue. Why would you need that? Well,
# you need temporary duplicates as the manager of the queue is a loop
# that
#
# (1) looks at the first item in the queue without shifting it off
#
# (2) cares for the item
#
# (3) removes the item from the queue, *even if its agenda failed and
# even if the item isn't the first in the queue anymore* (that way
# protecting against never ending queues)
#
# So if an item has prerequisites, the installation fails now, but we
# want to retry later. That's easy if we have it twice in the queue.
#
# I also expect insane dependency situations where an item gets more
# than two lives in the queue. Simplest example is triggered by 'install
# Foo Foo Foo'. People make this kind of mistakes and I don't want to
# get in the way. I wanted the queue manager to be a dumb servant, not
# one that knows everything.
#
# Who would I tell in this model that the user wants to be asked before
# processing? I can't attach that information to the module object,
# because not modules are installed but distributions. So I'd have to
# tell the distribution object that it should ask the user before
# processing. Where would the question be triggered then? Most probably
# in CPAN::Distribution::rematein.
use vars qw{ @All $VERSION };
$VERSION = "5.5003";
# CPAN::Queue::queue_item ;
sub queue_item {
my($class,@attr) = @_;
my $item = "$class\::Item"->new(@attr);
$class->qpush($item);
return 1;
}
# CPAN::Queue::qpush ;
sub qpush {
my($class,$obj) = @_;
push @All, $obj;
CPAN->debug(sprintf("in new All[%s]",
join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All),
)) if $CPAN::DEBUG;
}
# CPAN::Queue::first ;
sub first {
my $obj = $All[0];
$obj;
}
# CPAN::Queue::delete_first ;
sub delete_first {
my($class,$what) = @_;
my $i;
for my $i (0..$#All) {
if ( $All[$i]->{qmod} eq $what ) {
splice @All, $i, 1;
last;
}
}
CPAN->debug(sprintf("after delete_first mod[%s] All[%s]",
$what,
join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All)
)) if $CPAN::DEBUG;
}
# CPAN::Queue::jumpqueue ;
sub jumpqueue {
my $class = shift;
my @what = @_;
CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All),
join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @what),
)) if $CPAN::DEBUG;
unless (defined $what[0]{reqtype}) {
# apparently it was not the Shell that sent us this enquiry,
# treat it as commandline
$what[0]{reqtype} = "c";
}
my $inherit_reqtype = $what[0]{reqtype} =~ /^(c|r)$/ ? "r" : "b";
WHAT: for my $what_tuple (@what) {
my($qmod,$reqtype,$optional) = @$what_tuple{qw(qmod reqtype optional)};
if ($reqtype eq "r"
&&
$inherit_reqtype eq "b"
) {
$reqtype = "b";
}
my $jumped = 0;
for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
if ($All[$i]{qmod} eq $qmod) {
$jumped++;
}
}
# high jumped values are normal for popular modules when
# dealing with large bundles: XML::Simple,
# namespace::autoclean, UNIVERSAL::require
CPAN->debug("qmod[$qmod]jumped[$jumped]") if $CPAN::DEBUG;
my $obj = "$class\::Item"->new(
qmod => $qmod,
reqtype => $reqtype,
optional => !! $optional,
);
unshift @All, $obj;
}
CPAN->debug(sprintf("after jumpqueue All[%s]",
join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All)
)) if $CPAN::DEBUG;
}
# CPAN::Queue::exists ;
sub exists {
my($self,$what) = @_;
my @all = map { $_->{qmod} } @All;
my $exists = grep { $_->{qmod} eq $what } @All;
# warn "in exists what[$what] all[@all] exists[$exists]";
$exists;
}
# CPAN::Queue::delete ;
sub delete {
my($self,$mod) = @_;
@All = grep { $_->{qmod} ne $mod } @All;
CPAN->debug(sprintf("after delete mod[%s] All[%s]",
$mod,
join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All)
)) if $CPAN::DEBUG;
}
# CPAN::Queue::nullify_queue ;
sub nullify_queue {
@All = ();
}
# CPAN::Queue::size ;
sub size {
return scalar @All;
}
sub reqtype_of {
my($self,$mod) = @_;
my $best = "";
for my $item (grep { $_->{qmod} eq $mod } @All) {
my $c = $item->{reqtype};
if ($c eq "c") {
$best = $c;
last;
} elsif ($c eq "r") {
$best = $c;
} elsif ($c eq "b") {
if ($best eq "") {
$best = $c;
}
} else {
die "Panic: in reqtype_of: reqtype[$c] seen, should never happen";
}
}
return $best;
}
sub iterator {
my $i = 0;
return sub {
until ($All[$i] || $i > $#All) {
$i++;
}
return if $i > $#All;
return $All[$i++]
};
}
1;
__END__
=head1 NAME
CPAN::Queue - internal queue support for CPAN.pm
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut

2072
OGP64/usr/share/perl5/5.40/CPAN/Shell.pm Normal file
View file

File diff suppressed because it is too large Load diff

479
OGP64/usr/share/perl5/5.40/CPAN/Tarzip.pm Normal file
View file

@ -0,0 +1,479 @@
# -*- 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.5013";
# module is internal to CPAN.pm
@ISA = qw(CPAN::Debug); ## no critic
$BUGHUNTING ||= 0; # released code must have turned off
# it's ok if file doesn't exist, it just matters if it is .gz or .bz2
sub new {
my($class,$file) = @_;
$CPAN::Frontend->mydie("CPAN::Tarzip->new called without arg") unless defined $file;
my $me = { FILE => $file };
if ($file =~ /\.(bz2|gz|zip|tbz|tgz)$/i) {
$me->{ISCOMPRESSED} = 1;
} else {
$me->{ISCOMPRESSED} = 0;
}
if (0) {
} elsif ($file =~ /\.(?:bz2|tbz)$/i) {
unless ($me->{UNGZIPPRG} = $CPAN::Config->{bzip2}) {
my $bzip2 = _my_which("bzip2");
if ($bzip2) {
$me->{UNGZIPPRG} = $bzip2;
} else {
$CPAN::Frontend->mydie(qq{
CPAN.pm needs the external program bzip2 in order to handle '$file'.
Please install it now and run 'o conf init bzip2' from the
CPAN shell prompt to register it as external program.
});
}
}
} else {
$me->{UNGZIPPRG} = _my_which("gzip");
}
$me->{TARPRG} = _my_which("tar") || _my_which("gtar");
bless $me, $class;
}
sub _zlib_ok () {
$CPAN::META->has_inst("Compress::Zlib") or return;
Compress::Zlib->can('gzopen');
}
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 (_zlib_ok) {
my($buffer,$fhw);
$fhw = FileHandle->new($read)
or $CPAN::Frontend->mydie("Could not open $read: $!");
my $cwd = `pwd`;
my $gz = Compress::Zlib::gzopen($write, "wb")
or $CPAN::Frontend->mydie("Cannot gzopen $write: $! (pwd is $cwd)\n");
binmode($fhw);
$gz->gzwrite($buffer)
while read($fhw,$buffer,4096) > 0 ;
$gz->gzclose() ;
$fhw->close;
return 1;
} else {
my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
system(qq{$command -c "$read" > "$write"})==0;
}
}
sub gunzip {
my($self,$write) = @_;
my $read = $self->{FILE};
if (_zlib_ok) {
my($buffer,$fhw);
$fhw = FileHandle->new(">$write")
or $CPAN::Frontend->mydie("Could not open >$write: $!");
my $gz = Compress::Zlib::gzopen($read, "rb")
or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
binmode($fhw);
$fhw->print($buffer)
while $gz->gzread($buffer) > 0 ;
$CPAN::Frontend->mydie("Error reading from $read: $!\n")
if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
$gz->gzclose() ;
$fhw->close;
return 1;
} else {
my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
system(qq{$command -d -c "$read" > "$write"})==0;
}
}
sub gtest {
my($self) = @_;
return $self->{GTEST} if exists $self->{GTEST};
defined $self->{FILE} or $CPAN::Frontend->mydie("gtest called but no FILE specified");
my $read = $self->{FILE};
my $success;
if ($read=~/\.(?:bz2|tbz)$/ && $CPAN::META->has_inst("Compress::Bzip2")) {
my($buffer,$len);
$len = 0;
my $gz = Compress::Bzip2::bzopen($read, "rb")
or $CPAN::Frontend->mydie(sprintf("Cannot bzopen %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)$/ && _zlib_ok ) {
# 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)$/ && _zlib_ok) {
my $gz = Compress::Zlib::gzopen($file,"rb") or
$CPAN::Frontend->mydie("Could not gzopen $file");
$self->{GZ} = $gz;
$class->debug("via Compress::Zlib");
} else {
my $gzip = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
my $pipe = "$gzip -d -c $file |";
my $fh = FileHandle->new($pipe) or $CPAN::Frontend->mydie("Could not pipe[$pipe]: $!");
binmode $fh;
$self->{FH} = $fh;
$class->debug("via external $gzip");
}
$self;
}
sub READLINE {
my($self) = @_;
if (exists $self->{GZ}) {
my $gz = $self->{GZ};
my($line,$bytesread);
$bytesread = $gz->gzreadline($line);
return undef if $bytesread <= 0;
return $line;
} else {
my $fh = $self->{FH};
return scalar <$fh>;
}
}
sub READ {
my($self,$ref,$length,$offset) = @_;
$CPAN::Frontend->mydie("read with offset not implemented") if defined $offset;
if (exists $self->{GZ}) {
my $gz = $self->{GZ};
my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
return $byteread;
} else {
my $fh = $self->{FH};
return read($fh,$$ref,$length);
}
}
sub DESTROY {
my($self) = @_;
if (exists $self->{GZ}) {
my $gz = $self->{GZ};
$gz->gzclose() if defined $gz; # hard to say if it is allowed
# to be undef ever. AK, 2000-09
} else {
my $fh = $self->{FH};
$fh->close if defined $fh;
}
undef $self;
}
sub untar {
my($self) = @_;
my $file = $self->{FILE};
my($prefer) = 0;
my $exttar = $self->{TARPRG} || "";
$exttar = "" if $exttar =~ /^\s+$/; # user refuses to use it
my $extgzip = $self->{UNGZIPPRG} || "";
$extgzip = "" if $extgzip =~ /^\s+$/; # user refuses to use it
if (0) { # makes changing order easier
} elsif ($BUGHUNTING) {
$prefer=2;
} elsif ($CPAN::Config->{prefer_external_tar}) {
$prefer = 1;
} elsif (
$CPAN::META->has_usable("Archive::Tar")
&&
_zlib_ok ) {
my $prefer_external_tar = $CPAN::Config->{prefer_external_tar};
unless (defined $prefer_external_tar) {
if ($^O =~ /(MSWin32|solaris)/) {
$prefer_external_tar = 0;
} else {
$prefer_external_tar = 1;
}
}
$prefer = $prefer_external_tar ? 1 : 2;
} elsif ($exttar && $extgzip) {
# no modules and not bz2
$prefer = 1;
# but solaris binary tar is a problem
if ($^O eq 'solaris' && qx($exttar --version 2>/dev/null) !~ /gnu/i) {
$CPAN::Frontend->mywarn(<< 'END_WARN');
WARNING: Many CPAN distributions were archived with GNU tar and some of
them may be incompatible with Solaris tar. We respectfully suggest you
configure CPAN to use a GNU tar instead ("o conf init tar") or install
a recent Archive::Tar instead;
END_WARN
}
} else {
my $foundtar = $exttar ? "'$exttar'" : "nothing";
my $foundzip = $extgzip ? "'$extgzip'" : $foundtar ? "nothing" : "also nothing";
my $foundAT;
if ($CPAN::META->has_usable("Archive::Tar")) {
$foundAT = sprintf "'%s'", "Archive::Tar::"->VERSION;
} else {
$foundAT = "nothing";
}
my $foundCZ;
if (_zlib_ok) {
$foundCZ = sprintf "'%s'", "Compress::Zlib::"->VERSION;
} elsif ($foundAT) {
$foundCZ = "nothing";
} else {
$foundCZ = "also nothing";
}
$CPAN::Frontend->mydie(qq{
CPAN.pm needs either the external programs tar and gzip -or- both
modules Archive::Tar and Compress::Zlib installed.
For tar I found $foundtar, for gzip $foundzip.
For Archive::Tar I found $foundAT, for Compress::Zlib $foundCZ;
Can't continue cutting file '$file'.
});
}
my $tar_verb = "v";
if (defined $CPAN::Config->{tar_verbosity}) {
$tar_verb = $CPAN::Config->{tar_verbosity} eq "none" ? "" :
$CPAN::Config->{tar_verbosity};
}
if ($prefer==1) { # 1 => external gzip+tar
my($system);
my $is_compressed = $self->gtest();
my $tarcommand = CPAN::HandleConfig->safe_quote($exttar);
if ($is_compressed) {
my $command = CPAN::HandleConfig->safe_quote($extgzip);
$system = qq{$command -d -c }.
qq{< "$file" | $tarcommand x${tar_verb}f -};
} else {
$system = qq{$tarcommand x${tar_verb}f "$file"};
}
if (system($system) != 0) {
# people find the most curious tar binaries that cannot handle
# pipes
if ($is_compressed) {
(my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
$ungzf = basename $ungzf;
my $ct = CPAN::Tarzip->new($file);
if ($ct->gunzip($ungzf)) {
$CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
} else {
$CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
}
$file = $ungzf;
}
$system = qq{$tarcommand x${tar_verb}f "$file"};
$CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
my $ret = system($system);
if ($ret==0) {
$CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
} else {
if ($? == -1) {
$CPAN::Frontend->mydie(sprintf qq{Couldn\'t untar %s: '%s'\n},
$file, $!);
} elsif ($? & 127) {
$CPAN::Frontend->mydie(sprintf qq{Couldn\'t untar %s: child died with signal %d, %s coredump\n},
$file, ($? & 127), ($? & 128) ? 'with' : 'without');
} else {
$CPAN::Frontend->mydie(sprintf qq{Couldn\'t untar %s: child exited with value %d\n},
$file, $? >> 8);
}
}
return 1;
} else {
return 1;
}
} elsif ($prefer==2) { # 2 => modules
unless ($CPAN::META->has_usable("Archive::Tar")) {
$CPAN::Frontend->mydie("Archive::Tar not installed, please install it to continue");
}
# Make sure AT does not use uid/gid/permissions in the archive
# This leaves it to the user's umask instead
local $Archive::Tar::CHMOD = 1;
local $Archive::Tar::SAME_PERMISSIONS = 0;
# Make sure AT leaves current user as owner
local $Archive::Tar::CHOWN = 0;
my $tar = Archive::Tar->new($file,1);
my $af; # archive file
my @af;
if ($BUGHUNTING) {
# RCS 1.337 had this code, it turned out unacceptable slow but
# it revealed a bug in Archive::Tar. Code is only here to hunt
# the bug again. It should never be enabled in published code.
# GDGraph3d-0.53 was an interesting case according to Larry
# Virden.
warn(">>>Bughunting code enabled<<< " x 20);
for $af ($tar->list_files) {
if ($af =~ m!^(/|\.\./)!) {
$CPAN::Frontend->mydie("ALERT: Archive contains ".
"illegal member [$af]");
}
$CPAN::Frontend->myprint("$af\n");
$tar->extract($af); # slow but effective for finding the bug
return if $CPAN::Signal;
}
} else {
for $af ($tar->list_files) {
if ($af =~ m!^(/|\.\./)!) {
$CPAN::Frontend->mydie("ALERT: Archive contains ".
"illegal member [$af]");
}
if ($tar_verb eq "v" || $tar_verb eq "vv") {
$CPAN::Frontend->myprint("$af\n");
}
push @af, $af;
return if $CPAN::Signal;
}
$tar->extract(@af) or
$CPAN::Frontend->mydie("Could not untar with Archive::Tar.");
}
Mac::BuildTools::convert_files([$tar->list_files], 1)
if ($^O eq 'MacOS');
return 1;
}
}
sub unzip {
my($self) = @_;
my $file = $self->{FILE};
if ($CPAN::META->has_inst("Archive::Zip")) {
# blueprint of the code from Archive::Zip::Tree::extractTree();
my $zip = Archive::Zip->new();
my $status;
$status = $zip->read($file);
$CPAN::Frontend->mydie("Read of file[$file] failed\n")
if $status != Archive::Zip::AZ_OK();
$CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
my @members = $zip->members();
for my $member ( @members ) {
my $af = $member->fileName();
if ($af =~ m!^(/|\.\./)!) {
$CPAN::Frontend->mydie("ALERT: Archive contains ".
"illegal member [$af]");
}
$status = $member->extractToFileNamed( $af );
$CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
$CPAN::Frontend->mydie("Extracting of file[$af] from zipfile[$file] failed\n") if
$status != Archive::Zip::AZ_OK();
return if $CPAN::Signal;
}
return 1;
} elsif ( my $unzip = $CPAN::Config->{unzip} ) {
my @system = ($unzip, $file);
return system(@system) == 0;
}
else {
$CPAN::Frontend->mydie(<<"END");
Can't unzip '$file':
You have not configured an 'unzip' program and do not have Archive::Zip
installed. Please either install Archive::Zip or else configure 'unzip'
by running the command 'o conf init unzip' from the CPAN shell prompt.
END
}
}
1;
__END__
=head1 NAME
CPAN::Tarzip - internal handling of tar archives for CPAN.pm
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut

31
OGP64/usr/share/perl5/5.40/CPAN/URL.pm Normal file
View file

@ -0,0 +1,31 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::URL;
use overload '""' => "as_string", fallback => 1;
# accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
# planned are things like age or quality
use vars qw(
$VERSION
);
$VERSION = "5.5";
sub new {
my($class,%args) = @_;
bless {
%args
}, $class;
}
sub as_string {
my($self) = @_;
$self->text;
}
sub text {
my($self,$set) = @_;
if (defined $set) {
$self->{TEXT} = $set;
}
$self->{TEXT};
}
1;

177
OGP64/usr/share/perl5/5.40/CPAN/Version.pm Normal file
View file

@ -0,0 +1,177 @@
package CPAN::Version;
use strict;
use vars qw($VERSION);
$VERSION = "5.5003";
# CPAN::Version::vcmp courtesy Jost Krieger
sub vcmp {
my($self,$l,$r) = @_;
local($^W) = 0;
CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
# treat undef as zero
$l = 0 if $l eq 'undef';
$r = 0 if $r eq 'undef';
return 0 if $l eq $r; # short circuit for quicker success
for ($l,$r) {
s/_//g;
}
CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
for ($l,$r) {
next unless tr/.// > 1 || /^v/;
s/^v?/v/;
1 while s/\.0+(\d)/.$1/; # remove leading zeroes per group
}
CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
if ($l=~/^v/ <=> $r=~/^v/) {
for ($l,$r) {
next if /^v/;
$_ = $self->float2vv($_);
}
}
CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
my $lvstring = "v0";
my $rvstring = "v0";
if ($] >= 5.006
&& $l =~ /^v/
&& $r =~ /^v/) {
$lvstring = $self->vstring($l);
$rvstring = $self->vstring($r);
CPAN->debug(sprintf "lv[%vd] rv[%vd]", $lvstring, $rvstring) if $CPAN::DEBUG;
}
return (
($l ne "undef") <=> ($r ne "undef")
||
$lvstring cmp $rvstring
||
$l <=> $r
||
$l cmp $r
);
}
sub vgt {
my($self,$l,$r) = @_;
$self->vcmp($l,$r) > 0;
}
sub vlt {
my($self,$l,$r) = @_;
$self->vcmp($l,$r) < 0;
}
sub vge {
my($self,$l,$r) = @_;
$self->vcmp($l,$r) >= 0;
}
sub vle {
my($self,$l,$r) = @_;
$self->vcmp($l,$r) <= 0;
}
sub vstring {
my($self,$n) = @_;
$n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
pack "U*", split /\./, $n;
}
# vv => visible vstring
sub float2vv {
my($self,$n) = @_;
my($rev) = int($n);
$rev ||= 0;
my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
# architecture influence
$mantissa ||= 0;
$mantissa .= "0" while length($mantissa)%3;
my $ret = "v" . $rev;
while ($mantissa) {
$mantissa =~ s/(\d{1,3})// or
die "Panic: length>0 but not a digit? mantissa[$mantissa]";
$ret .= ".".int($1);
}
# warn "n[$n]ret[$ret]";
$ret =~ s/(\.0)+/.0/; # v1.0.0 => v1.0
$ret;
}
sub readable {
my($self,$n) = @_;
$n =~ /^([\w\-\+\.]+)/;
return $1 if defined $1 && length($1)>0;
# if the first user reaches version v43, he will be treated as "+".
# We'll have to decide about a new rule here then, depending on what
# will be the prevailing versioning behavior then.
if ($] < 5.006) { # or whenever v-strings were introduced
# we get them wrong anyway, whatever we do, because 5.005 will
# have already interpreted 0.2.4 to be "0.24". So even if he
# indexer sends us something like "v0.2.4" we compare wrongly.
# And if they say v1.2, then the old perl takes it as "v12"
if (defined $CPAN::Frontend) {
$CPAN::Frontend->mywarn("Suspicious version string seen [$n]\n");
} else {
warn("Suspicious version string seen [$n]\n");
}
return $n;
}
my $better = sprintf "v%vd", $n;
CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
return $better;
}
1;
__END__
=head1 NAME
CPAN::Version - utility functions to compare CPAN versions
=head1 SYNOPSIS
use CPAN::Version;
CPAN::Version->vgt("1.1","1.1.1"); # 1 bc. 1.1 > 1.001001
CPAN::Version->vlt("1.1","1.1"); # 0 bc. 1.1 not < 1.1
CPAN::Version->vcmp("1.1","1.1.1"); # 1 bc. first is larger
CPAN::Version->vcmp("1.1.1","1.1"); # -1 bc. first is smaller
CPAN::Version->readable(v1.2.3); # "v1.2.3"
CPAN::Version->vstring("v1.2.3"); # v1.2.3
CPAN::Version->float2vv(1.002003); # "v1.2.3"
=head1 DESCRIPTION
This module mediates between some version that perl sees in a package
and the version that is published by the CPAN indexer.
It's only written as a helper module for both CPAN.pm and CPANPLUS.pm.
As it stands it predates version.pm but has the same goal: make
version strings visible and comparable.
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# End: