package App::cpanminus::fatscript;
#
# You want to install cpanminus? Run the following command and it will
# install itself for you. You might want to run it as a root with sudo
# if you want to install to places like /usr/local/bin.
#
# % curl -L http://cpanmin.us | perl - App::cpanminus
#
# If you don't have curl but wget, replace `curl -L` with `wget -O -`.
#
# For more details about this program, visit http://search.cpan.org/dist/App-cpanminus
our $VERSION = "1.6928";
# DO NOT EDIT -- this is an auto generated file
# This chunk of stuff was generated by App::FatPacker. To find the original
# file's code, look for the end of this BEGIN block or the string 'FATPACK'
BEGIN {
my %fatpacked;
$fatpacked{"App/cpanminus.pm"} = <<'APP_CPANMINUS';
package App::cpanminus;
our $VERSION = "1.6935";
=encoding utf8
=head1 NAME
App::cpanminus - get, unpack, build and install modules from CPAN
=head1 SYNOPSIS
cpanm Module
Run C<cpanm -h> or C<perldoc cpanm> for more options.
=head1 DESCRIPTION
cpanminus is a script to get, unpack, build and install modules from
CPAN and does nothing else.
It's dependency free (can bootstrap itself), requires zero
configuration, and stands alone. When running, it requires only 10MB
of RAM.
=head1 INSTALLATION
There are several ways to install cpanminus to your system.
=head2 Package management system
There are Debian packages, RPMs, FreeBSD ports, and packages for other
operation systems available. If you want to use the package management system,
search for cpanminus and use the appropriate command to install. This makes it
easy to install C<cpanm> to your system without thinking about where to
install, and later upgrade.
=head2 Installing to system perl
You can also use the latest cpanminus to install cpanminus itself:
curl -L http://cpanmin.us | perl - --sudo App::cpanminus
This will install C<cpanm> to your bin directory like
C</usr/local/bin> (unless you configured C<INSTALL_BASE> with
L<local::lib>), so you probably need the C<--sudo> option.
=head2 Installing to local perl (perlbrew)
If you have perl in your home directory, which is the case if you use
tools like L<perlbrew>, you don't need the C<--sudo> option, since
you're most likely to have a write permission to the perl's library
path. You can just do:
curl -L http://cpanmin.us | perl - App::cpanminus
to install the C<cpanm> executable to the perl's bin path, like
C<~/perl5/perlbrew/bin/cpanm>.
=head2 Downloading the standalone executable
You can also copy the standalone executable to whatever location you'd like.
cd ~/bin
curl -LO http://xrl.us/cpanm
chmod +x cpanm
# edit shebang if you don't have /usr/bin/env
This just works, but be sure to grab the new version manually when you
upgrade because C<--self-upgrade> might not work for this.
=head1 DEPENDENCIES
perl 5.8 or later.
=over 4
=item *
'tar' executable (bsdtar or GNU tar version 1.22 are recommended) or Archive::Tar to unpack files.
=item *
C compiler, if you want to build XS modules.
=item *
make
=item *
Module::Build (core in 5.10)
=back
=head1 QUESTIONS
=head2 Another CPAN installer?
OK, the first motivation was this: the CPAN shell runs out of memory (or swaps
heavily and gets really slow) on Slicehost/linode's most affordable plan with
only 256MB RAM. Should I pay more to install perl modules from CPAN? I don't
think so.
=head2 But why a new client?
First of all, let me be clear that CPAN and CPANPLUS are great tools
I've used for I<literally> years (you know how many modules I have on
CPAN, right?). I really respect their efforts of maintaining the most
important tools in the CPAN toolchain ecosystem.
However, for less experienced users (mostly from outside the Perl community),
or even really experienced Perl developers who know how to shoot themselves in
their feet, setting up the CPAN toolchain often feels like yak shaving,
especially when all they want to do is just install some modules and start
writing code.
=head2 Zero-conf? How does this module get/parse/update the CPAN index?
It queries the CPAN Meta DB site at L<http://cpanmetadb.plackperl.org/>.
The site is updated at least every hour to reflect the latest changes
from fast syncing mirrors. The script then also falls back to query the
module at L<http://metacpan.org/> using its wonderful API.
Upon calling these API hosts, cpanm (1.6004 or later) will send the
local perl versions to the server in User-Agent string by default. You
can turn it off with C<--no-report-perl-version> option. Read more
about the option with L<cpanm>, and read more about the privacy policy
about this data collection at L<http://cpanmetadb.plackperl.org/#privacy>
Fetched files are unpacked in C<~/.cpanm> and automatically cleaned up
periodically. You can configure the location of this with the
C<PERL_CPANM_HOME> environment variable.
=head2 Where does this install modules to? Do I need root access?
It installs to wherever ExtUtils::MakeMaker and Module::Build are
configured to (via C<PERL_MM_OPT> and C<PERL_MB_OPT>). So if you're
using local::lib, then it installs to your local perl5
directory. Otherwise it installs to the site_perl directory that
belongs to your perl.
cpanminus at a boot time checks whether you have configured
local::lib, or have the permission to install modules to the site_perl
directory. If neither, it automatically sets up local::lib compatible
installation path in a C<perl5> directory under your home
directory. To avoid this, run the script as the root user, with
C<--sudo> option or with C<--local-lib> option.
=head2 cpanminus can't install the module XYZ. Is it a bug?
It is more likely a problem with the distribution itself. cpanminus
doesn't support or is known to have issues with distributions like as
follows:
=over 4
=item *
Tests that require input from STDIN.
=item *
Tests that might fail when C<AUTOMATED_TESTING> is enabled.
=item *
Modules that have invalid numeric values as VERSION (such as C<1.1a>)
=back
These failures can be reported back to the author of the module so
that they can fix it accordingly, rather than me.
=head2 Does cpanm support the feature XYZ of L<CPAN> and L<CPANPLUS>?
Most likely not. Here are the things that cpanm doesn't do by
itself. And it's a feature - you got that from the name I<minus>,
right?
If you need these features, use L<CPAN>, L<CPANPLUS> or the standalone
tools that are mentioned.
=over 4
=item *
CPAN testers reporting. See L<App::cpanminus::reporter>
=item *
Building RPM packages from CPAN modules
=item *
Listing the outdated modules that needs upgrading. See L<App::cpanoutdated>
=item *
Showing the changes of the modules you're about to upgrade. See L<cpan-listchanges>
=item *
Patching CPAN modules with distroprefs.
=back
See L<cpanm> or C<cpanm -h> to see what cpanminus I<can> do :)
=head1 COPYRIGHT
Copyright 2010- Tatsuhiko Miyagawa
The standalone executable contains the following modules embedded.
=over 4
=item L<CPAN::DistnameInfo> Copyright 2003 Graham Barr
=item L<Parse::CPAN::Meta> Copyright 2006-2009 Adam Kennedy
=item L<local::lib> Copyright 2007-2009 Matt S Trout
=item L<HTTP::Tiny> Copyright 2011 Christian Hansen
=item L<Module::Metadata> Copyright 2001-2006 Ken Williams. 2010 Matt S Trout
=item L<version> Copyright 2004-2010 John Peacock
=item L<JSON::PP> Copyright 2007-2011 by Makamaka Hannyaharamitu
=item L<CPAN::Meta>, L<CPAN::Meta::Requirements> Copyright (c) 2010 by David Golden and Ricardo Signes
=item L<CPAN::Meta::YAML> Copyright 2010 Adam Kennedy
=item L<File::pushd> Copyright 2012 David Golden
=back
=head1 LICENSE
This software is licensed under the same terms as Perl.
=head1 CREDITS
=head2 CONTRIBUTORS
Patches and code improvements were contributed by:
Goro Fuji, Kazuhiro Osawa, Tokuhiro Matsuno, Kenichi Ishigaki, Ian
Wells, Pedro Melo, Masayoshi Sekimura, Matt S Trout (mst), squeeky,
horus and Ingy dot Net.
=head2 ACKNOWLEDGEMENTS
Bug reports, suggestions and feedbacks were sent by, or general
acknowledgement goes to:
Jesse Vincent, David Golden, Andreas Koenig, Jos Boumans, Chris
Williams, Adam Kennedy, Audrey Tang, J. Shirley, Chris Prather, Jesse
Luehrs, Marcus Ramberg, Shawn M Moore, chocolateboy, Chirs Nehren,
Jonathan Rockway, Leon Brocard, Simon Elliott, Ricardo Signes, AEvar
Arnfjord Bjarmason, Eric Wilhelm, Florian Ragwitz and xaicron.
=head1 COMMUNITY
=over 4
=item L<http://github.com/miyagawa/cpanminus> - source code repository, issue tracker
=item L<irc://irc.perl.org/#toolchain> - discussions about Perl toolchain. I'm there.
=back
=head1 NO WARRANTY
This software is provided "as-is," without any express or implied
warranty. In no event shall the author be held liable for any damages
arising from the use of the software.
=head1 SEE ALSO
L<CPAN> L<CPANPLUS> L<pip>
=cut
1;
APP_CPANMINUS
$fatpacked{"App/cpanminus/CPANVersion.pm"} = <<'APP_CPANMINUS_CPANVERSION';
package App::cpanminus::CPANVersion;
# copy of CPAN::Version since it's not core on older 5.8
use strict;
#use vars qw($VERSION);
#$VERSION = "5.5001";
# CPAN::Version::vcmp courtesy Jost Krieger
sub vcmp {
my($self,$l,$r) = @_;
local($^W) = 0;
#CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
return 0 if $l eq $r; # short circuit for quicker success
for ($l,$r) {
s/_//g;
}
#CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
for ($l,$r) {
next unless tr/.// > 1 || /^v/;
s/^v?/v/;
1 while s/\.0+(\d)/.$1/; # remove leading zeroes per group
}
#CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
if ($l=~/^v/ <=> $r=~/^v/) {
for ($l,$r) {
next if /^v/;
$_ = $self->float2vv($_);
}
}
#CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
my $lvstring = "v0";
my $rvstring = "v0";
if ($] >= 5.006
&& $l =~ /^v/
&& $r =~ /^v/) {
$lvstring = $self->vstring($l);
$rvstring = $self->vstring($r);
#CPAN->debug(sprintf "lv[%vd] rv[%vd]", $lvstring, $rvstring) if $CPAN::DEBUG;
}
return (
($l ne "undef") <=> ($r ne "undef")
||
$lvstring cmp $rvstring
||
$l <=> $r
||
$l cmp $r
);
}
sub vgt {
my($self,$l,$r) = @_;
$self->vcmp($l,$r) > 0;
}
sub vlt {
my($self,$l,$r) = @_;
$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__
APP_CPANMINUS_CPANVERSION
$fatpacked{"App/cpanminus/Dependency.pm"} = <<'APP_CPANMINUS_DEPENDENCY';
package App::cpanminus::Dependency;
use strict;
use CPAN::Meta::Requirements;
sub from_prereqs {
my($class, $prereq, $phases, $types) = @_;
my @deps;
for my $type (@$types) {
my $req = CPAN::Meta::Requirements->new;
$req->add_requirements($prereq->requirements_for($_, $type))
for @$phases;
push @deps, $class->from_versions($req->as_string_hash, $type);
}
return @deps;
}
sub from_versions {
my($class, $versions, $type) = @_;
my @deps;
while (my($module, $version) = each %$versions) {
push @deps, $class->new($module, $version, $type)
}
@deps;
}
sub new {
my($class, $module, $version, $type) = @_;
bless {
module => $module,
version => $version,
type => $type || 'requires',
}, $class;
}
sub module { $_[0]->{module} }
sub version { $_[0]->{version} }
sub type { $_[0]->{type} }
sub is_requirement {
$_[0]->{type} eq 'requires';
}
1;
APP_CPANMINUS_DEPENDENCY
$fatpacked{"App/cpanminus/ParsePM.pm"} = <<'APP_CPANMINUS_PARSEPM';
package App::cpanminus::ParsePM;
# fork of Parse::PMFile, use JSON::PP instead of JSON
use strict;
use warnings;
use Safe;
use JSON::PP;
use Dumpvalue;
#use CPAN::Version;
use version ();
use File::Spec ();
use File::Temp ();
use POSIX ':sys_wait_h';
use App::cpanminus::CPANVersion;
our $VERSION = '0.04';
our $VERBOSE = 0;
our $ALLOW_DEV_VERSION = 0;
sub new {
my ($class, $meta) = @_;
bless {META_CONTENT => $meta}, $class;
}
# from PAUSE::pmfile::examine_fio
sub parse {
my ($self, $pmfile) = @_;
$pmfile =~ s|\\|/|g;
my($filemtime) = (stat $pmfile)[9];
$self->{MTIME} = $filemtime;
$self->{PMFILE} = $pmfile;
unless ($self->_version_from_meta_ok) {
$self->{VERSION} = $self->_parse_version;
if ($self->{VERSION} =~ /^\{.*\}$/) {
# JSON error message
} elsif ($self->{VERSION} =~ /[_\s]/ && !$ALLOW_DEV_VERSION){ # ignore developer releases and "You suck!"
return;
}
}
my($ppp) = $self->_packages_per_pmfile;
my @keys_ppp = $self->_filter_ppps(sort keys %$ppp);
$self->_verbose(1,"Will check keys_ppp[@keys_ppp]\n");
#
# Immediately after each package (pmfile) examined contact
# the database
#
my ($package);
DBPACK: foreach $package (@keys_ppp) {
# this part is taken from PAUSE::package::examine_pkg
if ($package !~ /^\w[\w\:\']*\w?\z/
||
$package !~ /\w\z/
||
$package =~ /:/ && $package !~ /::/
||
$package =~ /\w:\w/
||
$package =~ /:::/
){
$self->_verbose(1,"Package[$package] did not pass the ultimate sanity check");
delete $ppp->{$package};
next;
}
# Can't do perm_check() here.
my $pp = $ppp->{$package};
if ($pp->{version} && $pp->{version} =~ /^\{.*\}$/) { # JSON parser error
my $err = JSON::PP::decode_json($pp->{version});
if ($err->{openerr}) {
$self->_verbose(1,
qq{Parse::PMFile was not able to
read the file. It issued the following error: C< $err->{r} >},
);
} else {
$self->_verbose(1,
qq{Parse::PMFile was not able to
parse the following line in that file: C< $err->{line} >
Note: the indexer is running in a Safe compartement and cannot
provide the full functionality of perl in the VERSION line. It
is trying hard, but sometime it fails. As a workaround, please
consider writing a META.yml that contains a 'provides'
attribute or contact the CPAN admins to investigate (yet
another) workaround against "Safe" limitations.)},
);
}
delete $ppp->{$package};
next;
}
# Sanity checks
for (
$package,
$pp->{version},
) {
if (!defined || /^\s*$/ || /\s/){ # for whatever reason I come here
delete $ppp->{$package};
next; # don't screw up 02packages
}
}
} # end foreach package
return $ppp;
}
# from PAUSE::pmfile;
sub _parse_version {
my $self = shift;
use strict;
my $pmfile = $self->{PMFILE};
my $tmpfile = File::Spec->catfile(File::Spec->tmpdir, "ParsePMFile$$" . rand(1000));
my $pmcp = $pmfile;
for ($pmcp) {
s/([^\\](\\\\)*)@/$1\\@/g; # thanks to Raphael Manfredi for the
# solution to escape @s and \
}
my($v);
{
package main; # seems necessary
# XXX: do we need to fork as PAUSE does?
# or, is alarm() just fine?
my $pid = fork();
die "Can't fork: $!" unless defined $pid;
if ($pid) {
waitpid($pid, 0);
if (open my $fh, '<', $tmpfile) {
$v = <$fh>;
}
} else {
# XXX Limit Resources too
my($comp) = Safe->new("_pause::mldistwatch");
my $eval = qq{
local(\$^W) = 0;
App::cpanminus::ParsePM::_parse_version_safely("$pmcp");
};
$comp->permit("entereval"); # for MBARBON/Module-Info-0.30.tar.gz
$comp->share("*App::cpanminus::ParsePM::_parse_version_safely");
$comp->share("*version::new");
$comp->share("*version::numify");
$comp->share_from('main', ['*version::',
'*Exporter::',
'*DynaLoader::']);
$comp->share_from('version', ['&qv']);
# $comp->permit("require"); # no strict!
$comp->deny(qw/enteriter iter unstack goto/); # minimum protection against Acme::BadExample
{
no strict;
$v = $comp->reval($eval);
}
if ($@){ # still in the child process, out of Safe::reval
my $err = $@;
# warn ">>>>>>>err[$err]<<<<<<<<";
if (ref $err) {
if ($err->{line} =~ /[\$*]([\w\:\']*)\bVERSION\b.*?\=(.*)/) {
$v = $comp->reval($2);
}
if ($@) {
$self->_verbose(1, sprintf("reval failed: err[%s] for eval[%s]",
JSON::PP::encode_json($err),
$eval,
));
$v = JSON::PP::encode_json($err);
}
} else {
$v = JSON::PP::encode_json({ openerr => $err });
}
}
if (defined $v) {
$v = $v->numify if ref($v) eq 'version';
} else {
$v = "";
}
open my $fh, '>:utf8', $tmpfile;
print $fh $v;
exit 0;
}
}
unlink $tmpfile if -e $tmpfile;
return $self->_normalize_version($v);
}
# from PAUSE::pmfile;
sub _packages_per_pmfile {
my $self = shift;
my $ppp = {};
my $pmfile = $self->{PMFILE};
my $filemtime = $self->{MTIME};
my $version = $self->{VERSION};
$DB::single++;
open my $fh, "<", "$pmfile" or return $ppp;
local $/ = "\n";
my $inpod = 0;
PLINE: while (<$fh>) {
chomp;
my($pline) = $_;
$inpod = $pline =~ /^=(?!cut)/ ? 1 :
$pline =~ /^=cut/ ? 0 : $inpod;
next if $inpod;
next if substr($pline,0,4) eq "=cut";
$pline =~ s/\#.*//;
next if $pline =~ /^\s*$/;
if ($pline =~ /\b__(?:END|DATA)__\b/
and $pmfile !~ /\.PL$/ # PL files may well have code after __DATA__
){
last PLINE;
}
my $pkg;
my $strict_version;
if (
$pline =~ m{
# (.*) # takes too much time if $pline is long
\bpackage\s+
([\w\:\']+)
\s*
(?: $ | [\}\;] | \s+($version::STRICT) )
}x) {
$pkg = $1;
$strict_version = $2;
if ($pkg eq "DB"){
# XXX if pumpkin and perl make him comaintainer! I
# think I always made the pumpkins comaint on DB
# without further ado (?)
next PLINE;
}
}
if ($pkg) {
# Found something
# from package
$pkg =~ s/\'/::/;
next PLINE unless $pkg =~ /^[A-Za-z]/;
next PLINE unless $pkg =~ /\w$/;
next PLINE if $pkg eq "main";
# Perl::Critic::Policy::TestingAndDebugging::ProhibitShebangWarningsArg
# database for modid in mods, package in packages, package in perms
# alter table mods modify modid varchar(128) binary NOT NULL default '';
# alter table packages modify package varchar(128) binary NOT NULL default '';
next PLINE if length($pkg) > 128;
#restriction
$ppp->{$pkg}{parsed}++;
$ppp->{$pkg}{infile} = $pmfile;
if ($self->_simile($pmfile,$pkg)) {
$ppp->{$pkg}{simile} = $pmfile;
if ($self->_version_from_meta_ok) {
my $provides = $self->{META_CONTENT}{provides};
if (exists $provides->{$pkg}) {
if (exists $provides->{$pkg}{version}) {
my $v = $provides->{$pkg}{version};
if ($v =~ /[_\s]/ && !$ALLOW_DEV_VERSION){ # ignore developer releases and "You suck!"
next PLINE;
} else {
$ppp->{$pkg}{version} = $self->_normalize_version($v);
}
} else {
$ppp->{$pkg}{version} = "undef";
}
}
} else {
if (defined $strict_version){
$ppp->{$pkg}{version} = $strict_version ;
} else {
$ppp->{$pkg}{version} = defined $version ? $version : "";
}
no warnings;
if ($version eq 'undef') {
$ppp->{$pkg}{version} = $version unless defined $ppp->{$pkg}{version};
} else {
$ppp->{$pkg}{version} =
$version
if $version
> $ppp->{$pkg}{version} ||
$version
gt $ppp->{$pkg}{version};
}
}
} else { # not simile
#### it comes later, it would be nonsense
#### to set to "undef". MM_Unix gives us
#### the best we can reasonably consider
$ppp->{$pkg}{version} =
$version
unless defined $ppp->{$pkg}{version} &&
length($ppp->{$pkg}{version});
}
$ppp->{$pkg}{filemtime} = $filemtime;
} else {
# $self->_verbose(2,"no pkg found");
}
}
$fh->close;
$ppp;
}
# from PAUSE::pmfile;
{
no strict;
sub _parse_version_safely {
my($parsefile) = @_;
my $result;
local *FH;
local $/ = "\n";
open(FH,$parsefile) or die "Could not open '$parsefile': $!";
my $inpod = 0;
while (<FH>) {
$inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
next if $inpod || /^\s*#/;
last if /\b__(?:END|DATA)__\b/; # fails on quoted __END__ but this is rare
chop;
# next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/;
next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
my $current_parsed_line = $_;
my $eval = qq{
package #
ExtUtils::MakeMaker::_version;
local $1$2;
\$$2=undef; do {
$_
}; \$$2
};
local $^W = 0;
local $SIG{__WARN__} = sub {};
$result = eval($eval);
# warn "current_parsed_line[$current_parsed_line]\$\@[$@]";
if ($@ or !defined $result){
die +{
eval => $eval,
line => $current_parsed_line,
file => $parsefile,
err => $@,
};
}
last;
} #;
close FH;
$result = "undef" unless defined $result;
return $result;
}
}
# from PAUSE::pmfile;
sub _filter_ppps {
my($self,@ppps) = @_;
my @res;
# very similar code is in PAUSE::dist::filter_pms
MANI: for my $ppp ( @ppps ) {
if ($self->{META_CONTENT}){
my $no_index = $self->{META_CONTENT}{no_index}
|| $self->{META_CONTENT}{private}; # backward compat
if (ref($no_index) eq 'HASH') {
my %map = (
package => qr{\z},
namespace => qr{::},
);
for my $k (qw(package namespace)) {
next unless my $v = $no_index->{$k};
my $rest = $map{$k};
if (ref $v eq "ARRAY") {
for my $ve (@$v) {
$ve =~ s|::$||;
if ($ppp =~ /^$ve$rest/){
$self->_verbose(1,"Skipping ppp[$ppp] due to ve[$ve]");
next MANI;
} else {
$self->_verbose(1,"NOT skipping ppp[$ppp] due to ve[$ve]");
}
}
} else {
$v =~ s|::$||;
if ($ppp =~ /^$v$rest/){
$self->_verbose(1,"Skipping ppp[$ppp] due to v[$v]");
next MANI;
} else {
$self->_verbose(1,"NOT skipping ppp[$ppp] due to v[$v]");
}
}
}
} else {
$self->_verbose(1,"No keyword 'no_index' or 'private' in META_CONTENT");
}
} else {
# $self->_verbose(1,"no META_CONTENT"); # too noisy
}
push @res, $ppp;
}
$self->_verbose(1,"Result of filter_ppps: res[@res]");
@res;
}
# from PAUSE::pmfile;
sub _simile {
my($self,$file,$package) = @_;
# MakeMaker gives them the chance to have the file Simple.pm in
# this directory but have the package HTML::Simple in it.
# Afaik, they wouldn't be able to do so with deeper nested packages
$file =~ s|.*/||;
$file =~ s|\.pm(?:\.PL)?||;
my $ret = $package =~ m/\b\Q$file\E$/;
$ret ||= 0;
unless ($ret) {
# Apache::mod_perl_guide stuffs it into Version.pm
$ret = 1 if lc $file eq 'version';
}
$self->_verbose(1,"Result of simile(): file[$file] package[$package] ret[$ret]\n");
$ret;
}
# from PAUSE::pmfile
sub _normalize_version {
my($self,$v) = @_;
$v = "undef" unless defined $v;
my $dv = Dumpvalue->new;
my $sdv = $dv->stringify($v,1); # second argument prevents ticks
$self->_verbose(1,"Result of normalize_version: sdv[$sdv]\n");
return $v if $v eq "undef";
return $v if $v =~ /^\{.*\}$/; # JSON object
$v =~ s/^\s+//;
$v =~ s/\s+\z//;
if ($v =~ /_/) {
# XXX should pass something like EDEVELOPERRELEASE up e.g.
# SIXTEASE/XML-Entities-0.0306.tar.gz had nothing but one
# such modules and the mesage was not helpful that "nothing
# was found".
return $v ;
}
# may warn "Integer overflow"
my $vv = eval { no warnings; version->new($v)->numify };
if ($@) {
# warn "$v: $@";
return "undef";
}
if ($vv eq $v) {
# the boring 3.14
} else {
my $forced = $self->_force_numeric($v);
if ($forced eq $vv) {
} elsif ($forced =~ /^v(.+)/) {
# rare case where a v1.0.23 slipped in (JANL/w3mir-1.0.10.tar.gz)
$vv = version->new($1)->numify;
} else {
# warn "Unequal forced[$forced] and vv[$vv]";
if ($forced == $vv) {
# the trailing zeroes would cause unnecessary havoc
$vv = $forced;
}
}
}
return $vv;
}
# from PAUSE::pmfile;
sub _force_numeric {
my($self,$v) = @_;
$v = App::cpanminus::CPANVersion->readable($v);
if (
$v =~
/^(\+?)(\d*)(\.(\d*))?/ &&
# "$2$4" ne ''
(
defined $2 && length $2
||
defined $4 && length $4
)
) {
my $two = defined $2 ? $2 : "";
my $three = defined $3 ? $3 : "";
$v = "$two$three";
}
# no else branch! We simply say, everything else is a string.
$v;
}
# from PAUSE::dist
sub _version_from_meta_ok {
my($self) = @_;
return $self->{VERSION_FROM_META_OK} if exists $self->{VERSION_FROM_META_OK};
my $c = $self->{META_CONTENT};
# If there's no provides hash, we can't get our module versions from the
# provides hash! -- rjbs, 2012-03-31
return($self->{VERSION_FROM_META_OK} = 0) unless $c->{provides};
# Some versions of Module::Build geneated an empty provides hash. If we're
# *not* looking at a Module::Build-generated metafile, then it's okay.
my ($mb_v) = (defined $c->{generated_by} ? $c->{generated_by} : '') =~ /Module::Build version ([\d\.]+)/;
return($self->{VERSION_FROM_META_OK} = 1) unless $mb_v;
# ??? I don't know why this is here.
return($self->{VERSION_FROM_META_OK} = 1) if $mb_v eq '0.250.0';
if ($mb_v >= 0.19 && $mb_v < 0.26 && ! keys %{$c->{provides}}) {
# RSAVAGE/Javascript-SHA1-1.01.tgz had an empty provides hash. Ron
# did not find the reason why this happened, but let's not go
# overboard, 0.26 seems a good threshold from the statistics: there
# are not many empty provides hashes from 0.26 up.
return($self->{VERSION_FROM_META_OK} = 0);
}
# We're not in the suspect range of M::B versions. It's good to go.
return($self->{VERSION_FROM_META_OK} = 1);
}
sub _verbose {
my($self,$level,@what) = @_;
warn @what if $level <= $VERBOSE;
}
1;
__END__
APP_CPANMINUS_PARSEPM
$fatpacked{"App/cpanminus/script.pm"} = <<'APP_CPANMINUS_SCRIPT';
package App::cpanminus::script;
use strict;
use Config;
use Cwd ();
use App::cpanminus;
use File::Basename ();
use File::Find ();
use File::Path ();
use File::Spec ();
use File::Copy ();
use File::Temp ();
use Getopt::Long ();
use Parse::CPAN::Meta;
use Symbol ();
use String::ShellQuote ();
use version ();
use aliased 'App::cpanminus::Dependency';
use constant WIN32 => $^O eq 'MSWin32';
use constant SUNOS => $^O eq 'solaris';
use constant CAN_SYMLINK => eval { symlink("", ""); 1 };
our $VERSION = $App::cpanminus::VERSION;
if ($INC{"App/FatPacker/Trace.pm"}) {
require JSON::PP;
require CPAN::Meta::YAML;
require CPAN::Meta::Prereqs;
require version::vpp;
require File::pushd;
}
my $quote = WIN32 ? q/"/ : q/'/;
sub agent {
my $self = shift;
my $agent = "cpanminus/$VERSION";
$agent .= " perl/$]" if $self->{report_perl_version};
$agent;
}
sub determine_home {
my $class = shift;
my $homedir = $ENV{HOME}
|| eval { require File::HomeDir; File::HomeDir->my_home }
|| join('', @ENV{qw(HOMEDRIVE HOMEPATH)}); # Win32
if (WIN32) {
require Win32; # no fatpack
$homedir = Win32::GetShortPathName($homedir);
}
return "$homedir/.cpanm";
}
sub new {
my $class = shift;
bless {
home => $class->determine_home,
cmd => 'install',
seen => {},
notest => undef,
test_only => undef,
installdeps => undef,
force => undef,
sudo => undef,
make => undef,
verbose => undef,
quiet => undef,
interactive => undef,
log => undef,
mirrors => [],
mirror_only => undef,
mirror_index => undef,
cpanmetadb => "http://cpanmetadb.plackperl.org/v1.0/",
perl => $^X,
argv => [],
local_lib => undef,
self_contained => undef,
prompt_timeout => 0,
prompt => undef,
configure_timeout => 60,
build_timeout => 3600,
test_timeout => 1800,
try_lwp => 1,
try_wget => 1,
try_curl => 1,
uninstall_shadows => ($] < 5.012),
skip_installed => 1,
skip_satisfied => 0,
auto_cleanup => 7, # days
pod2man => 1,
installed_dists => 0,
install_types => ['requires'],
with_develop => 0,
showdeps => 0,
scandeps => 0,
scandeps_tree => [],
format => 'tree',
save_dists => undef,
skip_configure => 0,
verify => 0,
report_perl_version => 1,
build_args => {},
features => {},
pure_perl => 0,
cpanfile_path => 'cpanfile',
@_,
}, $class;
}
sub env {
my($self, $key) = @_;
$ENV{"PERL_CPANM_" . $key};
}
sub install_type_handlers {
my $self = shift;
my @handlers;
for my $type (qw( recommends suggests )) {
push @handlers, "with-$type" => sub {
my %uniq;
$self->{install_types} = [ grep !$uniq{$_}++, @{$self->{install_types}}, $type ];
};
push @handlers, "without-$type" => sub {
$self->{install_types} = [ grep $_ ne $type, @{$self->{install_types}} ];
};
}
@handlers;
}
sub build_args_handlers {
my $self = shift;
my @handlers;
for my $phase (qw( configure build test install )) {
push @handlers, "$phase-args=s" => \($self->{build_args}{$phase});
}
@handlers;
}
sub parse_options {
my $self = shift;
local @ARGV = @{$self->{argv}};
push @ARGV, grep length, split /\s+/, $self->env('OPT');
push @ARGV, @_;
Getopt::Long::Configure("bundling");
Getopt::Long::GetOptions(
'f|force' => sub { $self->{skip_installed} = 0; $self->{force} = 1 },
'n|notest!' => \$self->{notest},
'test-only' => sub { $self->{notest} = 0; $self->{skip_installed} = 0; $self->{test_only} = 1 },
'S|sudo!' => \$self->{sudo},
'v|verbose' => sub { $self->{verbose} = $self->{interactive} = 1 },
'verify!' => \$self->{verify},
'q|quiet!' => \$self->{quiet},
'h|help' => sub { $self->{action} = 'show_help' },
'V|version' => sub { $self->{action} = 'show_version' },
'perl=s' => \$self->{perl},
'l|local-lib=s' => sub { $self->{local_lib} = $self->maybe_abs($_[1]) },
'L|local-lib-contained=s' => sub {
$self->{local_lib} = $self->maybe_abs($_[1]);
$self->{self_contained} = 1;
$self->{pod2man} = undef;
},
'self-contained!' => \$self->{self_contained},
'mirror=s@' => $self->{mirrors},
'mirror-only!' => \$self->{mirror_only},
'mirror-index=s' => \$self->{mirror_index},
'cpanmetadb=s' => \$self->{cpanmetadb},
'cascade-search!' => \$self->{cascade_search},
'prompt!' => \$self->{prompt},
'installdeps' => \$self->{installdeps},
'skip-installed!' => \$self->{skip_installed},
'skip-satisfied!' => \$self->{skip_satisfied},
'reinstall' => sub { $self->{skip_installed} = 0 },
'interactive!' => \$self->{interactive},
'i|install' => sub { $self->{cmd} = 'install' },
'info' => sub { $self->{cmd} = 'info' },
'look' => sub { $self->{cmd} = 'look'; $self->{skip_installed} = 0 },
'U|uninstall' => sub { $self->{cmd} = 'uninstall' },
'self-upgrade' => sub { $self->{action} = 'self_upgrade' },
'uninst-shadows!' => \$self->{uninstall_shadows},
'lwp!' => \$self->{try_lwp},
'wget!' => \$self->{try_wget},
'curl!' => \$self->{try_curl},
'auto-cleanup=s' => \$self->{auto_cleanup},
'man-pages!' => \$self->{pod2man},
'scandeps' => \$self->{scandeps},
'showdeps' => sub { $self->{showdeps} = 1; $self->{skip_installed} = 0 },
'format=s' => \$self->{format},
'save-dists=s' => sub {
$self->{save_dists} = $self->maybe_abs($_[1]);
},
'skip-configure!' => \$self->{skip_configure},
'dev!' => \$self->{dev_release},
'metacpan!' => \$self->{metacpan},
'report-perl-version!' => \$self->{report_perl_version},
'configure-timeout=i' => \$self->{configure_timeout},
'build-timeout=i' => \$self->{build_timeout},
'test-timeout=i' => \$self->{test_timeout},
'with-develop' => \$self->{with_develop},
'without-develop' => sub { $self->{with_develop} = 0 },
'with-feature=s' => sub { $self->{features}{$_[1]} = 1 },
'without-feature=s' => sub { $self->{features}{$_[1]} = 0 },
'with-all-features' => sub { $self->{features}{__all} = 1 },
'pp|pureperl!' => \$self->{pure_perl},
"cpanfile=s" => \$self->{cpanfile_path},
$self->install_type_handlers,
$self->build_args_handlers,
);
if (!@ARGV && $0 ne '-' && !-t STDIN){ # e.g. # cpanm < author/requires.cpanm
push @ARGV, $self->load_argv_from_fh(\*STDIN);
$self->{load_from_stdin} = 1;
}
$self->{argv} = \@ARGV;
}
sub check_upgrade {
my $self = shift;
my $install_base = $ENV{PERL_LOCAL_LIB_ROOT} ? $self->local_lib_target($ENV{PERL_LOCAL_LIB_ROOT}) : $Config{installsitebin};
if ($0 eq '-') {
# run from curl, that's fine
return;
} elsif ($0 !~ /^$install_base/) {
if ($0 =~ m!perlbrew/bin!) {
die <<DIE;
It appears your cpanm executable was installed via `perlbrew install-cpanm`.
cpanm --self-upgrade won't upgrade the version of cpanm you're running.
Run the following command to get it upgraded.
perlbrew install-cpanm
DIE
} else {
die <<DIE;
You are running cpanm from the path where your current perl won't install executables to.
Because of that, cpanm --self-upgrade won't upgrade the version of cpanm you're running.
cpanm path : $0
Install path : $Config{installsitebin}
It means you either installed cpanm globally with system perl, or use distro packages such
as rpm or apt-get, and you have to use them again to upgrade cpanm.
DIE
}
}
}
sub check_libs {
my $self = shift;
return if $self->{_checked}++;
$self->bootstrap_local_lib;
if (@{$self->{bootstrap_deps} || []}) {
local $self->{notest} = 1; # test failure in bootstrap should be tolerated
local $self->{scandeps} = 0;
$self->install_deps(Cwd::cwd, 0, @{$self->{bootstrap_deps}});
}
}
sub setup_verify {
my $self = shift;
my $has_modules = eval { require Module::Signature; require Digest::SHA; 1 };
$self->{cpansign} = $self->which('cpansign');
unless ($has_modules && $self->{cpansign}) {
warn "WARNING: Module::Signature and Digest::SHA is required for distribution verifications.\n";
$self->{verify} = 0;
}
}
sub parse_module_args {
my($self, $module) = @_;
# Plack@1.2 -> Plack~"==1.2"
# BUT don't expand @ in git URLs
$module =~ s/^([A-Za-z0-9_:]+)@([v\d\._]+)$/$1~== $2/;
# Plack~1.20, DBI~"> 1.0, <= 2.0"
if ($module =~ /\~[v\d\._,\!<>= ]+$/) {
return split /\~/, $module, 2;
} else {
return $module, undef;
}
}
sub _exit {
my($self, $code) = @_;
die App::cpanminus::CommandExit->new($code);
}
sub doit {
my $self = shift;
my $code;
eval {
$code = ($self->_doit == 0);
}; if (my $e = $@) {
if (ref $e eq 'App::cpanminus::CommandExit') {
$code = $e->code;
} else {
warn $e;
$code = 1;
}
}
return $code;
}
sub _doit {
my $self = shift;
$self->setup_home;
$self->init_tools;
$self->setup_verify if $self->{verify};
if (my $action = $self->{action}) {
$self->$action() and return 1;
}
$self->show_help(1)
unless @{$self->{argv}} or $self->{load_from_stdin};
$self->configure_mirrors;
my $cwd = Cwd::cwd;
my @fail;
for my $module (@{$self->{argv}}) {
if ($module =~ s/\.pm$//i) {
my ($volume, $dirs, $file) = File::Spec->splitpath($module);
$module = join '::', grep { $_ } File::Spec->splitdir($dirs), $file;
}
($module, my $version) = $self->parse_module_args($module);
$self->chdir($cwd);
if ($self->{cmd} eq 'uninstall') {
$self->uninstall_module($module)
or push @fail, $module;
} else {
$self->install_module($module, 0, $version)
or push @fail, $module;
}
}
if ($self->{base} && $self->{auto_cleanup}) {
$self->cleanup_workdirs;
}
if ($self->{installed_dists}) {
my $dists = $self->{installed_dists} > 1 ? "distributions" : "distribution";
$self->diag("$self->{installed_dists} $dists installed\n", 1);
}
if ($self->{scandeps}) {
$self->dump_scandeps();
}
# Workaround for older File::Temp's
# where creating a tempdir with an implicit $PWD
# causes tempdir non-cleanup if $PWD changes
# as paths are stored internally without being resolved
# absolutely.
# https://rt.cpan.org/Public/Bug/Display.html?id=44924
$self->chdir($cwd);
return !@fail;
}
sub setup_home {
my $self = shift;
$self->{home} = $self->env('HOME') if $self->env('HOME');
unless (_writable($self->{home})) {
die "Can't write to cpanm home '$self->{home}': You should fix it with chown/chmod first.\n";
}
$self->{base} = "$self->{home}/work/" . time . ".$$";
File::Path::mkpath([ $self->{base} ], 0, 0777);
# native path because we use shell redirect
$self->{log} = File::Spec->catfile($self->{base}, "build.log");
my $final_log = "$self->{home}/build.log";
{ open my $out, ">$self->{log}" or die "$self->{log}: $!" }
if (CAN_SYMLINK) {
my $build_link = "$self->{home}/latest-build";
unlink $build_link;
symlink $self->{base}, $build_link;
unlink $final_log;
symlink $self->{log}, $final_log;
} else {
my $log = $self->{log}; my $home = $self->{home};
$self->{at_exit} = sub {
my $self = shift;
my $temp_log = "$home/build.log." . time . ".$$";
File::Copy::copy($log, $temp_log)
&& unlink($final_log)
&& rename($temp_log, $final_log);
}
}
$self->chat("cpanm (App::cpanminus) $VERSION on perl $] built for $Config{archname}\n" .
"Work directory is $self->{base}\n");
}
sub package_index_for {
my ($self, $mirror) = @_;
return $self->source_for($mirror) . "/02packages.details.txt";
}
sub generate_mirror_index {
my ($self, $mirror) = @_;
my $file = $self->package_index_for($mirror);
my $gz_file = $file . '.gz';
my $index_mtime = (stat $gz_file)[9];
unless (-e $file && (stat $file)[9] >= $index_mtime) {
$self->chat("Uncompressing index file...\n");
if (eval {require Compress::Zlib}) {
my $gz = Compress::Zlib::gzopen($gz_file, "rb")
or do { $self->diag_fail("$Compress::Zlib::gzerrno opening compressed index"); return};
open my $fh, '>', $file
or do { $self->diag_fail("$! opening uncompressed index for write"); return };
my $buffer;
while (my $status = $gz->gzread($buffer)) {
if ($status < 0) {
$self->diag_fail($gz->gzerror . " reading compressed index");
return;
}
print $fh $buffer;
}
} else {
if (system("gunzip -c $gz_file > $file")) {
$self->diag_fail("Cannot uncompress -- please install gunzip or Compress::Zlib");
return;
}
}
utime $index_mtime, $index_mtime, $file;
}
return 1;
}
sub search_mirror_index {
my ($self, $mirror, $module, $version) = @_;
$self->search_mirror_index_file($self->package_index_for($mirror), $module, $version);
}
sub search_mirror_index_file {
my($self, $file, $module, $version) = @_;
open my $fh, '<', $file or return;
my $found;
while (<$fh>) {
if (m!^\Q$module\E\s+([\w\.]+)\s+(\S*)!m) {
$found = $self->cpan_module($module, $2, $1);
last;
}
}
return $found unless $self->{cascade_search};
if ($found) {
if ($self->satisfy_version($module, $found->{module_version}, $version)) {
return $found;
} else {
$self->chat("Found $module $found->{module_version} which doesn't satisfy $version.\n");
}
}
return;
}
sub with_version_range {
my($self, $version) = @_;
defined($version) && $version =~ /[<>=]/;
}
sub encode_json {
my($self, $data) = @_;
require JSON::PP;
my $json = JSON::PP::encode_json($data);
$json =~ s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
$json;
}
# TODO extract this as a module?
sub version_to_query {
my($self, $module, $version) = @_;
require CPAN::Meta::Requirements;
my $requirements = CPAN::Meta::Requirements->new;
$requirements->add_string_requirement($module, $version || '0');
my $req = $requirements->requirements_for_module($module);
if ($req =~ s/^==\s*//) {
return {
term => { 'module.version' => $req },
};
} elsif ($req !~ /\s/) {
return {
range => { 'module.version_numified' => { 'gte' => $self->numify_ver($req) } },
};
} else {
my %ops = qw(< lt <= lte > gt >= gte);
my(%range, @exclusion);
my @requirements = split /,\s*/, $req;
for my $r (@requirements) {
if ($r =~ s/^([<>]=?)\s*//) {
$range{$ops{$1}} = $self->numify_ver($r);
} elsif ($r =~ s/\!=\s*//) {
push @exclusion, $self->numify_ver($r);
}
}
my @filters= (
{ range => { 'module.version_numified' => \%range } },
);
if (@exclusion) {
push @filters, {
not => { or => [ map { +{ term => { 'module.version_numified' => $self->numify_ver($_) } } } @exclusion ] },
};
}
return @filters;
}
}
sub numify_ver {
my($self, $ver) = @_;
version->new($ver)->numify;
}
sub maturity_filter {
my($self, $module, $version) = @_;
my @filters;
# TODO: dev release should be enabled per dist
if (!$self->with_version_range($version) or $self->{dev_release}) {
# backpan'ed dev release are considered "cancelled"
push @filters, { not => { term => { status => 'backpan' } } };
}
unless ($self->{dev_release} or $version =~ /==/) {
push @filters, { term => { maturity => 'released' } };
}
return @filters;
}
sub by_stability {
my %s = qw( latest 3 cpan 2 backpan 1 );
$b->{_score} <=> $a->{_score} || # version: higher version that satisfies the query
$s{ $b->{fields}{status} } <=> $s{ $a->{fields}{status} } || # prefer non-BackPAN dist
$a->{fields}{date} cmp $b->{fields}{date}; # first one wins, if all are in BackPAN/CPAN
}
sub find_best_match {
my($self, $match, $version) = @_;
return unless $match && @{$match->{hits}{hits} || []};
(sort by_stability @{$match->{hits}{hits}})[0]->{fields};
}
sub search_metacpan {
my($self, $module, $version) = @_;
require JSON::PP;
$self->chat("Searching $module ($version) on metacpan ...\n");
my $metacpan_uri = 'http://api.metacpan.org/v0';
my @filter = $self->maturity_filter($module, $version);
my $query = { filtered => {
(@filter ? (filter => { and => \@filter }) : ()),
query => { nested => {
score_mode => 'max',
path => 'module',
query => { custom_score => {
metacpan_script => "score_version_numified",
query => { constant_score => {
filter => { and => [
{ term => { 'module.authorized' => JSON::PP::true() } },
{ term => { 'module.indexed' => JSON::PP::true() } },
{ term => { 'module.name' => $module } },
$self->version_to_query($module, $version),
] }
} },
} },
} },
} };
my $module_uri = "$metacpan_uri/file/_search?source=";
$module_uri .= $self->encode_json({
query => $query,
fields => [ 'date', 'release', 'module', 'status' ],
});
my($release, $module_version);
my $module_json = $self->get($module_uri);
my $module_meta = eval { JSON::PP::decode_json($module_json) };
my $match = $self->find_best_match($module_meta);
if ($match) {
$release = $match->{release};
my $module_matched = (grep { $_->{name} eq $module } @{$match->{module}})[0];
$module_version = $module_matched->{version};
}
unless ($release) {
$self->chat("! Could not find a release matching $module ($version) on MetaCPAN.\n");
return;
}
my $dist_uri = "$metacpan_uri/release/_search?source=";
$dist_uri .= $self->encode_json({
filter => {
term => { 'release.name' => $release },
},
fields => [ 'download_url', 'stat', 'status' ],
});
my $dist_json = $self->get($dist_uri);
my $dist_meta = eval { JSON::PP::decode_json($dist_json) };
if ($dist_meta) {
$dist_meta = $dist_meta->{hits}{hits}[0]{fields};
}
if ($dist_meta && $dist_meta->{download_url}) {
(my $distfile = $dist_meta->{download_url}) =~ s!.+/authors/id/!!;
local $self->{mirrors} = $self->{mirrors};
if ($dist_meta->{status} eq 'backpan') {
$self->{mirrors} = [ 'http://backpan.perl.org' ];
} elsif ($dist_meta->{stat}{mtime} > time()-24*60*60) {
$self->{mirrors} = [ 'http://cpan.metacpan.org' ];
}
return $self->cpan_module($module, $distfile, $module_version);
}
$self->diag_fail("Finding $module on metacpan failed.");
return;
}
sub search_database {
my($self, $module, $version) = @_;
my $found;
my $range = ($self->with_version_range($version) || $self->{dev_release});
if ($range or $self->{metacpan}) {
$found = $self->search_metacpan($module, $version) and return $found;
$found = $self->search_cpanmetadb($module, $version) and return $found;
} else {
$found = $self->search_cpanmetadb($module, $version) and return $found;
$found = $self->search_metacpan($module, $version) and return $found;
}
}
sub search_cpanmetadb {
my($self, $module, $version) = @_;
$self->chat("Searching $module on cpanmetadb ...\n");
(my $uri = $self->{cpanmetadb}) =~ s{/?$}{/package/$module};
my $yaml = $self->get($uri);
my $meta = $self->parse_meta_string($yaml);
if ($meta && $meta->{distfile}) {
return $self->cpan_module($module, $meta->{distfile}, $meta->{version});
}
$self->diag_fail("Finding $module on cpanmetadb failed.");
return;
}
sub search_module {
my($self, $module, $version) = @_;
if ($self->{mirror_index}) {
$self->mask_output( chat => "Searching $module on mirror index $self->{mirror_index} ...\n" );
my $pkg = $self->search_mirror_index_file($self->{mirror_index}, $module, $version);
return $pkg if $pkg;
unless ($self->{cascade_search}) {
$self->mask_output( diag_fail => "Finding $module ($version) on mirror index $self->{mirror_index} failed." );
return;
}
}
unless ($self->{mirror_only}) {
my $found = $self->search_database($module, $version);
return $found if $found;
}
MIRROR: for my $mirror (@{ $self->{mirrors} }) {
$self->mask_output( chat => "Searching $module on mirror $mirror ...\n" );
my $name = '02packages.details.txt.gz';
my $uri = "$mirror/modules/$name";
my $gz_file = $self->package_index_for($mirror) . '.gz';
unless ($self->{pkgs}{$uri}) {
$self->mask_output( chat => "Downloading index file $uri ...\n" );
$self->mirror($uri, $gz_file);
$self->generate_mirror_index($mirror) or next MIRROR;
$self->{pkgs}{$uri} = "!!retrieved!!";
}
my $pkg = $self->search_mirror_index($mirror, $module, $version);
return $pkg if $pkg;
$self->mask_output( diag_fail => "Finding $module ($version) on mirror $mirror failed." );
}
return;
}
sub source_for {
my($self, $mirror) = @_;
$mirror =~ s/[^\w\.\-]+/%/g;
my $dir = "$self->{home}/sources/$mirror";
File::Path::mkpath([ $dir ], 0, 0777);
return $dir;
}
sub load_argv_from_fh {
my($self, $fh) = @_;
my @argv;
while(defined(my $line = <$fh>)){
chomp $line;
$line =~ s/#.+$//; # comment
$line =~ s/^\s+//; # trim spaces
$line =~ s/\s+$//; # trim spaces
push @argv, split ' ', $line if $line;
}
return @argv;
}
sub show_version {
my $self = shift;
print "cpanm (App::cpanminus) version $VERSION ($0)\n";
print "perl version $] ($^X)\n\n";
print " \%Config:\n";
for my $key (qw( archname installsitelib installsitebin installman1dir installman3dir
sitelibexp archlibexp privlibexp )) {
print " $key=$Config{$key}\n";
}
print " \%ENV:\n";
for my $key (grep /^PERL/, sort keys %ENV) {
print " $key=$ENV{$key}\n";
}
print " \@INC:\n";
for my $inc (@INC) {
print " $inc\n" unless ref($inc) eq 'CODE';
}
return 1;
}
sub show_help {
my $self = shift;
if ($_[0]) {
print <<USAGE;
Usage: cpanm [options] Module [...]
Try `cpanm --help` or `man cpanm` for more options.
USAGE
$self->_exit(1);
}
print <<HELP;
Usage: cpanm [options] Module [...]
Options:
-v,--verbose Turns on chatty output
-q,--quiet Turns off the most output
--interactive Turns on interactive configure (required for Task:: modules)
-f,--force force install
-n,--notest Do not run unit tests
--test-only Run tests only, do not install
-S,--sudo sudo to run install commands
--installdeps Only install dependencies
--showdeps Only display direct dependencies
--reinstall Reinstall the distribution even if you already have the latest version installed
--mirror Specify the base URL for the mirror (e.g. http://cpan.cpantesters.org/)
--mirror-only Use the mirror's index file instead of the CPAN Meta DB
--prompt Prompt when configure/build/test fails
-l,--local-lib Specify the install base to install modules
-L,--local-lib-contained Specify the install base to install all non-core modules
--self-contained Install all non-core modules, even if they're already installed.
--auto-cleanup Number of days that cpanm's work directories expire in. Defaults to 7
Commands:
--self-upgrade upgrades itself
--info Displays distribution info on CPAN
--look Opens the distribution with your SHELL
-U,--uninstall Uninstalls the modules (EXPERIMENTAL)
-V,--version Displays software version
Examples:
cpanm Test::More # install Test::More
cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution path
cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz # install from URL
cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz # install from a local file
cpanm --interactive Task::Kensho # Configure interactively
cpanm . # install from local directory
cpanm --installdeps . # install all the deps for the current directory
cpanm -L extlib Plack # install Plack and all non-core deps into extlib
cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror
You can also specify the default options in PERL_CPANM_OPT environment variable in the shell rc:
export PERL_CPANM_OPT="--prompt --reinstall -l ~/perl --mirror http://cpan.cpantesters.org"
Type `man cpanm` or `perldoc cpanm` for the more detailed explanation of the options.
HELP
return 1;
}
sub _writable {
my $dir = shift;
my @dir = File::Spec->splitdir($dir);
while (@dir) {
$dir = File::Spec->catdir(@dir);
if (-e $dir) {
return -w _;
}
pop @dir;
}
return;
}
sub maybe_abs {
my($self, $lib) = @_;
if ($lib eq '_' or $lib =~ /^~/ or File::Spec->file_name_is_absolute($lib)) {
return $lib;
} else {
return File::Spec->canonpath(File::Spec->catdir(Cwd::cwd(), $lib));
}
}
sub local_lib_target {
my($self, $root) = @_;
(grep { $_ ne '' } split /\Q$Config{path_sep}/, $root)[-1];
}
sub bootstrap_local_lib {
my $self = shift;
# If -l is specified, use that.
if ($self->{local_lib}) {
return $self->setup_local_lib($self->{local_lib});
}
# PERL_LOCAL_LIB_ROOT is defined. Run as local::lib mode without overwriting ENV
if ($ENV{PERL_LOCAL_LIB_ROOT} && $ENV{PERL_MM_OPT}) {
return $self->setup_local_lib($self->local_lib_target($ENV{PERL_LOCAL_LIB_ROOT}), 1);
}
# root, locally-installed perl or --sudo: don't care about install_base
return if $self->{sudo} or (_writable($Config{installsitelib}) and _writable($Config{installsitebin}));
# local::lib is configured in the shell -- yay
if ($ENV{PERL_MM_OPT} and ($ENV{MODULEBUILDRC} or $ENV{PERL_MB_OPT})) {
$self->bootstrap_local_lib_deps;
return;
}
$self->setup_local_lib;
$self->diag(<<DIAG);
!
! Can't write to $Config{installsitelib} and $Config{installsitebin}: Installing modules to $ENV{HOME}/perl5
! To turn off this warning, you have to do one of the following:
! - run me as a root or with --sudo option (to install to $Config{installsitelib} and $Config{installsitebin})
! - Configure local::lib your existing local::lib in this shell to set PERL_MM_OPT etc.
! - Install local::lib by running the following commands
!
! cpanm --local-lib=~/perl5 local::lib && eval \$(perl -I ~/perl5/lib/perl5/ -Mlocal::lib)
!
DIAG
sleep 2;
}
sub _core_only_inc {
my($self, $base) = @_;
require local::lib;
(
local::lib->resolve_path(local::lib->install_base_perl_path($base)),
local::lib->resolve_path(local::lib->install_base_arch_path($base)),
@Config{qw(privlibexp archlibexp)},
);
}
sub _diff {
my($self, $old, $new) = @_;
my @diff;
my %old = map { $_ => 1 } @$old;
for my $n (@$new) {
push @diff, $n unless exists $old{$n};
}
@diff;
}
sub _setup_local_lib_env {
my($self, $base) = @_;
local $SIG{__WARN__} = sub { }; # catch 'Attempting to write ...'
local::lib->setup_env_hash_for($base, 0);
}
sub setup_local_lib {
my($self, $base, $no_env) = @_;
$base = undef if $base eq '_';
require local::lib;
{
local $0 = 'cpanm'; # so curl/wget | perl works
$base ||= "~/perl5";
$base = local::lib->resolve_path($base);
if ($self->{self_contained}) {
my @inc = $self->_core_only_inc($base);
$self->{search_inc} = [ @inc ];
} else {
$self->{search_inc} = [
local::lib->install_base_arch_path($base),
local::lib->install_base_perl_path($base),
@INC,
];
}
$self->_setup_local_lib_env($base) unless $no_env;
$self->{local_lib} = $base;
}
$self->bootstrap_local_lib_deps;
}
sub bootstrap_local_lib_deps {
my $self = shift;
push @{$self->{bootstrap_deps}},
Dependency->new('ExtUtils::MakeMaker' => 6.31),
Dependency->new('ExtUtils::Install' => 1.46);
}
sub prompt_bool {
my($self, $mess, $def) = @_;
my $val = $self->prompt($mess, $def);
return lc $val eq 'y';
}
sub prompt {
my($self, $mess, $def) = @_;
my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ;
my $dispdef = defined $def ? "[$def] " : " ";
$def = defined $def ? $def : "";
if (!$self->{prompt} || (!$isa_tty && eof STDIN)) {
return $def;
}
local $|=1;
local $\;
my $ans;
eval {
local $SIG{ALRM} = sub { undef $ans; die "alarm\n" };
print STDOUT "$mess $dispdef";
alarm $self->{prompt_timeout} if $self->{prompt_timeout};
$ans = <STDIN>;
alarm 0;
};
if ( defined $ans ) {
chomp $ans;
} else { # user hit ctrl-D or alarm timeout
print STDOUT "\n";
}
return (!defined $ans || $ans eq '') ? $def : $ans;
}
sub diag_ok {
my($self, $msg) = @_;
chomp $msg;
$msg ||= "OK";
if ($self->{in_progress}) {
$self->_diag("$msg\n");
$self->{in_progress} = 0;
}
$self->log("-> $msg\n");
}
sub diag_fail {
my($self, $msg, $always) = @_;
chomp $msg;
if ($self->{in_progress}) {
$self->_diag("FAIL\n");
$self->{in_progress} = 0;
}
if ($msg) {
$self->_diag("! $msg\n", $always, 1);
$self->log("-> FAIL $msg\n");
}
}
sub diag_progress {
my($self, $msg) = @_;
chomp $msg;
$self->{in_progress} = 1;
$self->_diag("$msg ... ");
$self->log("$msg\n");
}
sub _diag {
my($self, $msg, $always, $error) = @_;
my $fh = $error ? *STDERR : *STDOUT;
print {$fh} $msg if $always or $self->{verbose} or !$self->{quiet};
}
sub diag {
my($self, $msg, $always) = @_;
$self->_diag($msg, $always);
$self->log($msg);
}
sub chat {
my $self = shift;
print STDERR @_ if $self->{verbose};
$self->log(@_);
}
sub mask_output {
my $self = shift;
my $method = shift;
$self->$method( $self->mask_uri_passwords(@_) );
}
sub log {
my $self = shift;
open my $out, ">>$self->{log}";
print $out @_;
}
sub run {
my($self, $cmd) = @_;
if (WIN32) {
$cmd = $self->shell_quote(@$cmd) if ref $cmd eq 'ARRAY';
unless ($self->{verbose}) {
$cmd .= " >> " . $self->shell_quote($self->{log}) . " 2>&1";
}
!system $cmd;
} else {
my $pid = fork;
if ($pid) {
waitpid $pid, 0;
return !$?;
} else {
$self->run_exec($cmd);
}
}
}
sub run_exec {
my($self, $cmd) = @_;
if (ref $cmd eq 'ARRAY') {
unless ($self->{verbose}) {
open my $logfh, ">>", $self->{log};
open STDERR, '>&', $logfh;
open STDOUT, '>&', $logfh;
close $logfh;
}
exec @$cmd;
} else {
unless ($self->{verbose}) {
$cmd .= " >> " . $self->shell_quote($self->{log}) . " 2>&1";
}
exec $cmd;
}
}
sub run_timeout {
my($self, $cmd, $timeout) = @_;
return $self->run($cmd) if WIN32 || $self->{verbose} || !$timeout;
my $pid = fork;
if ($pid) {
eval {
local $SIG{ALRM} = sub { die "alarm\n" };
alarm $timeout;
waitpid $pid, 0;
alarm 0;
};
if ($@ && $@ eq "alarm\n") {
$self->diag_fail("Timed out (> ${timeout}s). Use --verbose to retry.");
local $SIG{TERM} = 'IGNORE';
kill TERM => 0;
waitpid $pid, 0;
return;
}
return !$?;
} elsif ($pid == 0) {
$self->run_exec($cmd);
} else {
$self->chat("! fork failed: falling back to system()\n");
$self->run($cmd);
}
}
sub append_args {
my($self, $cmd, $phase) = @_;
if (my $args = $self->{build_args}{$phase}) {
$cmd = join ' ', $self->shell_quote(@$cmd), $args;
}
$cmd;
}
sub configure {
my($self, $cmd, $depth) = @_;
# trick AutoInstall
local $ENV{PERL5_CPAN_IS_RUNNING} = local $ENV{PERL5_CPANPLUS_IS_RUNNING} = $$;
# e.g. skip CPAN configuration on local::lib
local $ENV{PERL5_CPANM_IS_RUNNING} = $$;
my $use_default = !$self->{interactive};
local $ENV{PERL_MM_USE_DEFAULT} = $use_default;
# skip man page generation
local $ENV{PERL_MM_OPT} = $ENV{PERL_MM_OPT};
unless ($self->{pod2man}) {
$ENV{PERL_MM_OPT} .= " INSTALLMAN1DIR=none INSTALLMAN3DIR=none";
$ENV{PERL_MB_OPT} .= " --config installman1dir= --config installsiteman1dir= --config installman3dir= --config installsiteman3dir=";
}
# Lancaster Consensus
if ($self->{pure_perl}) {
$ENV{PERL_MM_OPT} .= " PUREPERL_ONLY=1";
$ENV{PERL_MB_OPT} .= " --pureperl-only";
}
$cmd = $self->append_args($cmd, 'configure') if $depth == 0;
local $self->{verbose} = $self->{verbose} || $self->{interactive};
$self->run_timeout($cmd, $self->{configure_timeout});
}
sub build {
my($self, $cmd, $distname, $depth) = @_;
local $ENV{PERL_MM_USE_DEFAULT} = !$self->{interactive};
$cmd = $self->append_args($cmd, 'build') if $depth == 0;
return 1 if $self->run_timeout($cmd, $self->{build_timeout});
while (1) {
my $ans = lc $self->prompt("Building $distname failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?", "s");
return if $ans eq 's';
return $self->build($cmd, $distname, $depth) if $ans eq 'r';
$self->show_build_log if $ans eq 'e';
$self->look if $ans eq 'l';
}
}
sub test {
my($self, $cmd, $distname, $depth) = @_;
return 1 if $self->{notest};
# https://rt.cpan.org/Ticket/Display.html?id=48965#txn-1013385
local $ENV{PERL_MM_USE_DEFAULT} = !$self->{interactive};
# https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/lancaster-consensus.md
local $ENV{NONINTERACTIVE_TESTING} = !$self->{interactive};
$cmd = $self->append_args($cmd, 'test') if $depth == 0;
return 1 if $self->run_timeout($cmd, $self->{test_timeout});
if ($self->{force}) {
$self->diag_fail("Testing $distname failed but installing it anyway.");
return 1;
} else {
$self->diag_fail;
while (1) {
my $ans = lc $self->prompt("Testing $distname failed.\nYou can s)kip, r)etry, f)orce install, e)xamine build log, or l)ook ?", "s");
return if $ans eq 's';
return $self->test($cmd, $distname, $depth) if $ans eq 'r';
return 1 if $ans eq 'f';
$self->show_build_log if $ans eq 'e';
$self->look if $ans eq 'l';
}
}
}
sub install {
my($self, $cmd, $uninst_opts, $depth) = @_;
if ($depth == 0 && $self->{test_only}) {
return 1;
}
if ($self->{sudo}) {
unshift @$cmd, "sudo";
}
if ($self->{uninstall_shadows} && !$ENV{PERL_MM_OPT}) {
push @$cmd, @$uninst_opts;
}
$cmd = $self->append_args($cmd, 'install') if $depth == 0;
$self->run($cmd);
}
sub look {
my $self = shift;
my $shell = $ENV{SHELL};
$shell ||= $ENV{COMSPEC} if WIN32;
if ($shell) {
my $cwd = Cwd::cwd;
$self->diag("Entering $cwd with $shell\n");
system $shell;
} else {
$self->diag_fail("You don't seem to have a SHELL :/");
}
}
sub show_build_log {
my $self = shift;
my @pagers = (
$ENV{PAGER},
(WIN32 ? () : ('less')),
'more'
);
my $pager;
while (@pagers) {
$pager = shift @pagers;
next unless $pager;
$pager = $self->which($pager);
next unless $pager;
last;
}
if ($pager) {
# win32 'more' doesn't allow "more build.log", the < is required
system("$pager < $self->{log}");
}
else {
$self->diag_fail("You don't seem to have a PAGER :/");
}
}
sub chdir {
my $self = shift;
Cwd::chdir(File::Spec->canonpath($_[0])) or die "$_[0]: $!";
}
sub configure_mirrors {
my $self = shift;
unless (@{$self->{mirrors}}) {
$self->{mirrors} = [ 'http://www.cpan.org' ];
}
for (@{$self->{mirrors}}) {
s!^/!file:///!;
s!/$!!;
}
}
sub self_upgrade {
my $self = shift;
$self->check_upgrade;
$self->{argv} = [ 'App::cpanminus' ];
return; # continue
}
sub install_module {
my($self, $module, $depth, $version) = @_;
if ($self->{seen}{$module}++) {
# TODO: circular dependencies
$self->chat("Already tried $module. Skipping.\n");
return 1;
}
$self->check_libs;
if ($self->{skip_satisfied}) {
my($ok, $local) = $self->check_module($module, $version || 0);
if ($ok) {
$self->diag("You have $module ($local)\n", 1);
return 1;
}
}
my $dist = $self->resolve_name($module, $version);
unless ($dist) {
my $what = $module . ($version ? " ($version)" : "");
$self->diag_fail("Couldn't find module or a distribution $what", 1);
return;
}
if ($dist->{distvname} && $self->{seen}{$dist->{distvname}}++) {
$self->chat("Already tried $dist->{distvname}. Skipping.\n");
return 1;
}
if ($self->{cmd} eq 'info') {
print $self->format_dist($dist), "\n";
return 1;
}
$dist->{depth} = $depth; # ugly hack
if ($dist->{module}) {
unless ($self->satisfy_version($dist->{module}, $dist->{module_version}, $version)) {
$self->diag("Found $dist->{module} $dist->{module_version} which doesn't satisfy $version.\n", 1);
return;
}
# If a version is requested, it has to be the exact same version, otherwise, check as if
# it is the minimum version you need.
my $cmp = $version ? "==" : "";
my $requirement = $dist->{module_version} ? "$cmp$dist->{module_version}" : 0;
my($ok, $local) = $self->check_module($dist->{module}, $requirement);
if ($self->{skip_installed} && $ok) {
$self->diag("$dist->{module} is up to date. ($local)\n", 1);
return 1;
}
}
if ($dist->{dist} eq 'perl'){
$self->diag("skipping $dist->{pathname}\n");
return 1;
}
$self->diag("--> Working on $module\n");
$dist->{dir} ||= $self->fetch_module($dist);
unless ($dist->{dir}) {
$self->diag_fail("Failed to fetch distribution $dist->{distvname}", 1);
return;
}
$self->chat("Entering $dist->{dir}\n");
$self->chdir($self->{base});
$self->chdir($dist->{dir});
if ($self->{cmd} eq 'look') {
$self->look;
return 1;
}
return $self->build_stuff($module, $dist, $depth);
}
sub uninstall_search_path {
my $self = shift;
$self->{local_lib}
? (local::lib->install_base_arch_path($self->{local_lib}),
local::lib->install_base_perl_path($self->{local_lib}))
: @Config{qw(installsitearch installsitelib)};
}
sub uninstall_module {
my ($self, $module) = @_;
$self->check_libs;
my @inc = $self->uninstall_search_path;
my($metadata, $packlist) = $self->packlists_containing($module, \@inc);
unless ($packlist) {
$self->diag_fail(<<DIAG, 1);
$module is not found in the following directories and can't be uninstalled.
@{[ join(" \n", map " $_", @inc) ]}
DIAG
return;
}
my @uninst_files = $self->uninstall_target($metadata, $packlist);
$self->ask_permission($module, \@uninst_files) or return;
$self->uninstall_files(@uninst_files, $packlist);
$self->diag("Successfully uninstalled $module\n", 1);
return 1;
}
sub packlists_containing {
my($self, $module, $inc) = @_;
require Module::Metadata;
my $metadata = Module::Metadata->new_from_module($module, inc => $inc)
or return;
my $packlist;
my $wanted = sub {
return unless $_ eq '.packlist' && -f $_;
for my $file ($self->unpack_packlist($File::Find::name)) {
$packlist ||= $File::Find::name if $file eq $metadata->filename;
}
};
{
require File::pushd;
my $pushd = File::pushd::pushd();
my @search = grep -d $_, map File::Spec->catdir($_, 'auto'), @$inc;
File::Find::find($wanted, @search);
}
return $metadata, $packlist;
}
sub uninstall_target {
my($self, $metadata, $packlist) = @_;
# If the module has a shadow install, or uses local::lib, then you can't just remove
# all files in .packlist since it might have shadows in there
if ($self->has_shadow_install($metadata) or $self->{local_lib}) {
grep $self->should_unlink($_), $self->unpack_packlist($packlist);
} else {
$self->unpack_packlist($packlist);
}
}
sub has_shadow_install {
my($self, $metadata) = @_;
# check if you have the module in site_perl *and* perl
my @shadow = grep defined, map Module::Metadata->new_from_module($metadata->name, inc => [$_]), @INC;
@shadow >= 2;
}
sub should_unlink {
my($self, $file) = @_;
# If local::lib is used, everything under the directory can be safely removed
# Otherwise, bin and man files might be shared with the shadows i.e. site_perl vs perl
# This is not 100% safe to keep the script there hoping to work with older version of .pm
# files in the shadow, but there's nothing you can do about it.
if ($self->{local_lib}) {
$file =~ /^\Q$self->{local_lib}\E/;
} else {
!(grep $file =~ /^\Q$_\E/, @Config{qw(installbin installscript installman1dir installman3dir)});
}
}
sub ask_permission {
my ($self, $module, $files) = @_;
$self->diag("$module contains the following files:\n\n");
for my $file (@$files) {
$self->diag(" $file\n");
}
$self->diag("\n");
return 'force uninstall' if $self->{force};
local $self->{prompt} = 1;
return $self->prompt_bool("Are you sure you want to uninstall $module?", 'y');
}
sub unpack_packlist {
my ($self, $packlist) = @_;
open my $fh, '<', $packlist or die "$packlist: $!";
map { chomp; $_ } <$fh>;
}
sub uninstall_files {
my ($self, @files) = @_;
$self->diag("\n");
for my $file (@files) {
$self->diag("Unlink: $file\n");
unlink $file or $self->diag_fail("$!: $file");
}
$self->diag("\n");
return 1;
}
sub format_dist {
my($self, $dist) = @_;
# TODO support --dist-format?
return "$dist->{cpanid}/$dist->{filename}";
}
sub trim {
local $_ = shift;
tr/\n/ /d;
s/^\s*|\s*$//g;
$_;
}
sub fetch_module {
my($self, $dist) = @_;
$self->chdir($self->{base});
for my $uri (@{$dist->{uris}}) {
$self->mask_output( diag_progress => "Fetching $uri" );
# Ugh, $dist->{filename} can contain sub directory
my $filename = $dist->{filename} || $uri;
my $name = File::Basename::basename($filename);
my $cancelled;
my $fetch = sub {
my $file;
eval {
local $SIG{INT} = sub { $cancelled = 1; die "SIGINT\n" };
$self->mirror($uri, $name);
$file = $name if -e $name;
};
$self->diag("ERROR: " . trim("$@") . "\n", 1) if $@ && $@ ne "SIGINT\n";
return $file;
};
my($try, $file);
while ($try++ < 3) {
$file = $fetch->();
last if $cancelled or $file;
$self->diag_fail("Download $uri failed. Retrying ... ");
}
if ($cancelled) {
$self->diag_fail("Download cancelled.");
return;
}
unless ($file) {
$self->diag_fail("Failed to download $uri");
next;
}
$self->diag_ok;
$dist->{local_path} = File::Spec->rel2abs($name);
my $dir = $self->unpack($file, $uri, $dist);
next unless $dir; # unpack failed
if (my $save = $self->{save_dists}) {
# Only distros retrieved from CPAN have a pathname set
my $path = $dist->{pathname} ? "$save/authors/id/$dist->{pathname}"
: "$save/vendor/$file";
$self->chat("Copying $name to $path\n");
File::Path::mkpath([ File::Basename::dirname($path) ], 0, 0777);
File::Copy::copy($file, $path) or warn $!;
}
return $dist, $dir;
}
}
sub unpack {
my($self, $file, $uri, $dist) = @_;
if ($self->{verify}) {
$self->verify_archive($file, $uri, $dist) or return;
}
$self->chat("Unpacking $file\n");
my $dir = $file =~ /\.zip/i ? $self->unzip($file) : $self->untar($file);
unless ($dir) {
$self->diag_fail("Failed to unpack $file: no directory");
}
return $dir;
}
sub verify_checksums_signature {
my($self, $chk_file) = @_;
require Module::Signature; # no fatpack
$self->chat("Verifying the signature of CHECKSUMS\n");
my $rv = eval {
local $SIG{__WARN__} = sub {}; # suppress warnings
my $v = Module::Signature::_verify($chk_file);
$v == Module::Signature::SIGNATURE_OK();
};
if ($rv) {
$self->chat("Verified OK!\n");
} else {
$self->diag_fail("Verifying CHECKSUMS signature failed: $rv\n");
return;
}
return 1;
}
sub verify_archive {
my($self, $file, $uri, $dist) = @_;
unless ($dist->{cpanid}) {
$self->chat("Archive '$file' does not seem to be from PAUSE. Skip verification.\n");
}
(my $mirror = $uri) =~ s!/authors/id.*$!!;
(my $chksum_uri = $uri) =~ s!/[^/]*$!/CHECKSUMS!;
my $chk_file = $self->source_for($mirror) . "/$dist->{cpanid}.CHECKSUMS";
$self->mask_output( diag_progress => "Fetching $chksum_uri" );
$self->mirror($chksum_uri, $chk_file);
unless (-e $chk_file) {
$self->diag_fail("Fetching $chksum_uri failed.\n");
return;
}
$self->diag_ok;
$self->verify_checksums_signature($chk_file) or return;
$self->verify_checksum($file, $chk_file);
}
sub verify_checksum {
my($self, $file, $chk_file) = @_;
$self->chat("Verifying the SHA1 for $file\n");
open my $fh, "<$chk_file" or die "$chk_file: $!";
my $data = join '', <$fh>;
$data =~ s/\015?\012/\n/g;
require Safe; # no fatpack
my $chksum = Safe->new->reval($data);
if (!ref $chksum or ref $chksum ne 'HASH') {
$self->diag_fail("! Checksum file downloaded from $chk_file is broken.\n");
return;
}
if (my $sha = $chksum->{$file}{sha256}) {
my $hex = $self->sha1_for($file);
if ($hex eq $sha) {
$self->chat("Checksum for $file: Verified!\n");
} else {
$self->diag_fail("Checksum mismatch for $file\n");
return;
}
} else {
$self->chat("Checksum for $file not found in CHECKSUMS.\n");
return;
}
}
sub sha1_for {
my($self, $file) = @_;
require Digest::SHA; # no fatpack
open my $fh, "<", $file or die "$file: $!";
my $dg = Digest::SHA->new(256);
my($data);
while (read($fh, $data, 4096)) {
$dg->add($data);
}
return $dg->hexdigest;
}
sub verify_signature {
my($self, $dist) = @_;
$self->diag_progress("Verifying the SIGNATURE file");
my $out = `$self->{cpansign} -v --skip 2>&1`;
$self->log($out);
if ($out =~ /Signature verified OK/) {
$self->diag_ok("Verified OK");
return 1;
} else {
$self->diag_fail("SIGNATURE verificaion for $dist->{filename} failed\n");
return;
}
}
sub resolve_name {
my($self, $module, $version) = @_;
# URL
if ($module =~ /^(ftp|https?|file):/) {
if ($module =~ m!authors/id/(.*)!) {
return $self->cpan_dist($1, $module);
} else {
return { uris => [ $module ] };
}
}
# Directory
if ($module =~ m!^[\./]! && -d $module) {
return {
source => 'local',
dir => Cwd::abs_path($module),
};
}
# File
if (-f $module) {
return {
source => 'local',
uris => [ "file://" . Cwd::abs_path($module) ],
};
}
# Git
if ($module =~ /(?:^git:|\.git(?:@.+)?$)/) {
return $self->git_uri($module);
}
# cpan URI
if ($module =~ s!^cpan:///distfile/!!) {
return $self->cpan_dist($module);
}
# PAUSEID/foo
# P/PA/PAUSEID/foo
if ($module =~ m!^(?:[A-Z]/[A-Z]{2}/)?([A-Z]{2}[\-A-Z0-9]*/.*)$!) {
return $self->cpan_dist($1);
}
# Module name
return $self->search_module($module, $version);
}
sub cpan_module {
my($self, $module, $dist, $version) = @_;
my $dist = $self->cpan_dist($dist);
$dist->{module} = $module;
$dist->{module_version} = $version if $version && $version ne 'undef';
return $dist;
}
sub cpan_dist {
my($self, $dist, $url) = @_;
$dist =~ s!^([A-Z]{2})!substr($1,0,1)."/".substr($1,0,2)."/".$1!e;
require CPAN::DistnameInfo;
my $d = CPAN::DistnameInfo->new($dist);
if ($url) {
$url = [ $url ] unless ref $url eq 'ARRAY';
} else {
my $id = $d->cpanid;
my $fn = substr($id, 0, 1) . "/" . substr($id, 0, 2) . "/" . $id . "/" . $d->filename;
my @mirrors = @{$self->{mirrors}};
my @urls = map "$_/authors/id/$fn", @mirrors;
$url = \@urls,
}
return {
$d->properties,
source => 'cpan',
uris => $url,
};
}
sub git_uri {
my ($self, $uri) = @_;
# similar to http://www.pip-installer.org/en/latest/logic.html#vcs-support
# git URL has to end with .git when you need to use pin @ commit/tag/branch
($uri, my $commitish) = split /(?<=\.git)@/i, $uri, 2;
my $dir = File::Temp::tempdir(CLEANUP => 1);
$self->mask_output( diag_progress => "Cloning $uri" );
$self->run([ 'git', 'clone', $uri, $dir ]);
unless (-e "$dir/.git") {
$self->diag_fail("Failed cloning git repository $uri", 1);
return;
}
if ($commitish) {
require File::pushd;
my $dir = File::pushd::pushd($dir);
unless ($self->run([ 'git', 'checkout', $commitish ])) {
$self->diag_fail("Failed to checkout '$commitish' in git repository $uri\n");
return;
}
}
$self->diag_ok;
return {
source => 'local',
dir => $dir,
};
}
sub setup_module_build_patch {
my $self = shift;
open my $out, ">$self->{base}/ModuleBuildSkipMan.pm" or die $!;
print $out <<EOF;
package ModuleBuildSkipMan;
CHECK {
if (%Module::Build::) {
no warnings 'redefine';
*Module::Build::Base::ACTION_manpages = sub {};
*Module::Build::Base::ACTION_docs = sub {};
}
}
1;
EOF
}
sub core_version_for {
my($self, $module) = @_;
require Module::CoreList; # no fatpack
unless (exists $Module::CoreList::version{$]+0}) {
die sprintf("Module::CoreList %s (loaded from %s) doesn't seem to have entries for perl $]. " .
"You're strongly recommended to upgrade Module::CoreList from CPAN.\n",
$Module::CoreList::VERSION, $INC{"Module/CoreList.pm"});
}
unless (exists $Module::CoreList::version{$]+0}{$module}) {
return -1;
}
return $Module::CoreList::version{$]+0}{$module};
}
sub check_module {
my($self, $mod, $want_ver) = @_;
require Module::Metadata;
my $meta = Module::Metadata->new_from_module($mod, inc => $self->{search_inc})
or return 0, undef;
my $version = $meta->version;
# When -L is in use, the version loaded from 'perl' library path
# might be newer than (or actually wasn't core at) the version
# that is shipped with the current perl
if ($self->{self_contained} && $self->loaded_from_perl_lib($meta)) {
$version = $self->core_version_for($mod);
return 0, undef if $version && $version == -1;
}
$self->{local_versions}{$mod} = $version;
if ($self->is_deprecated($meta)){
return 0, $version;
} elsif ($self->satisfy_version($mod, $version, $want_ver)) {
return 1, ($version || 'undef');
} else {
return 0, $version;
}
}
sub satisfy_version {
my($self, $mod, $version, $want_ver) = @_;
$want_ver = '0' unless defined($want_ver) && length($want_ver);
require CPAN::Meta::Requirements;
my $requirements = CPAN::Meta::Requirements->new;
$requirements->add_string_requirement($mod, $want_ver);
$requirements->accepts_module($mod, $version);
}
sub unsatisfy_how {
my($self, $ver, $want_ver) = @_;
if ($want_ver =~ /^[v0-9\.\_]+$/) {
return "$ver < $want_ver";
} else {
return "$ver doesn't satisfy $want_ver";
}
}
sub is_deprecated {
my($self, $meta) = @_;
my $deprecated = eval {
require Module::CoreList; # no fatpack
Module::CoreList::is_deprecated($meta->{module});
};
return $deprecated && $self->loaded_from_perl_lib($meta);
}
sub loaded_from_perl_lib {
my($self, $meta) = @_;
require Config;
for my $dir (qw(archlibexp privlibexp)) {
my $confdir = $Config{$dir};
if ($confdir eq substr($meta->filename, 0, length($confdir))) {
return 1;
}
}
return;
}
sub should_install {
my($self, $mod, $ver) = @_;
$self->chat("Checking if you have $mod $ver ... ");
my($ok, $local) = $self->check_module($mod, $ver);
if ($ok) { $self->chat("Yes ($local)\n") }
elsif ($local) { $self->chat("No (" . $self->unsatisfy_how($local, $ver) . ")\n") }
else { $self->chat("No\n") }
return $mod unless $ok;
return;
}
sub check_perl_version {
my($self, $version) = @_;
require CPAN::Meta::Requirements;
my $req = CPAN::Meta::Requirements->from_string_hash({ perl => $version });
$req->accepts_module(perl => $]);
}
sub install_deps {
my($self, $dir, $depth, @deps) = @_;
my(@install, %seen, @fail);
for my $dep (@deps) {
next if $seen{$dep->module};
if ($dep->module eq 'perl') {
if ($dep->is_requirement && !$self->check_perl_version($dep->version)) {
$self->diag("Needs perl @{[$dep->version]}, you have $]\n");
push @fail, 'perl';
}
} elsif ($self->should_install($dep->module, $dep->version)) {
push @install, $dep;
$seen{$dep->module} = 1;
}
}
if (@install) {
$self->diag("==> Found dependencies: " . join(", ", map $_->module, @install) . "\n");
}
for my $dep (@install) {
$self->install_module($dep->module, $depth + 1, $dep->version);
}
$self->chdir($self->{base});
$self->chdir($dir) if $dir;
if ($self->{scandeps}) {
return 1; # Don't check if dependencies are installed, since with --scandeps they aren't
}
my @not_ok = $self->unsatisfied_deps(@deps);
if (@not_ok) {
return 0, \@not_ok;
} else {
return 1;
}
}
sub unsatisfied_deps {
my($self, @deps) = @_;
require CPAN::Meta::Check;
require CPAN::Meta::Requirements;
my $reqs = CPAN::Meta::Requirements->new;
for my $dep (grep $_->is_requirement, @deps) {
$reqs->add_string_requirement($dep->module => $dep->version || '0');
}
my $ret = CPAN::Meta::Check::check_requirements($reqs, 'requires', $self->{search_inc});
grep defined, values %$ret;
}
sub install_deps_bailout {
my($self, $target, $dir, $depth, @deps) = @_;
my($ok, $fail) = $self->install_deps($dir, $depth, @deps);
if (!$ok) {
$self->diag_fail("Installing the dependencies failed: " . join(", ", @$fail), 1);
unless ($self->prompt_bool("Do you want to continue building $target anyway?", "n")) {
$self->diag_fail("Bailing out the installation for $target.", 1);
return;
}
}
return 1;
}
sub build_stuff {
my($self, $stuff, $dist, $depth) = @_;
if ($self->{verify} && -e 'SIGNATURE') {
$self->verify_signature($dist) or return;
}
if (-e 'META.json') {
$self->chat("Checking configure dependencies from META.json\n");
$dist->{meta} = $self->parse_meta('META.json');
} elsif (-e 'META.yml') {
$self->chat("Checking configure dependencies from META.yml\n");
$dist->{meta} = $self->parse_meta('META.yml');
}
if (!$dist->{meta} && $dist->{source} eq 'cpan') {
$self->chat("META.yml/json not found or unparsable. Creating skelton for it.\n");
require CPAN::Meta;
$dist->{meta} = CPAN::Meta->new({ name => $dist->{dist}, version => $dist->{version} })->as_struct;
}
$dist->{meta} ||= {};
if ($dist->{meta}{'meta-spec'}) {
require CPAN::Meta;
$dist->{cpanmeta} = CPAN::Meta->new($dist->{meta}, { lazy_validation => 1 });
}
my @config_deps;
if ($dist->{cpanmeta}) {
push @config_deps, Dependency->from_prereqs(
$dist->{cpanmeta}->effective_prereqs, ['configure'], $self->{install_types},
);
} else {
push @config_deps, Dependency->from_versions(
$dist->{meta}{configure_requires} || {}, 'configure',
);
}
# workaround for bad M::B based dists with no configure_requires
# https://github.com/miyagawa/cpanminus/issues/273
if (-e 'Build.PL') {
push @config_deps, Dependency->from_versions(
{ 'Module::Build' => '0.36' }, 'configure',
);
}
my $target = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $dist->{dir};
$self->install_deps_bailout($target, $dist->{dir}, $depth, @config_deps)
or return;
$self->diag_progress("Configuring $target");
my $configure_state = $self->configure_this($dist, $depth);
$self->diag_ok($configure_state->{configured_ok} ? "OK" : "N/A");
$dist->{provides} = $self->extract_packages($dist->{cpanmeta}, ".")
if $dist->{cpanmeta} && -e 'MANIFEST';
# install direct 'test' dependencies for --installdeps, even with --notest
my $root_target = (($self->{installdeps} or $self->{showdeps}) and $depth == 0);
$dist->{want_phases} = $self->{notest} && !$root_target
? [qw( build runtime )] : [qw( build test runtime )];
push @{$dist->{want_phases}}, 'develop' if $self->{with_develop} && $depth == 0;
my @deps = $self->find_prereqs($dist);
my $module_name = $self->find_module_name($configure_state) || $dist->{meta}{name};
$module_name =~ s/-/::/g;
if ($self->{showdeps}) {
for my $dep (@config_deps, @deps) {
print $dep->module, ($dep->version ? ("~".$dep->version) : ""), "\n";
}
return 1;
}
my $distname = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $stuff;
my $walkup;
if ($self->{scandeps}) {
$walkup = $self->scandeps_append_child($dist);
}
$self->install_deps_bailout($distname, $dist->{dir}, $depth, @deps)
or return;
if ($self->{scandeps}) {
unless ($configure_state->{configured_ok}) {
my $diag = <<DIAG;
! Configuring $distname failed. See $self->{log} for details.
! You might have to install the following modules first to get --scandeps working correctly.
DIAG
if (@config_deps) {
my @tree = @{$self->{scandeps_tree}};
$diag .= "!\n" . join("", map "! * $_->[0]{module}\n", @tree[0..$#tree-1]) if @tree;
}
$self->diag("!\n$diag!\n", 1);
}
$walkup->();
return 1;
}
if ($self->{installdeps} && $depth == 0) {
if ($configure_state->{configured_ok}) {
$self->diag("<== Installed dependencies for $stuff. Finishing.\n");
return 1;
} else {
$self->diag("! Configuring $distname failed. See $self->{log} for details.\n", 1);
return;
}
}
my $installed;
if ($configure_state->{use_module_build} && -e 'Build' && -f _) {
$self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname);
$self->build([ $self->{perl}, "./Build" ], $distname, $depth) &&
$self->test([ $self->{perl}, "./Build", "test" ], $distname, $depth) &&
$self->install([ $self->{perl}, "./Build", "install" ], [ "--uninst", 1 ], $depth) &&
$installed++;
} elsif ($self->{make} && -e 'Makefile') {
$self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname);
$self->build([ $self->{make} ], $distname, $depth) &&
$self->test([ $self->{make}, "test" ], $distname, $depth) &&
$self->install([ $self->{make}, "install" ], [ "UNINST=1" ], $depth) &&
$installed++;
} else {
my $why;
my $configure_failed = $configure_state->{configured} && !$configure_state->{configured_ok};
if ($configure_failed) { $why = "Configure failed for $distname." }
elsif ($self->{make}) { $why = "The distribution doesn't have a proper Makefile.PL/Build.PL" }
else { $why = "Can't configure the distribution. You probably need to have 'make'." }
$self->diag_fail("$why See $self->{log} for details.", 1);
return;
}
if ($installed && $self->{test_only}) {
$self->diag_ok;
$self->diag("Successfully tested $distname\n", 1);
} elsif ($installed) {
my $local = $self->{local_versions}{$dist->{module} || ''};
my $version = $dist->{module_version} || $dist->{meta}{version} || $dist->{version};
my $reinstall = $local && ($local eq $version);
my $action = $local && !$reinstall
? $self->numify_ver($version) < $self->numify_ver($local)
? "downgraded"
: "upgraded"
: undef;
my $how = $reinstall ? "reinstalled $distname"
: $local ? "installed $distname ($action from $local)"
: "installed $distname" ;
my $msg = "Successfully $how";
$self->diag_ok;
$self->diag("$msg\n", 1);
$self->{installed_dists}++;
$self->save_meta($stuff, $dist, $module_name, \@config_deps, \@deps);
return 1;
} else {
my $what = $self->{test_only} ? "Testing" : "Installing";
$self->diag_fail("$what $stuff failed. See $self->{log} for details. Retry with --force to force install it.", 1);
return;
}
}
sub perl_requirements {
my($self, @requires) = @_;
my @perl;
for my $requires (grep defined, @requires) {
if (exists $requires->{perl}) {
push @perl, Dependency->new(perl => $requires->{perl});
}
}
return @perl;
}
sub configure_this {
my($self, $dist, $depth) = @_;
if (-e $self->{cpanfile_path} && $self->{installdeps} && $depth == 0) {
require Module::CPANfile;
$dist->{cpanfile} = eval { Module::CPANfile->load($self->{cpanfile_path}) };
$self->diag_fail($@, 1) if $@;
return {
configured => 1,
configured_ok => !!$dist->{cpanfile},
use_module_build => 0,
};
}
if ($self->{skip_configure}) {
my $eumm = -e 'Makefile';
my $mb = -e 'Build' && -f _;
return {
configured => 1,
configured_ok => $eumm || $mb,
use_module_build => $mb,
};
}
my $state = {};
my $try_eumm = sub {
if (-e 'Makefile.PL') {
$self->chat("Running Makefile.PL\n");
# NOTE: according to Devel::CheckLib, most XS modules exit
# with 0 even if header files are missing, to avoid receiving
# tons of FAIL reports in such cases. So exit code can't be
# trusted if it went well.
if ($self->configure([ $self->{perl}, "Makefile.PL" ], $depth)) {
$state->{configured_ok} = -e 'Makefile';
}
$state->{configured}++;
}
};
my $try_mb = sub {
if (-e 'Build.PL') {
$self->chat("Running Build.PL\n");
if ($self->configure([ $self->{perl}, "Build.PL" ], $depth)) {
$state->{configured_ok} = -e 'Build' && -f _;
}
$state->{use_module_build}++;
$state->{configured}++;
}
};
# Module::Build deps should use MakeMaker because that causes circular deps and fail
# Otherwise we should prefer Build.PL
my %should_use_mm = map { $_ => 1 } qw( version ExtUtils-ParseXS ExtUtils-Install ExtUtils-Manifest );
my @try;
if ($dist->{dist} && $should_use_mm{$dist->{dist}}) {
@try = ($try_eumm, $try_mb);
} else {
@try = ($try_mb, $try_eumm);
}
for my $try (@try) {
$try->();
last if $state->{configured_ok};
}
unless ($state->{configured_ok}) {
while (1) {
my $ans = lc $self->prompt("Configuring $dist->{dist} failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?", "s");
last if $ans eq 's';
return $self->configure_this($dist, $depth) if $ans eq 'r';
$self->show_build_log if $ans eq 'e';
$self->look if $ans eq 'l';
}
}
return $state;
}
sub find_module_name {
my($self, $state) = @_;
return unless $state->{configured_ok};
if ($state->{use_module_build} &&
-e "_build/build_params") {
my $params = do { open my $in, "_build/build_params"; $self->safe_eval(join "", <$in>) };
return eval { $params->[2]{module_name} } || undef;
} elsif (-e "Makefile") {
open my $mf, "Makefile";
while (<$mf>) {
if (/^\#\s+NAME\s+=>\s+(.*)/) {
return $self->safe_eval($1);
}
}
}
return;
}
sub extract_packages {
my($self, $meta, $dir) = @_;
my $try = sub {
my $file = shift;
return 1 unless $meta->{no_index};
return 0 if grep { $file =~ m!^$_/! } @{$meta->{no_index}{directory} || []};
return 0 if grep { $file eq $_ } @{$meta->{no_index}{file} || []};
return 1;
};
require ExtUtils::Manifest;
require App::cpanminus::ParsePM;
my $manifest = eval { ExtUtils::Manifest::manifind() } || {};
my @files = grep { /\.pm(?:\.PL)?$/ && $try->($_) } keys %$manifest;
my $provides = {};
for my $file (@files) {
my $parser = App::cpanminus::ParsePM->new($meta);
my $packages = $parser->parse($file);
while (my($package, $meta) = each %$packages) {
$provides->{$package} = {
file => $meta->{infile},
($meta->{version} eq 'undef') ? () : (version => $meta->{version}),
};
}
}
return $provides;
}
sub save_meta {
my($self, $module, $dist, $module_name, $config_deps, $build_deps) = @_;
return unless $dist->{distvname} && $dist->{source} eq 'cpan';
my $base = ($ENV{PERL_MM_OPT} || '') =~ /INSTALL_BASE=/
? ($self->install_base($ENV{PERL_MM_OPT}) . "/lib/perl5") : $Config{sitelibexp};
my $provides = $dist->{provides};
File::Path::mkpath("blib/meta", 0, 0777);
my $local = {
name => $module_name,
target => $module,
version => exists $provides->{$module_name}
? ($provides->{$module_name}{version} || $dist->{version}) : $dist->{version},
dist => $dist->{distvname},
pathname => $dist->{pathname},
provides => $provides,
};
require JSON::PP;
open my $fh, ">", "blib/meta/install.json" or die $!;
print $fh JSON::PP::encode_json($local);
# Existence of MYMETA.* Depends on EUMM/M::B versions and CPAN::Meta
if (-e "MYMETA.json") {
File::Copy::copy("MYMETA.json", "blib/meta/MYMETA.json");
}
my @cmd = (
($self->{sudo} ? 'sudo' : ()),
$^X,
'-MExtUtils::Install=install',
'-e',
qq[install({ 'blib/meta' => '$base/$Config{archname}/.meta/$dist->{distvname}' })],
);
$self->run(\@cmd);
}
sub _merge_hashref {
my($self, @hashrefs) = @_;
my %hash;
for my $h (@hashrefs) {
%hash = (%hash, %$h);
}
return \%hash;
}
sub install_base {
my($self, $mm_opt) = @_;
$mm_opt =~ /INSTALL_BASE=(\S+)/ and return $1;
die "Your PERL_MM_OPT doesn't contain INSTALL_BASE";
}
sub safe_eval {
my($self, $code) = @_;
eval $code;
}
sub configure_features {
my($self, $dist, @features) = @_;
map $_->identifier, grep { $self->effective_feature($dist, $_) } @features;
}
sub effective_feature {
my($self, $dist, $feature) = @_;
if ($dist->{depth} == 0) {
my $value = $self->{features}{$feature->identifier};
return $value if defined $value;
return 1 if $self->{features}{__all};
}
if ($self->{interactive}) {
require CPAN::Meta::Requirements;
$self->diag("[@{[ $feature->description ]}]\n", 1);
my $req = CPAN::Meta::Requirements->new;
for my $phase (@{$dist->{want_phases}}) {
for my $type (@{$self->{install_types}}) {
$req->add_requirements($feature->prereqs->requirements_for($phase, $type));
}
}
my $reqs = $req->as_string_hash;
my @missing;
for my $module (keys %$reqs) {
if ($self->should_install($module, $req->{$module})) {
push @missing, $module;
}
}
if (@missing) {
my $howmany = @missing;
$self->diag("==> Found missing dependencies: " . join(", ", @missing) . "\n", 1);
local $self->{prompt} = 1;
return $self->prompt_bool("Install the $howmany optional module(s)?", "y");
}
}
return;
}
sub find_prereqs {
my($self, $dist) = @_;
my @deps = $self->extract_meta_prereqs($dist);
if ($dist->{module} =~ /^Bundle::/i) {
push @deps, $self->bundle_deps($dist);
}
return @deps;
}
sub extract_meta_prereqs {
my($self, $dist) = @_;
if ($dist->{cpanfile}) {
my @features = $self->configure_features($dist, $dist->{cpanfile}->features);
my $prereqs = $dist->{cpanfile}->prereqs_with(@features);
return Dependency->from_prereqs($prereqs, $dist->{want_phases}, $self->{install_types});
}
my $meta = $dist->{meta};
my @deps;
if (-e "MYMETA.json") {
require JSON::PP;
$self->chat("Checking dependencies from MYMETA.json ...\n");
my $json = do { open my $in, "<MYMETA.json"; local $/; <$in> };
my $mymeta = JSON::PP::decode_json($json);
if ($mymeta) {
$meta->{$_} = $mymeta->{$_} for qw(name version);
return $self->extract_prereqs($mymeta, $dist);
}
}
if (-e 'MYMETA.yml') {
$self->chat("Checking dependencies from MYMETA.yml ...\n");
my $mymeta = $self->parse_meta('MYMETA.yml');
if ($mymeta) {
$meta->{$_} = $mymeta->{$_} for qw(name version);
return $self->extract_prereqs($mymeta, $dist);
}
}
if (-e '_build/prereqs') {
$self->chat("Checking dependencies from _build/prereqs ...\n");
my $prereqs = do { open my $in, "_build/prereqs"; $self->safe_eval(join "", <$in>) };
@deps = $self->extract_prereqs({ name => $meta->{name}, version => $meta->{version}, %$prereqs }, $dist);
} elsif (-e 'Makefile') {
$self->chat("Finding PREREQ from Makefile ...\n");
open my $mf, "Makefile";
while (<$mf>) {
if (/^\#\s+PREREQ_PM => \{\s*(.*?)\s*\}/) {
my @all;
my @pairs = split ', ', $1;
for (@pairs) {
my ($pkg, $v) = split '=>', $_;
push @all, [ $pkg, $v ];
}
my $list = join ", ", map { "'$_->[0]' => $_->[1]" } @all;
my $prereq = $self->safe_eval("no strict; +{ $list }");
push @deps, Dependency->from_versions($prereq) if $prereq;
last;
}
}
}
return @deps;
}
sub bundle_deps {
my($self, $dist) = @_;
my @files;
File::Find::find({
wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i },
no_chdir => 1,
}, '.');
my @deps;
for my $file (@files) {
open my $pod, "<", $file or next;
my $in_contents;
while (<$pod>) {
if (/^=head\d\s+CONTENTS/) {
$in_contents = 1;
} elsif (/^=/) {
$in_contents = 0;
} elsif ($in_contents) {
/^(\S+)\s*(\S+)?/
and push @deps, Dependency->new($1, $self->maybe_version($2));
}
}
}
return @deps;
}
sub maybe_version {
my($self, $string) = @_;
return $string && $string =~ /^\.?\d/ ? $string : undef;
}
sub extract_prereqs {
my($self, $metadata, $dist) = @_;
require CPAN::Meta;
my $meta = CPAN::Meta->new($metadata, { lazy_validation => 1 });
my @features = $self->configure_features($dist, $meta->features);
return Dependency->from_prereqs($meta->effective_prereqs(\@features), $dist->{want_phases}, $self->{install_types});
}
sub cleanup_workdirs {
my $self = shift;
my $expire = time - 24 * 60 * 60 * $self->{auto_cleanup};
my @targets;
opendir my $dh, "$self->{home}/work";
while (my $e = readdir $dh) {
next if $e !~ /^(\d+)\.\d+$/; # {UNIX time}.{PID}
my $time = $1;
if ($time < $expire) {
push @targets, "$self->{home}/work/$e";
}
}
if (@targets) {
if (@targets >= 64) {
$self->diag("Expiring " . scalar(@targets) . " work directories. This might take long...\n");
} else {
$self->chat("Expiring " . scalar(@targets) . " work directories.\n");
}
File::Path::rmtree(\@targets, 0, 0); # safe = 0, since blib usually doesn't have write bits
}
}
sub scandeps_append_child {
my($self, $dist) = @_;
my $new_node = [ $dist, [] ];
my $curr_node = $self->{scandeps_current} || [ undef, $self->{scandeps_tree} ];
push @{$curr_node->[1]}, $new_node;
$self->{scandeps_current} = $new_node;
return sub { $self->{scandeps_current} = $curr_node };
}
sub dump_scandeps {
my $self = shift;
if ($self->{format} eq 'tree') {
$self->walk_down(sub {
my($dist, $depth) = @_;
if ($depth == 0) {
print "$dist->{distvname}\n";
} else {
print " " x ($depth - 1);
print "\\_ $dist->{distvname}\n";
}
}, 1);
} elsif ($self->{format} =~ /^dists?$/) {
$self->walk_down(sub {
my($dist, $depth) = @_;
print $self->format_dist($dist), "\n";
}, 0);
} elsif ($self->{format} eq 'json') {
require JSON::PP;
print JSON::PP::encode_json($self->{scandeps_tree});
} elsif ($self->{format} eq 'yaml') {
require YAML; # no fatpack
print YAML::Dump($self->{scandeps_tree});
} else {
$self->diag("Unknown format: $self->{format}\n");
}
}
sub walk_down {
my($self, $cb, $pre) = @_;
$self->_do_walk_down($self->{scandeps_tree}, $cb, 0, $pre);
}
sub _do_walk_down {
my($self, $children, $cb, $depth, $pre) = @_;
# DFS - $pre determines when we call the callback
for my $node (@$children) {
$cb->($node->[0], $depth) if $pre;
$self->_do_walk_down($node->[1], $cb, $depth + 1, $pre);
$cb->($node->[0], $depth) unless $pre;
}
}
sub DESTROY {
my $self = shift;
$self->{at_exit}->($self) if $self->{at_exit};
}
# Utils
sub shell_quote {
my($self, @stuff) = @_;
if (WIN32) {
join ' ', map { /^${quote}.+${quote}$/ ? $_ : ($quote . $_ . $quote) } @stuff;
} else {
String::ShellQuote::shell_quote_best_effort(@stuff);
}
}
sub which {
my($self, $name) = @_;
return $name if File::Spec->file_name_is_absolute($name) && -x $name;
my $exe_ext = $Config{_exe};
for my $dir (File::Spec->path) {
my $fullpath = File::Spec->catfile($dir, $name);
if (-x $fullpath || -x ($fullpath .= $exe_ext)) {
if ($fullpath =~ /\s/) {
$fullpath = $self->shell_quote($fullpath);
}
return $fullpath;
}
}
return;
}
sub get {
my($self, $uri) = @_;
if ($uri =~ /^file:/) {
$self->file_get($uri);
} else {
$self->{_backends}{get}->(@_);
}
}
sub mirror {
my($self, $uri, $local) = @_;
if ($uri =~ /^file:/) {
$self->file_mirror($uri, $local);
} else {
$self->{_backends}{mirror}->(@_);
}
}
sub untar { $_[0]->{_backends}{untar}->(@_) };
sub unzip { $_[0]->{_backends}{unzip}->(@_) };
sub uri_to_file {
my($self, $uri) = @_;
# file:///path/to/file -> /path/to/file
# file://C:/path -> C:/path
if ($uri =~ s!file:/+!!) {
$uri = "/$uri" unless $uri =~ m![a-zA-Z]:!;
}
return $uri;
}
sub file_get {
my($self, $uri) = @_;
my $file = $self->uri_to_file($uri);
open my $fh, "<$file" or return;
join '', <$fh>;
}
sub file_mirror {
my($self, $uri, $path) = @_;
my $file = $self->uri_to_file($uri);
File::Copy::copy($file, $path);
}
sub has_working_lwp {
my($self, $mirrors) = @_;
my $https = grep /^https:/, @$mirrors;
eval {
require LWP::UserAgent; # no fatpack
LWP::UserAgent->VERSION(5.802);
require LWP::Protocol::https if $https; # no fatpack
1;
};
}
sub init_tools {
my $self = shift;
return if $self->{initialized}++;
if ($self->{make} = $self->which($Config{make})) {
$self->chat("You have make $self->{make}\n");
}
# use --no-lwp if they have a broken LWP, to upgrade LWP
if ($self->{try_lwp} && $self->has_working_lwp($self->{mirrors})) {
$self->chat("You have LWP $LWP::VERSION\n");
my $ua = sub {
LWP::UserAgent->new(
parse_head => 0,
env_proxy => 1,
agent => $self->agent,
timeout => 30,
@_,
);
};
$self->{_backends}{get} = sub {
my $self = shift;
my $res = $ua->()->request(HTTP::Request->new(GET => $_[0]));
return unless $res->is_success;
return $res->decoded_content;
};
$self->{_backends}{mirror} = sub {
my $self = shift;
my $res = $ua->()->mirror(@_);
die $res->content if $res->code == 501;
$res->code;
};
} elsif ($self->{try_wget} and my $wget = $self->which('wget')) {
$self->chat("You have $wget\n");
my @common = (
'--user-agent', $self->agent,
'--retry-connrefused',
($self->{verbose} ? () : ('-q')),
);
$self->{_backends}{get} = sub {
my($self, $uri) = @_;
$self->safeexec( my $fh, $wget, $uri, @common, '-O', '-' ) or die "wget $uri: $!";
local $/;
<$fh>;
};
$self->{_backends}{mirror} = sub {
my($self, $uri, $path) = @_;
$self->safeexec( my $fh, $wget, $uri, @common, '-O', $path ) or die "wget $uri: $!";
local $/;
<$fh>;
};
} elsif ($self->{try_curl} and my $curl = $self->which('curl')) {
$self->chat("You have $curl\n");
my @common = (
'--location',
'--user-agent', $self->agent,
($self->{verbose} ? () : '-s'),
);
$self->{_backends}{get} = sub {
my($self, $uri) = @_;
$self->safeexec( my $fh, $curl, @common, $uri ) or die "curl $uri: $!";
local $/;
<$fh>;
};
$self->{_backends}{mirror} = sub {
my($self, $uri, $path) = @_;
$self->safeexec( my $fh, $curl, @common, $uri, '-#', '-o', $path ) or die "curl $uri: $!";
local $/;
<$fh>;
};
} else {
require HTTP::Tiny;
$self->chat("Falling back to HTTP::Tiny $HTTP::Tiny::VERSION\n");
my %common = (
agent => $self->agent,
);
$self->{_backends}{get} = sub {
my $self = shift;
my $res = HTTP::Tiny->new(%common)->get($_[0]);
return unless $res->{success};
return $res->{content};
};
$self->{_backends}{mirror} = sub {
my $self = shift;
my $res = HTTP::Tiny->new(%common)->mirror(@_);
return $res->{status};
};
}
my $tar = $self->which('tar');
my $tar_ver;
my $maybe_bad_tar = sub { WIN32 || SUNOS || (($tar_ver = `$tar --version 2>/dev/null`) =~ /GNU.*1\.13/i) };
if ($tar && !$maybe_bad_tar->()) {
chomp $tar_ver;
$self->chat("You have $tar: $tar_ver\n");
$self->{_backends}{untar} = sub {
my($self, $tarfile) = @_;
my $xf = ($self->{verbose} ? 'v' : '')."xf";
my $ar = $tarfile =~ /bz2$/ ? 'j' : 'z';
my($root, @others) = `$tar ${ar}tf $tarfile`
or return undef;
FILE: {
chomp $root;
$root =~ s!^\./!!;
$root =~ s{^(.+?)/.*$}{$1};
if (!length($root)) {
# archive had ./ as the first entry, so try again
$root = shift(@others);
redo FILE if $root;
}
}
system "$tar $ar$xf $tarfile";
return $root if -d $root;
$self->diag_fail("Bad archive: $tarfile");
return undef;
}
} elsif ( $tar
and my $gzip = $self->which('gzip')
and my $bzip2 = $self->which('bzip2')) {
$self->chat("You have $tar, $gzip and $bzip2\n");
$self->{_backends}{untar} = sub {
my($self, $tarfile) = @_;
my $x = "x" . ($self->{verbose} ? 'v' : '') . "f -";
my $ar = $tarfile =~ /bz2$/ ? $bzip2 : $gzip;
my($root, @others) = `$ar -dc $tarfile | $tar tf -`
or return undef;
FILE: {
chomp $root;
$root =~ s!^\./!!;
$root =~ s{^(.+?)/.*$}{$1};
if (!length($root)) {
# archive had ./ as the first entry, so try again
$root = shift(@others);
redo FILE if $root;
}
}
system "$ar -dc $tarfile | $tar $x";
return $root if -d $root;
$self->diag_fail("Bad archive: $tarfile");
return undef;
}
} elsif (eval { require Archive::Tar }) { # uses too much memory!
$self->chat("Falling back to Archive::Tar $Archive::Tar::VERSION\n");
$self->{_backends}{untar} = sub {
my $self = shift;
my $t = Archive::Tar->new($_[0]);
my($root, @others) = $t->list_files;
FILE: {
$root =~ s!^\./!!;
$root =~ s{^(.+?)/.*$}{$1};
if (!length($root)) {
# archive had ./ as the first entry, so try again
$root = shift(@others);
redo FILE if $root;
}
}
$t->extract;
return -d $root ? $root : undef;
};
} else {
$self->{_backends}{untar} = sub {
die "Failed to extract $_[1] - You need to have tar or Archive::Tar installed.\n";
};
}
if (my $unzip = $self->which('unzip')) {
$self->chat("You have $unzip\n");
$self->{_backends}{unzip} = sub {
my($self, $zipfile) = @_;
my $opt = $self->{verbose} ? '' : '-q';
my(undef, $root, @others) = `$unzip -t $zipfile`
or return undef;
chomp $root;
$root =~ s{^\s+testing:\s+([^/]+)/.*?\s+OK$}{$1};
system "$unzip $opt $zipfile";
return $root if -d $root;
$self->diag_fail("Bad archive: [$root] $zipfile");
return undef;
}
} else {
$self->{_backends}{unzip} = sub {
eval { require Archive::Zip }
or die "Failed to extract $_[1] - You need to have unzip or Archive::Zip installed.\n";
my($self, $file) = @_;
my $zip = Archive::Zip->new();
my $status;
$status = $zip->read($file);
$self->diag_fail("Read of file[$file] failed")
if $status != Archive::Zip::AZ_OK();
my @members = $zip->members();
for my $member ( @members ) {
my $af = $member->fileName();
next if ($af =~ m!^(/|\.\./)!);
$status = $member->extractToFileNamed( $af );
$self->diag_fail("Extracting of file[$af] from zipfile[$file failed")
if $status != Archive::Zip::AZ_OK();
}
my ($root) = $zip->membersMatching( qr<^[^/]+/$> );
$root &&= $root->fileName;
return -d $root ? $root : undef;
};
}
}
sub safeexec {
my $self = shift;
my $rdr = $_[0] ||= Symbol::gensym();
if (WIN32) {
my $cmd = $self->shell_quote(@_[1..$#_]);
return open( $rdr, "$cmd |" );
}
if ( my $pid = open( $rdr, '-|' ) ) {
return $pid;
}
elsif ( defined $pid ) {
exec( @_[ 1 .. $#_ ] );
exit 1;
}
else {
return;
}
}
sub mask_uri_passwords {
my($self, @strings) = @_;
s{ (https?://) ([^:/]+) : [^@/]+ @ }{$1$2:*password*@}gx for @strings;
return @strings;
}
sub parse_meta {
my($self, $file) = @_;
return eval { Parse::CPAN::Meta->load_file($file) };
}
sub parse_meta_string {
my($self, $yaml) = @_;
return eval { Parse::CPAN::Meta->load_yaml_string($yaml) };
}
package App::cpanminus::CommandExit;
sub new {
bless { code => $_[1] }, $_[0];
}
sub code { $_[0]->{code} }
1;
APP_CPANMINUS_SCRIPT
$fatpacked{"CPAN/DistnameInfo.pm"} = <<'CPAN_DISTNAMEINFO';
package CPAN::DistnameInfo;
$VERSION = "0.12";
use strict;
sub distname_info {
my $file = shift or return;
my ($dist, $version) = $file =~ /^
((?:[-+.]*(?:[A-Za-z0-9]+|(?<=\D)_|_(?=\D))*
(?:
[A-Za-z](?=[^A-Za-z]|$)
|
\d(?=-)
)(?<![._-][vV])
)+)(.*)
$/xs or return ($file,undef,undef);
if ($dist =~ /-undef\z/ and ! length $version) {
$dist =~ s/-undef\z//;
}
# Remove potential -withoutworldwriteables suffix
$version =~ s/-withoutworldwriteables$//;
if ($version =~ /^(-[Vv].*)-(\d.*)/) {
# Catch names like Unicode-Collate-Standard-V3_1_1-0.1
# where the V3_1_1 is part of the distname
$dist .= $1;
$version = $2;
}
if ($version =~ /(.+_.*)-(\d.*)/) {
# Catch names like Task-Deprecations5_14-1.00.tar.gz where the 5_14 is
# part of the distname. However, names like libao-perl_0.03-1.tar.gz
# should still have 0.03-1 as their version.
$dist .= $1;
$version = $2;
}
# Normalize the Dist.pm-1.23 convention which CGI.pm and
# a few others use.
$dist =~ s{\.pm$}{};
$version = $1
if !length $version and $dist =~ s/-(\d+\w)$//;
$version = $1 . $version
if $version =~ /^\d+$/ and $dist =~ s/-(\w+)$//;
if ($version =~ /\d\.\d/) {
$version =~ s/^[-_.]+//;
}
else {
$version =~ s/^[-_]+//;
}
my $dev;
if (length $version) {
if ($file =~ /^perl-?\d+\.(\d+)(?:\D(\d+))?(-(?:TRIAL|RC)\d+)?$/) {
$dev = 1 if (($1 > 6 and $1 & 1) or ($2 and $2 >= 50)) or $3;
}
elsif ($version =~ /\d\D\d+_\d/ or $version =~ /-TRIAL/) {
$dev = 1;
}
}
else {
$version = undef;
}
($dist, $version, $dev);
}
sub new {
my $class = shift;
my $distfile = shift;
$distfile =~ s,//+,/,g;
my %info = ( pathname => $distfile );
($info{filename} = $distfile) =~ s,^(((.*?/)?authors/)?id/)?([A-Z])/(\4[A-Z])/(\5[-A-Z0-9]*)/,,
and $info{cpanid} = $6;
if ($distfile =~ m,([^/]+)\.(tar\.(?:g?z|bz2)|zip|tgz)$,i) { # support more ?
$info{distvname} = $1;
$info{extension} = $2;
}
@info{qw(dist version beta)} = distname_info($info{distvname});
$info{maturity} = delete $info{beta} ? 'developer' : 'released';
return bless \%info, $class;
}
sub dist { shift->{dist} }
sub version { shift->{version} }
sub maturity { shift->{maturity} }
sub filename { shift->{filename} }
sub cpanid { shift->{cpanid} }
sub distvname { shift->{distvname} }
sub extension { shift->{extension} }
sub pathname { shift->{pathname} }
sub properties { %{ $_[0] } }
1;
__END__
=head1 NAME
CPAN::DistnameInfo - Extract distribution name and version from a distribution filename
=head1 SYNOPSIS
my $pathname = "authors/id/G/GB/GBARR/CPAN-DistnameInfo-0.02.tar.gz";
my $d = CPAN::DistnameInfo->new($pathname);
my $dist = $d->dist; # "CPAN-DistnameInfo"
my $version = $d->version; # "0.02"
my $maturity = $d->maturity; # "released"
my $filename = $d->filename; # "CPAN-DistnameInfo-0.02.tar.gz"
my $cpanid = $d->cpanid; # "GBARR"
my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
my $extension = $d->extension; # "tar.gz"
my $pathname = $d->pathname; # "authors/id/G/GB/GBARR/..."
my %prop = $d->properties;
=head1 DESCRIPTION
Many online services that are centered around CPAN attempt to
associate multiple uploads by extracting a distribution name from
the filename of the upload. For most distributions this is easy as
they have used ExtUtils::MakeMaker or Module::Build to create the
distribution, which results in a uniform name. But sadly not all
uploads are created in this way.
C<CPAN::DistnameInfo> uses heuristics that have been learnt by
L<http://search.cpan.org/> to extract the distribution name and
version from filenames and also report if the version is to be
treated as a developer release
The constructor takes a single pathname, returning an object with the following methods
=over
=item cpanid
If the path given looked like a CPAN authors directory path, then this will be the
the CPAN id of the author.
=item dist
The name of the distribution
=item distvname
The file name with any suffix and leading directory names removed
=item filename
If the path given looked like a CPAN authors directory path, then this will be the
path to the file relative to the detected CPAN author directory. Otherwise it is the path
that was passed in.
=item maturity
The maturity of the distribution. This will be either C<released> or C<developer>
=item extension
The extension of the distribution, often used to denote the archive type (e.g. 'tar.gz')
=item pathname
The pathname that was passed to the constructor when creating the object.
=item properties
This will return a list of key-value pairs, suitable for assigning to a hash,
for the known properties.
=item version
The extracted version
=back
=head1 AUTHOR
Graham Barr <gbarr@pobox.com>
=head1 COPYRIGHT
Copyright (c) 2003 Graham Barr. All rights reserved. This program is
free software; you can redistribute it and/or modify it under the same
terms as Perl itself.
=cut
CPAN_DISTNAMEINFO
$fatpacked{"CPAN/Meta.pm"} = <<'CPAN_META';
use 5.006;
use strict;
use warnings;
package CPAN::Meta;
our $VERSION = '2.131560'; # VERSION
use Carp qw(carp croak);
use CPAN::Meta::Feature;
use CPAN::Meta::Prereqs;
use CPAN::Meta::Converter;
use CPAN::Meta::Validator;
use Parse::CPAN::Meta 1.4403 ();
BEGIN { *_dclone = \&CPAN::Meta::Converter::_dclone }
BEGIN {
my @STRING_READERS = qw(
abstract
description
dynamic_config
generated_by
name
release_status
version
);
no strict 'refs';
for my $attr (@STRING_READERS) {
*$attr = sub { $_[0]{ $attr } };
}
}
BEGIN {
my @LIST_READERS = qw(
author
keywords
license
);
no strict 'refs';
for my $attr (@LIST_READERS) {
*$attr = sub {
my $value = $_[0]{ $attr };
croak "$attr must be called in list context"
unless wantarray;
return @{ _dclone($value) } if ref $value;
return $value;
};
}
}
sub authors { $_[0]->author }
sub licenses { $_[0]->license }
BEGIN {
my @MAP_READERS = qw(
meta-spec
resources
provides
no_index
prereqs
optional_features
);
no strict 'refs';
for my $attr (@MAP_READERS) {
(my $subname = $attr) =~ s/-/_/;
*$subname = sub {
my $value = $_[0]{ $attr };
return _dclone($value) if $value;
return {};
};
}
}
sub custom_keys {
return grep { /^x_/i } keys %{$_[0]};
}
sub custom {
my ($self, $attr) = @_;
my $value = $self->{$attr};
return _dclone($value) if ref $value;
return $value;
}
sub _new {
my ($class, $struct, $options) = @_;
my $self;
if ( $options->{lazy_validation} ) {
# try to convert to a valid structure; if succeeds, then return it
my $cmc = CPAN::Meta::Converter->new( $struct );
$self = $cmc->convert( version => 2 ); # valid or dies
return bless $self, $class;
}
else {
# validate original struct
my $cmv = CPAN::Meta::Validator->new( $struct );
unless ( $cmv->is_valid) {
die "Invalid metadata structure. Errors: "
. join(", ", $cmv->errors) . "\n";
}
}
# up-convert older spec versions
my $version = $struct->{'meta-spec'}{version} || '1.0';
if ( $version == 2 ) {
$self = $struct;
}
else {
my $cmc = CPAN::Meta::Converter->new( $struct );
$self = $cmc->convert( version => 2 );
}
return bless $self, $class;
}
sub new {
my ($class, $struct, $options) = @_;
my $self = eval { $class->_new($struct, $options) };
croak($@) if $@;
return $self;
}
sub create {
my ($class, $struct, $options) = @_;
my $version = __PACKAGE__->VERSION || 2;
$struct->{generated_by} ||= __PACKAGE__ . " version $version" ;
$struct->{'meta-spec'}{version} ||= int($version);
my $self = eval { $class->_new($struct, $options) };
croak ($@) if $@;
return $self;
}
sub load_file {
my ($class, $file, $options) = @_;
$options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
croak "load_file() requires a valid, readable filename"
unless -r $file;
my $self;
eval {
my $struct = Parse::CPAN::Meta->load_file( $file );
$self = $class->_new($struct, $options);
};
croak($@) if $@;
return $self;
}
sub load_yaml_string {
my ($class, $yaml, $options) = @_;
$options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
my $self;
eval {
my ($struct) = Parse::CPAN::Meta->load_yaml_string( $yaml );
$self = $class->_new($struct, $options);
};
croak($@) if $@;
return $self;
}
sub load_json_string {
my ($class, $json, $options) = @_;
$options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
my $self;
eval {
my $struct = Parse::CPAN::Meta->load_json_string( $json );
$self = $class->_new($struct, $options);
};
croak($@) if $@;
return $self;
}
sub save {
my ($self, $file, $options) = @_;
my $version = $options->{version} || '2';
my $layer = $] ge '5.008001' ? ':utf8' : '';
if ( $version ge '2' ) {
carp "'$file' should end in '.json'"
unless $file =~ m{\.json$};
}
else {
carp "'$file' should end in '.yml'"
unless $file =~ m{\.yml$};
}
my $data = $self->as_string( $options );
open my $fh, ">$layer", $file
or die "Error opening '$file' for writing: $!\n";
print {$fh} $data;
close $fh
or die "Error closing '$file': $!\n";
return 1;
}
sub meta_spec_version {
my ($self) = @_;
return $self->meta_spec->{version};
}
sub effective_prereqs {
my ($self, $features) = @_;
$features ||= [];
my $prereq = CPAN::Meta::Prereqs->new($self->prereqs);
return $prereq unless @$features;
my @other = map {; $self->feature($_)->prereqs } @$features;
return $prereq->with_merged_prereqs(\@other);
}
sub should_index_file {
my ($self, $filename) = @_;
for my $no_index_file (@{ $self->no_index->{file} || [] }) {
return if $filename eq $no_index_file;
}
for my $no_index_dir (@{ $self->no_index->{directory} }) {
$no_index_dir =~ s{$}{/} unless $no_index_dir =~ m{/\z};
return if index($filename, $no_index_dir) == 0;
}
return 1;
}
sub should_index_package {
my ($self, $package) = @_;
for my $no_index_pkg (@{ $self->no_index->{package} || [] }) {
return if $package eq $no_index_pkg;
}
for my $no_index_ns (@{ $self->no_index->{namespace} }) {
return if index($package, "${no_index_ns}::") == 0;
}
return 1;
}
sub features {
my ($self) = @_;
my $opt_f = $self->optional_features;
my @features = map {; CPAN::Meta::Feature->new($_ => $opt_f->{ $_ }) }
keys %$opt_f;
return @features;
}
sub feature {
my ($self, $ident) = @_;
croak "no feature named $ident"
unless my $f = $self->optional_features->{ $ident };
return CPAN::Meta::Feature->new($ident, $f);
}
sub as_struct {
my ($self, $options) = @_;
my $struct = _dclone($self);
if ( $options->{version} ) {
my $cmc = CPAN::Meta::Converter->new( $struct );
$struct = $cmc->convert( version => $options->{version} );
}
return $struct;
}
sub as_string {
my ($self, $options) = @_;
my $version = $options->{version} || '2';
my $struct;
if ( $self->meta_spec_version ne $version ) {
my $cmc = CPAN::Meta::Converter->new( $self->as_struct );
$struct = $cmc->convert( version => $version );
}
else {
$struct = $self->as_struct;
}
my ($data, $backend);
if ( $version ge '2' ) {
$backend = Parse::CPAN::Meta->json_backend();
$data = $backend->new->pretty->canonical->encode($struct);
}
else {
$backend = Parse::CPAN::Meta->yaml_backend();
$data = eval { no strict 'refs'; &{"$backend\::Dump"}($struct) };
if ( $@ ) {
croak $backend->can('errstr') ? $backend->errstr : $@
}
}
return $data;
}
# Used by JSON::PP, etc. for "convert_blessed"
sub TO_JSON {
return { %{ $_[0] } };
}
1;
# ABSTRACT: the distribution metadata for a CPAN dist
__END__
=pod
=encoding utf-8
=head1 NAME
CPAN::Meta - the distribution metadata for a CPAN dist
=head1 VERSION
version 2.131560
=head1 SYNOPSIS
use v5.10;
use strict;
use warnings;
use CPAN::Meta;
use Module::Load;
my $meta = CPAN::Meta->load_file('META.json');
printf "testing requirements for %s version %s\n",
$meta->name,
$meta->version;
my $prereqs = $meta->effective_prereqs;
for my $phase ( qw/configure runtime build test/ ) {
say "Requirements for $phase:";
my $reqs = $prereqs->requirements_for($phase, "requires");
for my $module ( sort $reqs->required_modules ) {
my $status;
if ( eval { load $module unless $module eq 'perl'; 1 } ) {
my $version = $module eq 'perl' ? $] : $module->VERSION;
$status = $reqs->accepts_module($module, $version)
? "$version ok" : "$version not ok";
} else {
$status = "missing"
};
say " $module ($status)";
}
}
=head1 DESCRIPTION
Software distributions released to the CPAN include a F<META.json> or, for
older distributions, F<META.yml>, which describes the distribution, its
contents, and the requirements for building and installing the distribution.
The data structure stored in the F<META.json> file is described in
L<CPAN::Meta::Spec>.
CPAN::Meta provides a simple class to represent this distribution metadata (or
I<distmeta>), along with some helpful methods for interrogating that data.
The documentation below is only for the methods of the CPAN::Meta object. For
information on the meaning of individual fields, consult the spec.
=head1 METHODS
=head2 new
my $meta = CPAN::Meta->new($distmeta_struct, \%options);
Returns a valid CPAN::Meta object or dies if the supplied metadata hash
reference fails to validate. Older-format metadata will be up-converted to
version 2 if they validate against the original stated specification.
It takes an optional hashref of options. Valid options include:
=over
=item *
lazy_validation -- if true, new will attempt to convert the given metadata
to version 2 before attempting to validate it. This means than any
fixable errors will be handled by CPAN::Meta::Converter before validation.
(Note that this might result in invalid optional data being silently
dropped.) The default is false.
=back
=head2 create
my $meta = CPAN::Meta->create($distmeta_struct, \%options);
This is same as C<new()>, except that C<generated_by> and C<meta-spec> fields
will be generated if not provided. This means the metadata structure is
assumed to otherwise follow the latest L<CPAN::Meta::Spec>.
=head2 load_file
my $meta = CPAN::Meta->load_file($distmeta_file, \%options);
Given a pathname to a file containing metadata, this deserializes the file
according to its file suffix and constructs a new C<CPAN::Meta> object, just
like C<new()>. It will die if the deserialized version fails to validate
against its stated specification version.
It takes the same options as C<new()> but C<lazy_validation> defaults to
true.
=head2 load_yaml_string
my $meta = CPAN::Meta->load_yaml_string($yaml, \%options);
This method returns a new CPAN::Meta object using the first document in the
given YAML string. In other respects it is identical to C<load_file()>.
=head2 load_json_string
my $meta = CPAN::Meta->load_json_string($json, \%options);
This method returns a new CPAN::Meta object using the structure represented by
the given JSON string. In other respects it is identical to C<load_file()>.
=head2 save
$meta->save($distmeta_file, \%options);
Serializes the object as JSON and writes it to the given file. The only valid
option is C<version>, which defaults to '2'. On Perl 5.8.1 or later, the file
is saved with UTF-8 encoding.
For C<version> 2 (or higher), the filename should end in '.json'. L<JSON::PP>
is the default JSON backend. Using another JSON backend requires L<JSON> 2.5 or
later and you must set the C<$ENV{PERL_JSON_BACKEND}> to a supported alternate
backend like L<JSON::XS>.
For C<version> less than 2, the filename should end in '.yml'.
L<CPAN::Meta::Converter> is used to generate an older metadata structure, which
is serialized to YAML. CPAN::Meta::YAML is the default YAML backend. You may
set the C<$ENV{PERL_YAML_BACKEND}> to a supported alternative backend, though
this is not recommended due to subtle incompatibilities between YAML parsers on
CPAN.
=head2 meta_spec_version
This method returns the version part of the C<meta_spec> entry in the distmeta
structure. It is equivalent to:
$meta->meta_spec->{version};
=head2 effective_prereqs
my $prereqs = $meta->effective_prereqs;
my $prereqs = $meta->effective_prereqs( \@feature_identifiers );
This method returns a L<CPAN::Meta::Prereqs> object describing all the
prereqs for the distribution. If an arrayref of feature identifiers is given,
the prereqs for the identified features are merged together with the
distribution's core prereqs before the CPAN::Meta::Prereqs object is returned.
=head2 should_index_file
... if $meta->should_index_file( $filename );
This method returns true if the given file should be indexed. It decides this
by checking the C<file> and C<directory> keys in the C<no_index> property of
the distmeta structure.
C<$filename> should be given in unix format.
=head2 should_index_package
... if $meta->should_index_package( $package );
This method returns true if the given package should be indexed. It decides
this by checking the C<package> and C<namespace> keys in the C<no_index>
property of the distmeta structure.
=head2 features
my @feature_objects = $meta->features;
This method returns a list of L<CPAN::Meta::Feature> objects, one for each
optional feature described by the distribution's metadata.
=head2 feature
my $feature_object = $meta->feature( $identifier );
This method returns a L<CPAN::Meta::Feature> object for the optional feature
with the given identifier. If no feature with that identifier exists, an
exception will be raised.
=head2 as_struct
my $copy = $meta->as_struct( \%options );
This method returns a deep copy of the object's metadata as an unblessed has
reference. It takes an optional hashref of options. If the hashref contains
a C<version> argument, the copied metadata will be converted to the version
of the specification and returned. For example:
my $old_spec = $meta->as_struct( {version => "1.4"} );
=head2 as_string
my $string = $meta->as_string( \%options );
This method returns a serialized copy of the object's metadata as a character
string. (The strings are B<not> UTF-8 encoded.) It takes an optional hashref
of options. If the hashref contains a C<version> argument, the copied metadata
will be converted to the version of the specification and returned. For
example:
my $string = $meta->as_struct( {version => "1.4"} );
For C<version> greater than or equal to 2, the string will be serialized as
JSON. For C<version> less than 2, the string will be serialized as YAML. In
both cases, the same rules are followed as in the C<save()> method for choosing
a serialization backend.
=head1 STRING DATA
The following methods return a single value, which is the value for the
corresponding entry in the distmeta structure. Values should be either undef
or strings.
=over 4
=item *
abstract
=item *
description
=item *
dynamic_config
=item *
generated_by
=item *
name
=item *
release_status
=item *
version
=back
=head1 LIST DATA
These methods return lists of string values, which might be represented in the
distmeta structure as arrayrefs or scalars:
=over 4
=item *
authors
=item *
keywords
=item *
licenses
=back
The C<authors> and C<licenses> methods may also be called as C<author> and
C<license>, respectively, to match the field name in the distmeta structure.
=head1 MAP DATA
These readers return hashrefs of arbitrary unblessed data structures, each
described more fully in the specification:
=over 4
=item *
meta_spec
=item *
resources
=item *
provides
=item *
no_index
=item *
prereqs
=item *
optional_features
=back
=head1 CUSTOM DATA
A list of custom keys are available from the C<custom_keys> method and
particular keys may be retrieved with the C<custom> method.
say $meta->custom($_) for $meta->custom_keys;
If a custom key refers to a data structure, a deep clone is returned.
=for Pod::Coverage TO_JSON abstract author authors custom custom_keys description dynamic_config
generated_by keywords license licenses meta_spec name no_index
optional_features prereqs provides release_status resources version
=head1 BUGS
Please report any bugs or feature using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.
=head1 SEE ALSO
=over 4
=item *
L<CPAN::Meta::Converter>
=item *
L<CPAN::Meta::Validator>
=back
=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
=head1 SUPPORT
=head2 Bugs / Feature Requests
Please report any bugs or feature requests through the issue tracker
at L<http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta>.
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<http://github.com/dagolden/cpan-meta>
git clone git://github.com/dagolden/cpan-meta.git
=head1 AUTHORS
=over 4
=item *
David Golden <dagolden@cpan.org>
=item *
Ricardo Signes <rjbs@cpan.org>
=back
=head1 CONTRIBUTORS
=over 4
=item *
Ansgar Burchardt <ansgar@cpan.org>
=item *
Avar Arnfjord Bjarmason <avar@cpan.org>
=item *
Christopher J. Madsen <cjm@cpan.org>
=item *
Cory G Watson <gphat@cpan.org>
=item *
Damyan Ivanov <dam@cpan.org>
=item *
Eric Wilhelm <ewilhelm@cpan.org>
=item *
Gregor Hermann <gregoa@debian.org>
=item *
Ken Williams <kwilliams@cpan.org>
=item *
Kenichi Ishigaki <ishigaki@cpan.org>
=item *
Lars Dieckow <daxim@cpan.org>
=item *
Leon Timmermans <leont@cpan.org>
=item *
Mark Fowler <markf@cpan.org>
=item *
Michael G. Schwern <mschwern@cpan.org>
=item *
Randy Sims <randys@thepierianspring.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
CPAN_META
$fatpacked{"CPAN/Meta/Check.pm"} = <<'CPAN_META_CHECK';
package CPAN::Meta::Check;
{
$CPAN::Meta::Check::VERSION = '0.005';
}
use strict;
use warnings;
use Exporter 5.57 'import';
our @EXPORT = qw//;
our @EXPORT_OK = qw/check_requirements requirements_for verify_dependencies/;
our %EXPORT_TAGS = (all => [ @EXPORT, @EXPORT_OK ] );
use CPAN::Meta::Requirements 2.120920;
use Module::Metadata;
sub _check_dep {
my ($reqs, $module, $dirs) = @_;
my $version = $module eq 'perl' ? $] : do {
my $metadata = Module::Metadata->new_from_module($module, inc => $dirs);
return "Module '$module' is not installed" if not defined $metadata;
eval { $metadata->version };
};
return "Missing version info for module '$module'" if $reqs->requirements_for_module($module) and not $version;
return sprintf 'Installed version (%s) of %s is not in range \'%s\'', $version, $module, $reqs->requirements_for_module($module) if not $reqs->accepts_module($module, $version || 0);
return;
}
sub _check_conflict {
my ($reqs, $module, $dirs) = @_;
my $metadata = Module::Metadata->new_from_module($module, inc => $dirs);
return if not defined $metadata;
my $version = eval { $metadata->version };
return "Missing version info for module '$module'" if not $version;
return sprintf 'Installed version (%s) of %s is in range \'%s\'', $version, $module, $$reqs->requirements_for_module($module) if $reqs->accepts_module($module, $version);
return;
}
sub requirements_for {
my ($meta, $phases, $type) = @_;
my $prereqs = ref($meta) eq 'CPAN::Meta' ? $meta->effective_prereqs : $meta;
if (!ref $phases) {
return $prereqs->requirements_for($phases, $type);
}
else {
my $ret = CPAN::Meta::Requirements->new;
for my $phase (@{ $phases }) {
$ret->add_requirements($prereqs->requirements_for($phase, $type));
}
return $ret;
}
}
sub check_requirements {
my ($reqs, $type, $dirs) = @_;
my %ret;
if ($type ne 'conflicts') {
for my $module ($reqs->required_modules) {
$ret{$module} = _check_dep($reqs, $module, $dirs);
}
}
else {
for my $module ($reqs->required_modules) {
$ret{$module} = _check_conflict($reqs, $module, $dirs);
}
}
return \%ret;
}
sub verify_dependencies {
my ($meta, $phases, $type, $dirs) = @_;
my $reqs = requirements_for($meta, $phases, $type);
my $issues = check_requirements($reqs, $type, $dirs);
return grep { defined } values %{ $issues };
}
1;
#ABSTRACT: Verify requirements in a CPAN::Meta object
=pod
=head1 NAME
CPAN::Meta::Check - Verify requirements in a CPAN::Meta object
=head1 VERSION
version 0.005
=head1 SYNOPSIS
warn "$_\n" for verify_requirements($meta, [qw/runtime build test/], 'requires');
=head1 DESCRIPTION
This module verifies if requirements described in a CPAN::Meta object are present.
=head1 FUNCTIONS
=head2 check_requirements($reqs, $type)
This function checks if all dependencies in C<$reqs> (a L<CPAN::Meta::Requirements|CPAN::Meta::Requirements> object) are met, taking into account that 'conflicts' dependencies have to be checked in reverse. It returns a hash with the modules as values and any problems as keys, the value for a succesfully found module will be undef.
=head2 verify_dependencies($meta, $phases, $types, $incdirs)
Check all requirements in C<$meta> for phases C<$phases> and types C<$types>. Modules are searched for in C<@$incdirs>, defaulting to C<@INC>.
=head2 requirements_for($meta, $phases, $types, incdirs)
This function returns a unified L<CPAN::Meta::Requirements|CPAN::Meta::Requirements> object for all C<$type> requirements for C<$phases>. $phases may be either one (scalar) value or an arrayref of valid values as defined by the L<CPAN::Meta spec|CPAN::Meta::Spec>. C<$type> must be a a relationship as defined by the same spec. Modules are searched for in C<@$incdirs>, defaulting to C<@INC>.
=head1 SEE ALSO
=over 4
=item * L<Test::CheckDeps|Test::CheckDeps>
=item * L<CPAN::Meta|CPAN::Meta>
=back
=head1 AUTHOR
Leon Timmermans <leont@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2012 by Leon Timmermans.
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__
CPAN_META_CHECK
$fatpacked{"CPAN/Meta/Converter.pm"} = <<'CPAN_META_CONVERTER';
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Converter;
our $VERSION = '2.131560'; # VERSION
use CPAN::Meta::Validator;
use CPAN::Meta::Requirements;
use version 0.88 ();
use Parse::CPAN::Meta 1.4400 ();
sub _dclone {
my $ref = shift;
# if an object is in the data structure and doesn't specify how to
# turn itself into JSON, we just stringify the object. That does the
# right thing for typical things that might be there, like version objects,
# Path::Class objects, etc.
no warnings 'once';
local *UNIVERSAL::TO_JSON = sub { return "$_[0]" };
my $backend = Parse::CPAN::Meta->json_backend();
return $backend->new->utf8->decode(
$backend->new->utf8->allow_blessed->convert_blessed->encode($ref)
);
}
my %known_specs = (
'2' => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
'1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
'1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html',
'1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
'1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html',
'1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html'
);
my @spec_list = sort { $a <=> $b } keys %known_specs;
my ($LOWEST, $HIGHEST) = @spec_list[0,-1];
#--------------------------------------------------------------------------#
# converters
#
# called as $converter->($element, $field_name, $full_meta, $to_version)
#
# defined return value used for field
# undef return value means field is skipped
#--------------------------------------------------------------------------#
sub _keep { $_[0] }
sub _keep_or_one { defined($_[0]) ? $_[0] : 1 }
sub _keep_or_zero { defined($_[0]) ? $_[0] : 0 }
sub _keep_or_unknown { defined($_[0]) && length($_[0]) ? $_[0] : "unknown" }
sub _generated_by {
my $gen = shift;
my $sig = __PACKAGE__ . " version " . (__PACKAGE__->VERSION || "<dev>");
return $sig unless defined $gen and length $gen;
return $gen if $gen =~ /(, )\Q$sig/;
return "$gen, $sig";
}
sub _listify { ! defined $_[0] ? undef : ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]] }
sub _prefix_custom {
my $key = shift;
$key =~ s/^(?!x_) # Unless it already starts with x_
(?:x-?)? # Remove leading x- or x (if present)
/x_/ix; # and prepend x_
return $key;
}
sub _ucfirst_custom {
my $key = shift;
$key = ucfirst $key unless $key =~ /[A-Z]/;
return $key;
}
sub _no_prefix_ucfirst_custom {
my $key = shift;
$key =~ s/^x_//;
return _ucfirst_custom($key);
}
sub _change_meta_spec {
my ($element, undef, undef, $version) = @_;
$element->{version} = $version;
$element->{url} = $known_specs{$version};
return $element;
}
my @valid_licenses_1 = (
'perl',
'gpl',
'apache',
'artistic',
'artistic_2',
'lgpl',
'bsd',
'gpl',
'mit',
'mozilla',
'open_source',
'unrestricted',
'restrictive',
'unknown',
);
my %license_map_1 = (
( map { $_ => $_ } @valid_licenses_1 ),
artistic2 => 'artistic_2',
);
sub _license_1 {
my ($element) = @_;
return 'unknown' unless defined $element;
if ( $license_map_1{lc $element} ) {
return $license_map_1{lc $element};
}
return 'unknown';
}
my @valid_licenses_2 = qw(
agpl_3
apache_1_1
apache_2_0
artistic_1
artistic_2
bsd
freebsd
gfdl_1_2
gfdl_1_3
gpl_1
gpl_2
gpl_3
lgpl_2_1
lgpl_3_0
mit
mozilla_1_0
mozilla_1_1
openssl
perl_5
qpl_1_0
ssleay
sun
zlib
open_source
restricted
unrestricted
unknown
);
# The "old" values were defined by Module::Build, and were often vague. I have
# made the decisions below based on reading Module::Build::API and how clearly
# it specifies the version of the license.
my %license_map_2 = (
(map { $_ => $_ } @valid_licenses_2),
apache => 'apache_2_0', # clearly stated as 2.0
artistic => 'artistic_1', # clearly stated as 1
artistic2 => 'artistic_2', # clearly stated as 2
gpl => 'open_source', # we don't know which GPL; punt
lgpl => 'open_source', # we don't know which LGPL; punt
mozilla => 'open_source', # we don't know which MPL; punt
perl => 'perl_5', # clearly Perl 5
restrictive => 'restricted',
);
sub _license_2 {
my ($element) = @_;
return [ 'unknown' ] unless defined $element;
$element = [ $element ] unless ref $element eq 'ARRAY';
my @new_list;
for my $lic ( @$element ) {
next unless defined $lic;
if ( my $new = $license_map_2{lc $lic} ) {
push @new_list, $new;
}
}
return @new_list ? \@new_list : [ 'unknown' ];
}
my %license_downgrade_map = qw(
agpl_3 open_source
apache_1_1 apache
apache_2_0 apache
artistic_1 artistic
artistic_2 artistic_2
bsd bsd
freebsd open_source
gfdl_1_2 open_source
gfdl_1_3 open_source
gpl_1 gpl
gpl_2 gpl
gpl_3 gpl
lgpl_2_1 lgpl
lgpl_3_0 lgpl
mit mit
mozilla_1_0 mozilla
mozilla_1_1 mozilla
openssl open_source
perl_5 perl
qpl_1_0 open_source
ssleay open_source
sun open_source
zlib open_source
open_source open_source
restricted restrictive
unrestricted unrestricted
unknown unknown
);
sub _downgrade_license {
my ($element) = @_;
if ( ! defined $element ) {
return "unknown";
}
elsif( ref $element eq 'ARRAY' ) {
if ( @$element == 1 ) {
return $license_downgrade_map{$element->[0]} || "unknown";
}
}
elsif ( ! ref $element ) {
return $license_downgrade_map{$element} || "unknown";
}
return "unknown";
}
my $no_index_spec_1_2 = {
'file' => \&_listify,
'dir' => \&_listify,
'package' => \&_listify,
'namespace' => \&_listify,
};
my $no_index_spec_1_3 = {
'file' => \&_listify,
'directory' => \&_listify,
'package' => \&_listify,
'namespace' => \&_listify,
};
my $no_index_spec_2 = {
'file' => \&_listify,
'directory' => \&_listify,
'package' => \&_listify,
'namespace' => \&_listify,
':custom' => \&_prefix_custom,
};
sub _no_index_1_2 {
my (undef, undef, $meta) = @_;
my $no_index = $meta->{no_index} || $meta->{private};
return unless $no_index;
# cleanup wrong format
if ( ! ref $no_index ) {
my $item = $no_index;
$no_index = { dir => [ $item ], file => [ $item ] };
}
elsif ( ref $no_index eq 'ARRAY' ) {
my $list = $no_index;
$no_index = { dir => [ @$list ], file => [ @$list ] };
}
# common mistake: files -> file
if ( exists $no_index->{files} ) {
$no_index->{file} = delete $no_index->{file};
}
# common mistake: modules -> module
if ( exists $no_index->{modules} ) {
$no_index->{module} = delete $no_index->{module};
}
return _convert($no_index, $no_index_spec_1_2);
}
sub _no_index_directory {
my ($element, $key, $meta, $version) = @_;
return unless $element;
# cleanup wrong format
if ( ! ref $element ) {
my $item = $element;
$element = { directory => [ $item ], file => [ $item ] };
}
elsif ( ref $element eq 'ARRAY' ) {
my $list = $element;
$element = { directory => [ @$list ], file => [ @$list ] };
}
if ( exists $element->{dir} ) {
$element->{directory} = delete $element->{dir};
}
# common mistake: files -> file
if ( exists $element->{files} ) {
$element->{file} = delete $element->{file};
}
# common mistake: modules -> module
if ( exists $element->{modules} ) {
$element->{module} = delete $element->{module};
}
my $spec = $version == 2 ? $no_index_spec_2 : $no_index_spec_1_3;
return _convert($element, $spec);
}
sub _is_module_name {
my $mod = shift;
return unless defined $mod && length $mod;
return $mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$};
}
sub _clean_version {
my ($element) = @_;
return 0 if ! defined $element;
$element =~ s{^\s*}{};
$element =~ s{\s*$}{};
$element =~ s{^\.}{0.};
return 0 if ! length $element;
return 0 if ( $element eq 'undef' || $element eq '<undef>' );
my $v = eval { version->new($element) };
# XXX check defined $v and not just $v because version objects leak memory
# in boolean context -- dagolden, 2012-02-03
if ( defined $v ) {
return $v->is_qv ? $v->normal : $element;
}
else {
return 0;
}
}
sub _bad_version_hook {
my ($v) = @_;
$v =~ s{[a-z]+$}{}; # strip trailing alphabetics
my $vobj = eval { version->parse($v) };
return defined($vobj) ? $vobj : version->parse(0); # or give up
}
sub _version_map {
my ($element) = @_;
return unless defined $element;
if ( ref $element eq 'HASH' ) {
# XXX turn this into CPAN::Meta::Requirements with bad version hook
# and then turn it back into a hash
my $new_map = CPAN::Meta::Requirements->new(
{ bad_version_hook => sub { version->new(0) } } # punt
);
while ( my ($k,$v) = each %$element ) {
next unless _is_module_name($k);
if ( !defined($v) || !length($v) || $v eq 'undef' || $v eq '<undef>' ) {
$v = 0;
}
# some weird, old META have bad yml with module => module
# so check if value is like a module name and not like a version
if ( _is_module_name($v) && ! version::is_lax($v) ) {
$new_map->add_minimum($k => 0);
$new_map->add_minimum($v => 0);
}
$new_map->add_string_requirement($k => $v);
}
return $new_map->as_string_hash;
}
elsif ( ref $element eq 'ARRAY' ) {
my $hashref = { map { $_ => 0 } @$element };
return _version_map($hashref); # cleanup any weird stuff
}
elsif ( ref $element eq '' && length $element ) {
return { $element => 0 }
}
return;
}
sub _prereqs_from_1 {
my (undef, undef, $meta) = @_;
my $prereqs = {};
for my $phase ( qw/build configure/ ) {
my $key = "${phase}_requires";
$prereqs->{$phase}{requires} = _version_map($meta->{$key})
if $meta->{$key};
}
for my $rel ( qw/requires recommends conflicts/ ) {
$prereqs->{runtime}{$rel} = _version_map($meta->{$rel})
if $meta->{$rel};
}
return $prereqs;
}
my $prereqs_spec = {
configure => \&_prereqs_rel,
build => \&_prereqs_rel,
test => \&_prereqs_rel,
runtime => \&_prereqs_rel,
develop => \&_prereqs_rel,
':custom' => \&_prefix_custom,
};
my $relation_spec = {
requires => \&_version_map,
recommends => \&_version_map,
suggests => \&_version_map,
conflicts => \&_version_map,
':custom' => \&_prefix_custom,
};
sub _cleanup_prereqs {
my ($prereqs, $key, $meta, $to_version) = @_;
return unless $prereqs && ref $prereqs eq 'HASH';
return _convert( $prereqs, $prereqs_spec, $to_version );
}
sub _prereqs_rel {
my ($relation, $key, $meta, $to_version) = @_;
return unless $relation && ref $relation eq 'HASH';
return _convert( $relation, $relation_spec, $to_version );
}
BEGIN {
my @old_prereqs = qw(
requires
configure_requires
recommends
conflicts
);
for ( @old_prereqs ) {
my $sub = "_get_$_";
my ($phase,$type) = split qr/_/, $_;
if ( ! defined $type ) {
$type = $phase;
$phase = 'runtime';
}
no strict 'refs';
*{$sub} = sub { _extract_prereqs($_[2]->{prereqs},$phase,$type) };
}
}
sub _get_build_requires {
my ($data, $key, $meta) = @_;
my $test_h = _extract_prereqs($_[2]->{prereqs}, qw(test requires)) || {};
my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {};
my $test_req = CPAN::Meta::Requirements->from_string_hash($test_h);
my $build_req = CPAN::Meta::Requirements->from_string_hash($build_h);
$test_req->add_requirements($build_req)->as_string_hash;
}
sub _extract_prereqs {
my ($prereqs, $phase, $type) = @_;
return unless ref $prereqs eq 'HASH';
return scalar _version_map($prereqs->{$phase}{$type});
}
sub _downgrade_optional_features {
my (undef, undef, $meta) = @_;
return unless exists $meta->{optional_features};
my $origin = $meta->{optional_features};
my $features = {};
for my $name ( keys %$origin ) {
$features->{$name} = {
description => $origin->{$name}{description},
requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','requires'),
configure_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'),
build_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'),
recommends => _extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'),
conflicts => _extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'),
};
for my $k (keys %{$features->{$name}} ) {
delete $features->{$name}{$k} unless defined $features->{$name}{$k};
}
}
return $features;
}
sub _upgrade_optional_features {
my (undef, undef, $meta) = @_;
return unless exists $meta->{optional_features};
my $origin = $meta->{optional_features};
my $features = {};
for my $name ( keys %$origin ) {
$features->{$name} = {
description => $origin->{$name}{description},
prereqs => _prereqs_from_1(undef, undef, $origin->{$name}),
};
delete $features->{$name}{prereqs}{configure};
}
return $features;
}
my $optional_features_2_spec = {
description => \&_keep,
prereqs => \&_cleanup_prereqs,
':custom' => \&_prefix_custom,
};
sub _feature_2 {
my ($element, $key, $meta, $to_version) = @_;
return unless $element && ref $element eq 'HASH';
_convert( $element, $optional_features_2_spec, $to_version );
}
sub _cleanup_optional_features_2 {
my ($element, $key, $meta, $to_version) = @_;
return unless $element && ref $element eq 'HASH';
my $new_data = {};
for my $k ( keys %$element ) {
$new_data->{$k} = _feature_2( $element->{$k}, $k, $meta, $to_version );
}
return unless keys %$new_data;
return $new_data;
}
sub _optional_features_1_4 {
my ($element) = @_;
return unless $element;
$element = _optional_features_as_map($element);
for my $name ( keys %$element ) {
for my $drop ( qw/requires_packages requires_os excluded_os/ ) {
delete $element->{$name}{$drop};
}
}
return $element;
}
sub _optional_features_as_map {
my ($element) = @_;
return unless $element;
if ( ref $element eq 'ARRAY' ) {
my %map;
for my $feature ( @$element ) {
my (@parts) = %$feature;
$map{$parts[0]} = $parts[1];
}
$element = \%map;
}
return $element;
}
sub _is_urlish { defined $_[0] && $_[0] =~ m{\A[-+.a-z0-9]+:.+}i }
sub _url_or_drop {
my ($element) = @_;
return $element if _is_urlish($element);
return;
}
sub _url_list {
my ($element) = @_;
return unless $element;
$element = _listify( $element );
$element = [ grep { _is_urlish($_) } @$element ];
return unless @$element;
return $element;
}
sub _author_list {
my ($element) = @_;
return [ 'unknown' ] unless $element;
$element = _listify( $element );
$element = [ map { defined $_ && length $_ ? $_ : 'unknown' } @$element ];
return [ 'unknown' ] unless @$element;
return $element;
}
my $resource2_upgrade = {
license => sub { return _is_urlish($_[0]) ? _listify( $_[0] ) : undef },
homepage => \&_url_or_drop,
bugtracker => sub {
my ($item) = @_;
return unless $item;
if ( $item =~ m{^mailto:(.*)$} ) { return { mailto => $1 } }
elsif( _is_urlish($item) ) { return { web => $item } }
else { return }
},
repository => sub { return _is_urlish($_[0]) ? { url => $_[0] } : undef },
':custom' => \&_prefix_custom,
};
sub _upgrade_resources_2 {
my (undef, undef, $meta, $version) = @_;
return unless exists $meta->{resources};
return _convert($meta->{resources}, $resource2_upgrade);
}
my $bugtracker2_spec = {
web => \&_url_or_drop,
mailto => \&_keep,
':custom' => \&_prefix_custom,
};
sub _repo_type {
my ($element, $key, $meta, $to_version) = @_;
return $element if defined $element;
return unless exists $meta->{url};
my $repo_url = $meta->{url};
for my $type ( qw/git svn/ ) {
return $type if $repo_url =~ m{\A$type};
}
return;
}
my $repository2_spec = {
web => \&_url_or_drop,
url => \&_url_or_drop,
type => \&_repo_type,
':custom' => \&_prefix_custom,
};
my $resources2_cleanup = {
license => \&_url_list,
homepage => \&_url_or_drop,
bugtracker => sub { ref $_[0] ? _convert( $_[0], $bugtracker2_spec ) : undef },
repository => sub { my $data = shift; ref $data ? _convert( $data, $repository2_spec ) : undef },
':custom' => \&_prefix_custom,
};
sub _cleanup_resources_2 {
my ($resources, $key, $meta, $to_version) = @_;
return unless $resources && ref $resources eq 'HASH';
return _convert($resources, $resources2_cleanup, $to_version);
}
my $resource1_spec = {
license => \&_url_or_drop,
homepage => \&_url_or_drop,
bugtracker => \&_url_or_drop,
repository => \&_url_or_drop,
':custom' => \&_keep,
};
sub _resources_1_3 {
my (undef, undef, $meta, $version) = @_;
return unless exists $meta->{resources};
return _convert($meta->{resources}, $resource1_spec);
}
*_resources_1_4 = *_resources_1_3;
sub _resources_1_2 {
my (undef, undef, $meta) = @_;
my $resources = $meta->{resources} || {};
if ( $meta->{license_url} && ! $resources->{license} ) {
$resources->{license} = $meta->license_url
if _is_urlish($meta->{license_url});
}
return unless keys %$resources;
return _convert($resources, $resource1_spec);
}
my $resource_downgrade_spec = {
license => sub { return ref $_[0] ? $_[0]->[0] : $_[0] },
homepage => \&_url_or_drop,
bugtracker => sub { return $_[0]->{web} },
repository => sub { return $_[0]->{url} || $_[0]->{web} },
':custom' => \&_no_prefix_ucfirst_custom,
};
sub _downgrade_resources {
my (undef, undef, $meta, $version) = @_;
return unless exists $meta->{resources};
return _convert($meta->{resources}, $resource_downgrade_spec);
}
sub _release_status {
my ($element, undef, $meta) = @_;
return $element if $element && $element =~ m{\A(?:stable|testing|unstable)\z};
return _release_status_from_version(undef, undef, $meta);
}
sub _release_status_from_version {
my (undef, undef, $meta) = @_;
my $version = $meta->{version} || '';
return ( $version =~ /_/ ) ? 'testing' : 'stable';
}
my $provides_spec = {
file => \&_keep,
version => \&_keep,
};
my $provides_spec_2 = {
file => \&_keep,
version => \&_keep,
':custom' => \&_prefix_custom,
};
sub _provides {
my ($element, $key, $meta, $to_version) = @_;
return unless defined $element && ref $element eq 'HASH';
my $spec = $to_version == 2 ? $provides_spec_2 : $provides_spec;
my $new_data = {};
for my $k ( keys %$element ) {
$new_data->{$k} = _convert($element->{$k}, $spec, $to_version);
$new_data->{$k}{version} = _clean_version($element->{$k}{version})
if exists $element->{$k}{version};
}
return $new_data;
}
sub _convert {
my ($data, $spec, $to_version) = @_;
my $new_data = {};
for my $key ( keys %$spec ) {
next if $key eq ':custom' || $key eq ':drop';
next unless my $fcn = $spec->{$key};
die "spec for '$key' is not a coderef"
unless ref $fcn && ref $fcn eq 'CODE';
my $new_value = $fcn->($data->{$key}, $key, $data, $to_version);
$new_data->{$key} = $new_value if defined $new_value;
}
my $drop_list = $spec->{':drop'};
my $customizer = $spec->{':custom'} || \&_keep;
for my $key ( keys %$data ) {
next if $drop_list && grep { $key eq $_ } @$drop_list;
next if exists $spec->{$key}; # we handled it
$new_data->{ $customizer->($key) } = $data->{$key};
}
return $new_data;
}
#--------------------------------------------------------------------------#
# define converters for each conversion
#--------------------------------------------------------------------------#
# each converts from prior version
# special ":custom" field is used for keys not recognized in spec
my %up_convert = (
'2-from-1.4' => {
# PRIOR MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_2,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# CHANGED TO MANDATORY
'dynamic_config' => \&_keep_or_one,
# ADDED MANDATORY
'release_status' => \&_release_status_from_version,
# PRIOR OPTIONAL
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_upgrade_optional_features,
'provides' => \&_provides,
'resources' => \&_upgrade_resources_2,
# ADDED OPTIONAL
'description' => \&_keep,
'prereqs' => \&_prereqs_from_1,
# drop these deprecated fields, but only after we convert
':drop' => [ qw(
build_requires
configure_requires
conflicts
distribution_type
license_url
private
recommends
requires
) ],
# other random keys need x_ prefixing
':custom' => \&_prefix_custom,
},
'1.4-from-1.3' => {
# PRIOR MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_optional_features_1_4,
'provides' => \&_provides,
'recommends' => \&_version_map,
'requires' => \&_version_map,
'resources' => \&_resources_1_4,
# ADDED OPTIONAL
'configure_requires' => \&_keep,
# drop these deprecated fields, but only after we convert
':drop' => [ qw(
license_url
private
)],
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.3-from-1.2' => {
# PRIOR MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_optional_features_as_map,
'provides' => \&_provides,
'recommends' => \&_version_map,
'requires' => \&_version_map,
'resources' => \&_resources_1_3,
# drop these deprecated fields, but only after we convert
':drop' => [ qw(
license_url
private
)],
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.2-from-1.1' => {
# PRIOR MANDATORY
'version' => \&_keep,
# CHANGED TO MANDATORY
'license' => \&_license_1,
'name' => \&_keep,
'generated_by' => \&_generated_by,
# ADDED MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'meta-spec' => \&_change_meta_spec,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# ADDED OPTIONAL
'keywords' => \&_keep,
'no_index' => \&_no_index_1_2,
'optional_features' => \&_optional_features_as_map,
'provides' => \&_provides,
'resources' => \&_resources_1_2,
# drop these deprecated fields, but only after we convert
':drop' => [ qw(
license_url
private
)],
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.1-from-1.0' => {
# CHANGED TO MANDATORY
'version' => \&_keep,
# IMPLIED MANDATORY
'name' => \&_keep,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# ADDED OPTIONAL
'license_url' => \&_url_or_drop,
'private' => \&_keep,
# other random keys are OK if already valid
':custom' => \&_keep
},
);
my %down_convert = (
'1.4-from-2' => {
# MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_downgrade_license,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# OPTIONAL
'build_requires' => \&_get_build_requires,
'configure_requires' => \&_get_configure_requires,
'conflicts' => \&_get_conflicts,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_downgrade_optional_features,
'provides' => \&_provides,
'recommends' => \&_get_recommends,
'requires' => \&_get_requires,
'resources' => \&_downgrade_resources,
# drop these unsupported fields (after conversion)
':drop' => [ qw(
description
prereqs
release_status
)],
# custom keys will be left unchanged
':custom' => \&_keep
},
'1.3-from-1.4' => {
# MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_optional_features_as_map,
'provides' => \&_provides,
'recommends' => \&_version_map,
'requires' => \&_version_map,
'resources' => \&_resources_1_3,
# drop these unsupported fields, but only after we convert
':drop' => [ qw(
configure_requires
)],
# other random keys are OK if already valid
':custom' => \&_keep,
},
'1.2-from-1.3' => {
# MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'keywords' => \&_keep,
'no_index' => \&_no_index_1_2,
'optional_features' => \&_optional_features_as_map,
'provides' => \&_provides,
'recommends' => \&_version_map,
'requires' => \&_version_map,
'resources' => \&_resources_1_3,
# other random keys are OK if already valid
':custom' => \&_keep,
},
'1.1-from-1.2' => {
# MANDATORY
'version' => \&_keep,
# IMPLIED MANDATORY
'name' => \&_keep,
'meta-spec' => \&_change_meta_spec,
# OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'private' => \&_keep,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# drop unsupported fields
':drop' => [ qw(
abstract
author
provides
no_index
keywords
resources
)],
# other random keys are OK if already valid
':custom' => \&_keep,
},
'1.0-from-1.1' => {
# IMPLIED MANDATORY
'name' => \&_keep,
'meta-spec' => \&_change_meta_spec,
'version' => \&_keep,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# other random keys are OK if already valid
':custom' => \&_keep,
},
);
my %cleanup = (
'2' => {
# PRIOR MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_2,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# CHANGED TO MANDATORY
'dynamic_config' => \&_keep_or_one,
# ADDED MANDATORY
'release_status' => \&_release_status,
# PRIOR OPTIONAL
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_cleanup_optional_features_2,
'provides' => \&_provides,
'resources' => \&_cleanup_resources_2,
# ADDED OPTIONAL
'description' => \&_keep,
'prereqs' => \&_cleanup_prereqs,
# drop these deprecated fields, but only after we convert
':drop' => [ qw(
build_requires
configure_requires
conflicts
distribution_type
license_url
private
recommends
requires
) ],
# other random keys need x_ prefixing
':custom' => \&_prefix_custom,
},
'1.4' => {
# PRIOR MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_optional_features_1_4,
'provides' => \&_provides,
'recommends' => \&_version_map,
'requires' => \&_version_map,
'resources' => \&_resources_1_4,
# ADDED OPTIONAL
'configure_requires' => \&_keep,
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.3' => {
# PRIOR MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_optional_features_as_map,
'provides' => \&_provides,
'recommends' => \&_version_map,
'requires' => \&_version_map,
'resources' => \&_resources_1_3,
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.2' => {
# PRIOR MANDATORY
'version' => \&_keep,
# CHANGED TO MANDATORY
'license' => \&_license_1,
'name' => \&_keep,
'generated_by' => \&_generated_by,
# ADDED MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'meta-spec' => \&_change_meta_spec,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# ADDED OPTIONAL
'keywords' => \&_keep,
'no_index' => \&_no_index_1_2,
'optional_features' => \&_optional_features_as_map,
'provides' => \&_provides,
'resources' => \&_resources_1_2,
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.1' => {
# CHANGED TO MANDATORY
'version' => \&_keep,
# IMPLIED MANDATORY
'name' => \&_keep,
'meta-spec' => \&_change_meta_spec,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# ADDED OPTIONAL
'license_url' => \&_url_or_drop,
'private' => \&_keep,
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.0' => {
# IMPLIED MANDATORY
'name' => \&_keep,
'meta-spec' => \&_change_meta_spec,
'version' => \&_keep,
# IMPLIED OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# other random keys are OK if already valid
':custom' => \&_keep,
},
);
#--------------------------------------------------------------------------#
# Code
#--------------------------------------------------------------------------#
sub new {
my ($class,$data) = @_;
# create an attributes hash
my $self = {
'data' => $data,
'spec' => $data->{'meta-spec'}{'version'} || "1.0",
};
# create the object
return bless $self, $class;
}
sub convert {
my ($self, %args) = @_;
my $args = { %args };
my $new_version = $args->{version} || $HIGHEST;
my ($old_version) = $self->{spec};
my $converted = _dclone($self->{data});
if ( $old_version == $new_version ) {
$converted = _convert( $converted, $cleanup{$old_version}, $old_version );
my $cmv = CPAN::Meta::Validator->new( $converted );
unless ( $cmv->is_valid ) {
my $errs = join("\n", $cmv->errors);
die "Failed to clean-up $old_version metadata. Errors:\n$errs\n";
}
return $converted;
}
elsif ( $old_version > $new_version ) {
my @vers = sort { $b <=> $a } keys %known_specs;
for my $i ( 0 .. $#vers-1 ) {
next if $vers[$i] > $old_version;
last if $vers[$i+1] < $new_version;
my $spec_string = "$vers[$i+1]-from-$vers[$i]";
$converted = _convert( $converted, $down_convert{$spec_string}, $vers[$i+1] );
my $cmv = CPAN::Meta::Validator->new( $converted );
unless ( $cmv->is_valid ) {
my $errs = join("\n", $cmv->errors);
die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
}
}
return $converted;
}
else {
my @vers = sort { $a <=> $b } keys %known_specs;
for my $i ( 0 .. $#vers-1 ) {
next if $vers[$i] < $old_version;
last if $vers[$i+1] > $new_version;
my $spec_string = "$vers[$i+1]-from-$vers[$i]";
$converted = _convert( $converted, $up_convert{$spec_string}, $vers[$i+1] );
my $cmv = CPAN::Meta::Validator->new( $converted );
unless ( $cmv->is_valid ) {
my $errs = join("\n", $cmv->errors);
die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
}
}
return $converted;
}
}
1;
# ABSTRACT: Convert CPAN distribution metadata structures
__END__
=pod
=encoding utf-8
=head1 NAME
CPAN::Meta::Converter - Convert CPAN distribution metadata structures
=head1 VERSION
version 2.131560
=head1 SYNOPSIS
my $struct = decode_json_file('META.json');
my $cmc = CPAN::Meta::Converter->new( $struct );
my $new_struct = $cmc->convert( version => "2" );
=head1 DESCRIPTION
This module converts CPAN Meta structures from one form to another. The
primary use is to convert older structures to the most modern version of
the specification, but other transformations may be implemented in the
future as needed. (E.g. stripping all custom fields or stripping all
optional fields.)
=head1 METHODS
=head2 new
my $cmc = CPAN::Meta::Converter->new( $struct );
The constructor should be passed a valid metadata structure but invalid
structures are accepted. If no meta-spec version is provided, version 1.0 will
be assumed.
=head2 convert
my $new_struct = $cmc->convert( version => "2" );
Returns a new hash reference with the metadata converted to a different form.
C<convert> will die if any conversion/standardization still results in an
invalid structure.
Valid parameters include:
=over
=item *
C<version> -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2").
Defaults to the latest version of the CPAN Meta Spec.
=back
Conversion proceeds through each version in turn. For example, a version 1.2
structure might be converted to 1.3 then 1.4 then finally to version 2. The
conversion process attempts to clean-up simple errors and standardize data.
For example, if C<author> is given as a scalar, it will converted to an array
reference containing the item. (Converting a structure to its own version will
also clean-up and standardize.)
When data are cleaned and standardized, missing or invalid fields will be
replaced with sensible defaults when possible. This may be lossy or imprecise.
For example, some badly structured META.yml files on CPAN have prerequisite
modules listed as both keys and values:
requires => { 'Foo::Bar' => 'Bam::Baz' }
These would be split and each converted to a prerequisite with a minimum
version of zero.
When some mandatory fields are missing or invalid, the conversion will attempt
to provide a sensible default or will fill them with a value of 'unknown'. For
example a missing or unrecognized C<license> field will result in a C<license>
field of 'unknown'. Fields that may get an 'unknown' include:
=over 4
=item *
abstract
=item *
author
=item *
license
=back
=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>
=back
=head1 CONTRIBUTORS
=over 4
=item *
Ansgar Burchardt <ansgar@cpan.org>
=item *
Avar Arnfjord Bjarmason <avar@cpan.org>
=item *
Christopher J. Madsen <cjm@cpan.org>
=item *
Cory G Watson <gphat@cpan.org>
=item *
Damyan Ivanov <dam@cpan.org>
=item *
Eric Wilhelm <ewilhelm@cpan.org>
=item *
Gregor Hermann <gregoa@debian.org>
=item *
Ken Williams <kwilliams@cpan.org>
=item *
Kenichi Ishigaki <ishigaki@cpan.org>
=item *
Lars Dieckow <daxim@cpan.org>
=item *
Leon Timmermans <leont@cpan.org>
=item *
Mark Fowler <markf@cpan.org>
=item *
Michael G. Schwern <mschwern@cpan.org>
=item *
Randy Sims <randys@thepierianspring.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
CPAN_META_CONVERTER
$fatpacked{"CPAN/Meta/Feature.pm"} = <<'CPAN_META_FEATURE';
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Feature;
our $VERSION = '2.131560'; # VERSION
use CPAN::Meta::Prereqs;
sub new {
my ($class, $identifier, $spec) = @_;
my %guts = (
identifier => $identifier,
description => $spec->{description},
prereqs => CPAN::Meta::Prereqs->new($spec->{prereqs}),
);
bless \%guts => $class;
}
sub identifier { $_[0]{identifier} }
sub description { $_[0]{description} }
sub prereqs { $_[0]{prereqs} }
1;
# ABSTRACT: an optional feature provided by a CPAN distribution
__END__
=pod
=encoding utf-8
=head1 NAME
CPAN::Meta::Feature - an optional feature provided by a CPAN distribution
=head1 VERSION
version 2.131560
=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>
=back
=head1 CONTRIBUTORS
=over 4
=item *
Ansgar Burchardt <ansgar@cpan.org>
=item *
Avar Arnfjord Bjarmason <avar@cpan.org>
=item *
Christopher J. Madsen <cjm@cpan.org>
=item *
Cory G Watson <gphat@cpan.org>
=item *
Damyan Ivanov <dam@cpan.org>
=item *
Eric Wilhelm <ewilhelm@cpan.org>
=item *
Gregor Hermann <gregoa@debian.org>
=item *
Ken Williams <kwilliams@cpan.org>
=item *
Kenichi Ishigaki <ishigaki@cpan.org>
=item *
Lars Dieckow <daxim@cpan.org>
=item *
Leon Timmermans <leont@cpan.org>
=item *
Mark Fowler <markf@cpan.org>
=item *
Michael G. Schwern <mschwern@cpan.org>
=item *
Randy Sims <randys@thepierianspring.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
CPAN_META_FEATURE
$fatpacked{"CPAN/Meta/History.pm"} = <<'CPAN_META_HISTORY';
# vi:tw=72
use 5.006;
use strict;
use warnings;
package CPAN::Meta::History;
our $VERSION = '2.131560'; # VERSION
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.131560
=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>
=back
=head1 CONTRIBUTORS
=over 4
=item *
Ansgar Burchardt <ansgar@cpan.org>
=item *
Avar Arnfjord Bjarmason <avar@cpan.org>
=item *
Christopher J. Madsen <cjm@cpan.org>
=item *
Cory G Watson <gphat@cpan.org>
=item *
Damyan Ivanov <dam@cpan.org>
=item *
Eric Wilhelm <ewilhelm@cpan.org>
=item *
Gregor Hermann <gregoa@debian.org>
=item *
Ken Williams <kwilliams@cpan.org>
=item *
Kenichi Ishigaki <ishigaki@cpan.org>
=item *
Lars Dieckow <daxim@cpan.org>
=item *
Leon Timmermans <leont@cpan.org>
=item *
Mark Fowler <markf@cpan.org>
=item *
Michael G. Schwern <mschwern@cpan.org>
=item *
Randy Sims <randys@thepierianspring.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
CPAN_META_HISTORY
$fatpacked{"CPAN/Meta/Prereqs.pm"} = <<'CPAN_META_PREREQS';
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Prereqs;
our $VERSION = '2.131560'; # VERSION
use Carp qw(confess);
use Scalar::Util qw(blessed);
use CPAN::Meta::Requirements 2.121;
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;
}
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;
}
sub with_merged_prereqs {
my ($self, $other) = @_;
my @other = blessed($other) ? $other : @$other;
my @prereq_objs = ($self, @other);
my %new_arg;
for my $phase ($self->__legal_phases) {
for my $type ($self->__legal_types) {
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);
}
sub as_string_hash {
my ($self) = @_;
my %hash;
for my $phase ($self->__legal_phases) {
for my $type ($self->__legal_types) {
my $req = $self->requirements_for($phase, $type);
next unless $req->required_modules;
$hash{ $phase }{ $type } = $req->as_string_hash;
}
}
return \%hash;
}
sub is_finalized { $_[0]{finalized} }
sub finalize {
my ($self) = @_;
$self->{finalized} = 1;
for my $phase (keys %{ $self->{prereqs} }) {
$_->finalize for values %{ $self->{prereqs}{$phase} };
}
}
sub clone {
my ($self) = @_;
my $clone = (ref $self)->new( $self->as_string_hash );
}
1;
# ABSTRACT: a set of distribution prerequisites by phase and type
__END__
=pod
=encoding utf-8
=head1 NAME
CPAN::Meta::Prereqs - a set of distribution prerequisites by phase and type
=head1 VERSION
version 2.131560
=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 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 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>
=back
=head1 CONTRIBUTORS
=over 4
=item *
Ansgar Burchardt <ansgar@cpan.org>
=item *
Avar Arnfjord Bjarmason <avar@cpan.org>
=item *
Christopher J. Madsen <cjm@cpan.org>
=item *
Cory G Watson <gphat@cpan.org>
=item *
Damyan Ivanov <dam@cpan.org>
=item *
Eric Wilhelm <ewilhelm@cpan.org>
=item *
Gregor Hermann <gregoa@debian.org>
=item *
Ken Williams <kwilliams@cpan.org>
=item *
Kenichi Ishigaki <ishigaki@cpan.org>
=item *
Lars Dieckow <daxim@cpan.org>
=item *
Leon Timmermans <leont@cpan.org>
=item *
Mark Fowler <markf@cpan.org>
=item *
Michael G. Schwern <mschwern@cpan.org>
=item *
Randy Sims <randys@thepierianspring.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
CPAN_META_PREREQS
$fatpacked{"CPAN/Meta/Requirements.pm"} = <<'CPAN_META_REQUIREMENTS';
use strict;
use warnings;
package CPAN::Meta::Requirements;
our $VERSION = '2.122'; # VERSION
# ABSTRACT: a set of version requirements for a CPAN dist
use Carp ();
use Scalar::Util ();
use version 0.77 (); # the ->parse method
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;
}
sub _version_object {
my ($self, $version) = @_;
my $vobj;
eval {
$vobj = (! defined $version) ? version->parse(0)
: (! Scalar::Util::blessed($version)) ? version->parse($version)
: $version;
};
if ( my $err = $@ ) {
my $hook = $self->{bad_version_hook};
$vobj = eval { $hook->($version) }
if ref $hook eq 'CODE';
unless (Scalar::Util::blessed($vobj) && $vobj->isa("version")) {
$err =~ s{ at .* line \d+.*$}{};
die "Can't convert '$version': $err";
}
}
# ensure no leading '.'
if ( $vobj =~ m{\A\.} ) {
$vobj = version->parse("0$vobj");
}
# ensure normal v-string form
if ( $vobj->is_qv ) {
$vobj = version->parse($vobj->normal);
}
return $vobj;
}
BEGIN {
for my $type (qw(minimum maximum exclusion exact_version)) {
my $method = "with_$type";
my $to_add = $type eq 'exact_version' ? $type : "add_$type";
my $code = sub {
my ($self, $name, $version) = @_;
$version = $self->_version_object( $version );
$self->__modify_entry_for($name, $method, $version);
return $self;
};
no strict 'refs';
*$to_add = $code;
}
}
sub add_requirements {
my ($self, $req) = @_;
for my $module ($req->required_modules) {
my $modifiers = $req->__entry_for($module)->as_modifiers;
for my $modifier (@$modifiers) {
my ($method, @args) = @$modifier;
$self->$method($module => @args);
};
}
return $self;
}
sub accepts_module {
my ($self, $module, $version) = @_;
$version = $self->_version_object( $version );
return 1 unless my $range = $self->__entry_for($module);
return $range->_accepts($version);
}
sub clear_requirement {
my ($self, $module) = @_;
return $self unless $self->__entry_for($module);
Carp::confess("can't clear requirements on finalized requirements")
if $self->is_finalized;
delete $self->{requirements}{ $module };
return $self;
}
sub requirements_for_module {
my ($self, $module) = @_;
my $entry = $self->__entry_for($module);
return unless $entry;
return $entry->as_string;
}
sub required_modules { keys %{ $_[0]{requirements} } }
sub clone {
my ($self) = @_;
my $new = (ref $self)->new;
return $new->add_requirements($self);
}
sub __entry_for { $_[0]{requirements}{ $_[1] } }
sub __modify_entry_for {
my ($self, $name, $method, $version) = @_;
my $fin = $self->is_finalized;
my $old = $self->__entry_for($name);
Carp::confess("can't add new requirements to finalized requirements")
if $fin and not $old;
my $new = ($old || 'CPAN::Meta::Requirements::_Range::Range')
->$method($version);
Carp::confess("can't modify finalized requirements")
if $fin and $old->as_string ne $new->as_string;
$self->{requirements}{ $name } = $new;
}
sub is_simple {
my ($self) = @_;
for my $module ($self->required_modules) {
# XXX: This is a complete hack, but also entirely correct.
return if $self->__entry_for($module)->as_string =~ /\s/;
}
return 1;
}
sub is_finalized { $_[0]{finalized} }
sub finalize { $_[0]{finalized} = 1 }
sub as_string_hash {
my ($self) = @_;
my %hash = map {; $_ => $self->{requirements}{$_}->as_string }
$self->required_modules;
return \%hash;
}
my %methods_for_op = (
'==' => [ qw(exact_version) ],
'!=' => [ qw(add_exclusion) ],
'>=' => [ qw(add_minimum) ],
'<=' => [ qw(add_maximum) ],
'>' => [ qw(add_minimum add_exclusion) ],
'<' => [ qw(add_maximum add_exclusion) ],
);
sub add_string_requirement {
my ($self, $module, $req) = @_;
Carp::confess("No requirement string provided for $module")
unless defined $req && length $req;
my @parts = split qr{\s*,\s*}, $req;
for my $part (@parts) {
my ($op, $ver) = $part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z};
if (! defined $op) {
$self->add_minimum($module => $part);
} else {
Carp::confess("illegal requirement string: $req")
unless my $methods = $methods_for_op{ $op };
$self->$_($module => $ver) for @$methods;
}
}
}
sub from_string_hash {
my ($class, $hash) = @_;
my $self = $class->new;
for my $module (keys %$hash) {
my $req = $hash->{$module};
unless ( defined $req && length $req ) {
$req = 0;
Carp::carp("Undefined requirement for $module treated as '0'");
}
$self->add_string_requirement($module, $req);
}
return $self;
}
##############################################################
{
package
CPAN::Meta::Requirements::_Range::Exact;
sub _new { bless { version => $_[1] } => $_[0] }
sub _accepts { return $_[0]{version} == $_[1] }
sub as_string { return "== $_[0]{version}" }
sub as_modifiers { return [ [ exact_version => $_[0]{version} ] ] }
sub _clone {
(ref $_[0])->_new( version->new( $_[0]{version} ) )
}
sub with_exact_version {
my ($self, $version) = @_;
return $self->_clone if $self->_accepts($version);
Carp::confess("illegal requirements: unequal exact version specified");
}
sub with_minimum {
my ($self, $minimum) = @_;
return $self->_clone if $self->{version} >= $minimum;
Carp::confess("illegal requirements: minimum above exact specification");
}
sub with_maximum {
my ($self, $maximum) = @_;
return $self->_clone if $self->{version} <= $maximum;
Carp::confess("illegal requirements: maximum below exact specification");
}
sub with_exclusion {
my ($self, $exclusion) = @_;
return $self->_clone unless $exclusion == $self->{version};
Carp::confess("illegal requirements: excluded exact specification");
}
}
##############################################################
{
package
CPAN::Meta::Requirements::_Range::Range;
sub _self { ref($_[0]) ? $_[0] : (bless { } => $_[0]) }
sub _clone {
return (bless { } => $_[0]) unless ref $_[0];
my ($s) = @_;
my %guts = (
(exists $s->{minimum} ? (minimum => version->new($s->{minimum})) : ()),
(exists $s->{maximum} ? (maximum => version->new($s->{maximum})) : ()),
(exists $s->{exclusions}
? (exclusions => [ map { version->new($_) } @{ $s->{exclusions} } ])
: ()),
);
bless \%guts => ref($s);
}
sub as_modifiers {
my ($self) = @_;
my @mods;
push @mods, [ add_minimum => $self->{minimum} ] if exists $self->{minimum};
push @mods, [ add_maximum => $self->{maximum} ] if exists $self->{maximum};
push @mods, map {; [ add_exclusion => $_ ] } @{$self->{exclusions} || []};
return \@mods;
}
sub as_string {
my ($self) = @_;
return 0 if ! keys %$self;
return "$self->{minimum}" if (keys %$self) == 1 and exists $self->{minimum};
my @exclusions = @{ $self->{exclusions} || [] };
my @parts;
for my $pair (
[ qw( >= > minimum ) ],
[ qw( <= < maximum ) ],
) {
my ($op, $e_op, $k) = @$pair;
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 join q{, }, @parts;
}
sub with_exact_version {
my ($self, $version) = @_;
$self = $self->_clone;
Carp::confess("illegal requirements: exact specification outside of range")
unless $self->_accepts($version);
return CPAN::Meta::Requirements::_Range::Exact->_new($version);
}
sub _simplify {
my ($self) = @_;
if (defined $self->{minimum} and defined $self->{maximum}) {
if ($self->{minimum} == $self->{maximum}) {
Carp::confess("illegal requirements: excluded all values")
if grep { $_ == $self->{minimum} } @{ $self->{exclusions} || [] };
return CPAN::Meta::Requirements::_Range::Exact->_new($self->{minimum})
}
Carp::confess("illegal requirements: minimum exceeds maximum")
if $self->{minimum} > $self->{maximum};
}
# eliminate irrelevant exclusions
if ($self->{exclusions}) {
my %seen;
@{ $self->{exclusions} } = grep {
(! defined $self->{minimum} or $_ >= $self->{minimum})
and
(! defined $self->{maximum} or $_ <= $self->{maximum})
and
! $seen{$_}++
} @{ $self->{exclusions} };
}
return $self;
}
sub with_minimum {
my ($self, $minimum) = @_;
$self = $self->_clone;
if (defined (my $old_min = $self->{minimum})) {
$self->{minimum} = (sort { $b cmp $a } ($minimum, $old_min))[0];
} else {
$self->{minimum} = $minimum;
}
return $self->_simplify;
}
sub with_maximum {
my ($self, $maximum) = @_;
$self = $self->_clone;
if (defined (my $old_max = $self->{maximum})) {
$self->{maximum} = (sort { $a cmp $b } ($maximum, $old_max))[0];
} else {
$self->{maximum} = $maximum;
}
return $self->_simplify;
}
sub with_exclusion {
my ($self, $exclusion) = @_;
$self = $self->_clone;
push @{ $self->{exclusions} ||= [] }, $exclusion;
return $self->_simplify;
}
sub _accepts {
my ($self, $version) = @_;
return if defined $self->{minimum} and $version < $self->{minimum};
return if defined $self->{maximum} and $version > $self->{maximum};
return if defined $self->{exclusions}
and grep { $version == $_ } @{ $self->{exclusions} };
return 1;
}
}
1;
# vim: ts=2 sts=2 sw=2 et:
__END__
=pod
=head1 NAME
CPAN::Meta::Requirements - a set of version requirements for a CPAN dist
=head1 VERSION
version 2.122
=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.
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. The following keys are supported:
=over 4
=item *
<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 an argument. It must return a valid version object.
=back
All other keys are ignored.
=head2 add_minimum
$req->add_minimum( $module => $version );
This adds a new minimum version requirement. If the new requirement is
redundant to the existing specification, this has no effect.
Minimum requirements are inclusive. C<$version> is required, along with any
greater version number.
This method returns the requirements object.
=head2 add_maximum
$req->add_maximum( $module => $version );
This adds a new maximum version requirement. If the new requirement is
redundant to the existing specification, this has no effect.
Maximum requirements are inclusive. No version strictly greater than the given
version is allowed.
This method returns the requirements object.
=head2 add_exclusion
$req->add_exclusion( $module => $version );
This adds a new excluded version. For example, you might use these three
method calls:
$req->add_minimum( $module => '1.00' );
$req->add_maximum( $module => '1.82' );
$req->add_exclusion( $module => '1.75' );
Any version between 1.00 and 1.82 inclusive would be acceptable, except for
1.75.
This method returns the requirements object.
=head2 exact_version
$req->exact_version( $module => $version );
This sets the version required for the given module to I<exactly> the given
version. No other version would be considered acceptable.
This method returns the requirements object.
=head2 add_requirements
$req->add_requirements( $another_req_object );
This method adds all the requirements in the given CPAN::Meta::Requirements object
to the requirements object on which it was called. If there are any conflicts,
an exception is thrown.
This method returns the requirements object.
=head2 accepts_module
my $bool = $req->accepts_modules($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 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 F<META.yml> 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');
This method parses the passed in string and adds the appropriate requirement
for the given module. 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 );
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.
=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
=head1 SUPPORT
=head2 Bugs / Feature Requests
Please report any bugs or feature requests through the issue tracker
at L<http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta-Requirements>.
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/dagolden/cpan-meta-requirements>
git clone https://github.com/dagolden/cpan-meta-requirements.git
=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
CPAN_META_REQUIREMENTS
$fatpacked{"CPAN/Meta/Spec.pm"} = <<'CPAN_META_SPEC';
# vi:tw=72
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Spec;
our $VERSION = '2.131560'; # VERSION
1;
# ABSTRACT: specification for CPAN distribution metadata
__END__
=pod
=encoding utf-8
=head1 NAME
CPAN::Meta::Spec - specification for CPAN distribution metadata
=head1 VERSION
version 2.131560
=head1 SYNOPSIS
my $distmeta = {
name => 'Module-Build',
abstract => 'Build and install Perl modules',
description => "Module::Build is a system for "
. "building, testing, and installing Perl modules. "
. "It is meant to ... blah blah blah ...",
version => '0.36',
release_status => 'stable',
author => [
'Ken Williams <kwilliams@cpan.org>',
'Module-Build List <module-build@perl.org>', # additional contact
],
license => [ 'perl_5' ],
prereqs => {
runtime => {
requires => {
'perl' => '5.006',
'ExtUtils::Install' => '0',
'File::Basename' => '0',
'File::Compare' => '0',
'IO::File' => '0',
},
recommends => {
'Archive::Tar' => '1.00',
'ExtUtils::Install' => '0.3',
'ExtUtils::ParseXS' => '2.02',
},
},
build => {
requires => {
'Test::More' => '0',
},
}
},
resources => {
license => ['http://dev.perl.org/licenses/'],
},
optional_features => {
domination => {
description => 'Take over the world',
prereqs => {
develop => { requires => { 'Genius::Evil' => '1.234' } },
runtime => { requires => { 'Machine::Weather' => '2.0' } },
},
},
},
dynamic_config => 1,
keywords => [ qw/ toolchain cpan dual-life / ],
'meta-spec' => {
version => '2',
url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
},
generated_by => 'Module::Build version 0.36',
};
=head1 DESCRIPTION
This document describes version 2 of the CPAN distribution metadata
specification, also known as the "CPAN Meta Spec".
Revisions of this specification for typo corrections and prose
clarifications may be issued as CPAN::Meta::Spec 2.I<x>. These
revisions will never change semantics or add or remove specified
behavior.
Distribution metadata describe important properties of Perl
distributions. Distribution building tools like Module::Build,
Module::Install, ExtUtils::MakeMaker or Dist::Zilla should create a
metadata file in accordance with this specification and include it with
the distribution for use by automated tools that index, examine, package
or install Perl distributions.
=head1 TERMINOLOGY
=over 4
=item distribution
This is the primary object described by the metadata. In the context of
this document it usually refers to a collection of modules, scripts,
and/or documents that are distributed together for other developers to
use. Examples of distributions are C<Class-Container>, C<libwww-perl>,
or C<DBI>.
=item module
This refers to a reusable library of code contained in a single file.
Modules usually contain one or more packages and are often referred
to by the name of a primary package that can be mapped to the file
name. For example, one might refer to C<File::Spec> instead of
F<File/Spec.pm>
=item package
This refers to a namespace declared with the Perl C<package> statement.
In Perl, packages often have a version number property given by the
C<$VERSION> variable in the namespace.
=item consumer
This refers to code that reads a metadata file, deserializes it into a
data structure in memory, or interprets a data structure of metadata
elements.
=item producer
This refers to code that constructs a metadata data structure,
serializes into a bytestream and/or writes it to disk.
=item must, should, may, etc.
These terms are interpreted as described in IETF RFC 2119.
=back
=head1 DATA TYPES
Fields in the L</STRUCTURE> section describe data elements, each of
which has an associated data type as described herein. There are four
primitive types: Boolean, String, List and Map. Other types are
subtypes of primitives and define compound data structures or define
constraints on the values of a data element.
=head2 Boolean
A I<Boolean> is used to provide a true or false value. It B<must> be
represented as a defined value.
=head2 String
A I<String> is data element containing a non-zero length sequence of
Unicode characters, such as an ordinary Perl scalar that is not a
reference.
=head2 List
A I<List> is an ordered collection of zero or more data elements.
Elements of a List may be of mixed types.
Producers B<must> represent List elements using a data structure which
unambiguously indicates that multiple values are possible, such as a
reference to a Perl array (an "arrayref").
Consumers expecting a List B<must> consider a String as equivalent to a
List of length 1.
=head2 Map
A I<Map> is an unordered collection of zero or more data elements
("values"), indexed by associated String elements ("keys"). The Map's
value elements may be of mixed types.
=head2 License String
A I<License String> is a subtype of String with a restricted set of
values. Valid values are described in detail in the description of
the L</license> field.
=head2 URL
I<URL> is a subtype of String containing a Uniform Resource Locator or
Identifier. [ This type is called URL and not URI for historical reasons. ]
=head2 Version
A I<Version> is a subtype of String containing a value that describes
the version number of packages or distributions. Restrictions on format
are described in detail in the L</Version Formats> section.
=head2 Version Range
The I<Version Range> type is a subtype of String. It describes a range
of Versions that may be present or installed to fulfill prerequisites.
It is specified in detail in the L</Version Ranges> section.
=head1 STRUCTURE
The metadata structure is a data element of type Map. This section
describes valid keys within the Map.
Any keys not described in this specification document (whether top-level
or within compound data structures described herein) are considered
I<custom keys> and B<must> begin with an "x" or "X" and be followed by an
underscore; i.e. they must match the pattern: C<< qr{\Ax_}i >>. If a
custom key refers to a compound data structure, subkeys within it do not
need an "x_" or "X_" prefix.
Consumers of metadata may ignore any or all custom keys. All other keys
not described herein are invalid and should be ignored by consumers.
Producers must not generate or output invalid keys.
For each key, an example is provided followed by a description. The
description begins with the version of spec in which the key was added
or in which the definition was modified, whether the key is I<required>
or I<optional> and the data type of the corresponding data element.
These items are in parentheses, brackets and braces, respectively.
If a data type is a Map or Map subtype, valid subkeys will be described
as well.
Some fields are marked I<Deprecated>. These are shown for historical
context and must not be produced in or consumed from any metadata structure
of version 2 or higher.
=head2 REQUIRED FIELDS
=head3 abstract
Example:
abstract => 'Build and install Perl modules'
(Spec 1.2) [required] {String}
This is a short description of the purpose of the distribution.
=head3 author
Example:
author => [ 'Ken Williams <kwilliams@cpan.org>' ]
(Spec 1.2) [required] {List of one or more Strings}
This List indicates the person(s) to contact concerning the
distribution. The preferred form of the contact string is:
contact-name <email-address>
This field provides a general contact list independent of other
structured fields provided within the L</resources> field, such as
C<bugtracker>. The addressee(s) can be contacted for any purpose
including but not limited to (security) problems with the distribution,
questions about the distribution or bugs in the distribution.
A distribution's original author is usually the contact listed within
this field. Co-maintainers, successor maintainers or mailing lists
devoted to the distribution may also be listed in addition to or instead
of the original author.
=head3 dynamic_config
Example:
dynamic_config => 1
(Spec 2) [required] {Boolean}
A boolean flag indicating whether a F<Build.PL> or F<Makefile.PL> (or
similar) must be executed to determine prerequisites.
This field should be set to a true value if the distribution performs
some dynamic configuration (asking questions, sensing the environment,
etc.) as part of its configuration. This field should be set to a false
value to indicate that prerequisites included in metadata may be
considered final and valid for static analysis.
This field explicitly B<does not> indicate whether installation may be
safely performed without using a Makefile or Build file, as there may be
special files to install or custom installation targets (e.g. for
dual-life modules that exist on CPAN as well as in the Perl core). This
field only defines whether prerequisites are complete as given in the
metadata.
=head3 generated_by
Example:
generated_by => 'Module::Build version 0.36'
(Spec 1.0) [required] {String}
This field indicates the tool that was used to create this metadata.
There are no defined semantics for this field, but it is traditional to
use a string in the form "Generating::Package version 1.23" or the
author's name, if the file was generated by hand.
=head3 license
Example:
license => [ 'perl_5' ]
license => [ 'apache_2', 'mozilla_1_0' ]
(Spec 2) [required] {List of one or more License Strings}
One or more licenses that apply to some or all of the files in the
distribution. If multiple licenses are listed, the distribution
documentation should be consulted to clarify the interpretation of
multiple licenses.
The following list of license strings are valid:
string description
------------- -----------------------------------------------
agpl_3 GNU Affero General Public License, Version 3
apache_1_1 Apache Software License, Version 1.1
apache_2_0 Apache License, Version 2.0
artistic_1 Artistic License, (Version 1)
artistic_2 Artistic License, Version 2.0
bsd BSD License (three-clause)
freebsd FreeBSD License (two-clause)
gfdl_1_2 GNU Free Documentation License, Version 1.2
gfdl_1_3 GNU Free Documentation License, Version 1.3
gpl_1 GNU General Public License, Version 1
gpl_2 GNU General Public License, Version 2
gpl_3 GNU General Public License, Version 3
lgpl_2_1 GNU Lesser General Public License, Version 2.1
lgpl_3_0 GNU Lesser General Public License, Version 3.0
mit MIT (aka X11) License
mozilla_1_0 Mozilla Public License, Version 1.0
mozilla_1_1 Mozilla Public License, Version 1.1
openssl OpenSSL License
perl_5 The Perl 5 License (Artistic 1 & GPL 1 or later)
qpl_1_0 Q Public License, Version 1.0
ssleay Original SSLeay License
sun Sun Internet Standards Source License (SISSL)
zlib zlib License
The following license strings are also valid and indicate other
licensing not described above:
string description
------------- -----------------------------------------------
open_source Other Open Source Initiative (OSI) approved license
restricted Requires special permission from copyright holder
unrestricted Not an OSI approved license, but not restricted
unknown License not provided in metadata
All other strings are invalid in the license field.
=head3 meta-spec
Example:
'meta-spec' => {
version => '2',
url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
}
(Spec 1.2) [required] {Map}
This field indicates the version of the CPAN Meta Spec that should be
used to interpret the metadata. Consumers must check this key as soon
as possible and abort further metadata processing if the meta-spec
version is not supported by the consumer.
The following keys are valid, but only C<version> is required.
=over
=item version
This subkey gives the integer I<Version> of the CPAN Meta Spec against
which the document was generated.
=item url
This is a I<URL> of the metadata specification document corresponding to
the given version. This is strictly for human-consumption and should
not impact the interpretation of the document.
=back
=head3 name
Example:
name => 'Module-Build'
(Spec 1.0) [required] {String}
This field is the name of the distribution. This is often created by
taking the "main package" in the distribution and changing C<::> to
C<->, but the name may be completely unrelated to the packages within
the distribution. C.f. L<http://search.cpan.org/dist/libwww-perl/>.
=head3 release_status
Example:
release_status => 'stable'
(Spec 2) [required] {String}
This field provides the release status of this distribution. If the
C<version> field contains an underscore character, then
C<release_status> B<must not> be "stable."
The C<release_status> field B<must> have one of the following values:
=over
=item stable
This indicates an ordinary, "final" release that should be indexed by PAUSE
or other indexers.
=item testing
This indicates a "beta" release that is substantially complete, but has an
elevated risk of bugs and requires additional testing. The distribution
should not be installed over a stable release without an explicit request
or other confirmation from a user. This release status may also be used
for "release candidate" versions of a distribution.
=item unstable
This indicates an "alpha" release that is under active development, but has
been released for early feedback or testing and may be missing features or
may have serious bugs. The distribution should not be installed over a
stable release without an explicit request or other confirmation from a
user.
=back
Consumers B<may> use this field to determine how to index the
distribution for CPAN or other repositories in addition to or in
replacement of heuristics based on version number or file name.
=head3 version
Example:
version => '0.36'
(Spec 1.0) [required] {Version}
This field gives the version of the distribution to which the metadata
structure refers.
=head2 OPTIONAL FIELDS
=head3 description
Example:
description => "Module::Build is a system for "
. "building, testing, and installing Perl modules. "
. "It is meant to ... blah blah blah ...",
(Spec 2) [optional] {String}
A longer, more complete description of the purpose or intended use of
the distribution than the one provided by the C<abstract> key.
=head3 keywords
Example:
keywords => [ qw/ toolchain cpan dual-life / ]
(Spec 1.1) [optional] {List of zero or more Strings}
A List of keywords that describe this distribution. Keywords
B<must not> include whitespace.
=head3 no_index
Example:
no_index => {
file => [ 'My/Module.pm' ],
directory => [ 'My/Private' ],
package => [ 'My::Module::Secret' ],
namespace => [ 'My::Module::Sample' ],
}
(Spec 1.2) [optional] {Map}
This Map describes any files, directories, packages, and namespaces that
are private to the packaging or implementation of the distribution and
should be ignored by indexing or search tools.
Valid subkeys are as follows:
=over
=item file
A I<List> of relative paths to files. Paths B<must be> specified with
unix conventions.
=item directory
A I<List> of relative paths to directories. Paths B<must be> specified
with unix conventions.
[ Note: previous editions of the spec had C<dir> instead of C<directory> ]
=item package
A I<List> of package names.
=item namespace
A I<List> of package namespaces, where anything below the namespace
must be ignored, but I<not> the namespace itself.
In the example above for C<no_index>, C<My::Module::Sample::Foo> would
be ignored, but C<My::Module::Sample> would not.
=back
=head3 optional_features
Example:
optional_features => {
sqlite => {
description => 'Provides SQLite support',
prereqs => {
runtime => {
requires => {
'DBD::SQLite' => '1.25'
}
}
}
}
}
(Spec 2) [optional] {Map}
This Map describes optional features with incremental prerequisites.
Each key of the C<optional_features> Map is a String used to identify
the feature and each value is a Map with additional information about
the feature. Valid subkeys include:
=over
=item description
This is a String describing the feature. Every optional feature
should provide a description
=item prereqs
This entry is required and has the same structure as that of the
C<L</prereqs>> key. It provides a list of package requirements
that must be satisfied for the feature to be supported or enabled.
There is one crucial restriction: the prereqs of an optional feature
B<must not> include C<configure> phase prereqs.
=back
Consumers B<must not> include optional features as prerequisites without
explicit instruction from users (whether via interactive prompting,
a function parameter or a configuration value, etc. ).
If an optional feature is used by a consumer to add additional
prerequisites, the consumer should merge the optional feature
prerequisites into those given by the C<prereqs> key using the same
semantics. See L</Merging and Resolving Prerequisites> for details on
merging prerequisites.
I<Suggestion for disuse:> Because there is currently no way for a
distribution to specify a dependency on an optional feature of another
dependency, the use of C<optional_feature> is discouraged. Instead,
create a separate, installable distribution that ensures the desired
feature is available. For example, if C<Foo::Bar> has a "Baz" feature,
release a separate C<Foo-Bar-Baz> distribution that satisfies
requirements for the feature.
=head3 prereqs
Example:
prereqs => {
runtime => {
requires => {
'perl' => '5.006',
'File::Spec' => '0.86',
'JSON' => '2.16',
},
recommends => {
'JSON::XS' => '2.26',
},
suggests => {
'Archive::Tar' => '0',
},
},
build => {
requires => {
'Alien::SDL' => '1.00',
},
},
test => {
recommends => {
'Test::Deep' => '0.10',
},
}
}
(Spec 2) [optional] {Map}
This is a Map that describes all the prerequisites of the distribution.
The keys are phases of activity, such as C<configure>, C<build>, C<test>
or C<runtime>. Values are Maps in which the keys name the type of
prerequisite relationship such as C<requires>, C<recommends>, or
C<suggests> and the value provides a set of prerequisite relations. The
set of relations B<must> be specified as a Map of package names to
version ranges.
The full definition for this field is given in the L</Prereq Spec>
section.
=head3 provides
Example:
provides => {
'Foo::Bar' => {
file => 'lib/Foo/Bar.pm',
version => 0.27_02
},
'Foo::Bar::Blah' => {
file => 'lib/Foo/Bar/Blah.pm',
},
'Foo::Bar::Baz' => {
file => 'lib/Foo/Bar/Baz.pm',
version => 0.3,
},
}
(Spec 1.2) [optional] {Map}
This describes all packages provided by this distribution. This
information is used by distribution and automation mechanisms like
PAUSE, CPAN, and search.cpan.org to build indexes saying in which
distribution various packages can be found.
The keys of C<provides> are package names that can be found within
the distribution. If a package name key is provided, it must
have a Map with the following valid subkeys:
=over
=item file
This field is required. It must contain a Unix-style relative file path
from the root of the distribution directory to a file that contains or
generates the package.
=item version
If it exists, this field must contains a I<Version> String for the
package. If the package does not have a C<$VERSION>, this field must
be omitted.
=back
=head3 resources
Example:
resources => {
license => [ 'http://dev.perl.org/licenses/' ],
homepage => 'http://sourceforge.net/projects/module-build',
bugtracker => {
web => 'http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta',
mailto => 'meta-bugs@example.com',
},
repository => {
url => 'git://github.com/dagolden/cpan-meta.git',
web => 'http://github.com/dagolden/cpan-meta',
type => 'git',
},
x_twitter => 'http://twitter.com/cpan_linked/',
}
(Spec 2) [optional] {Map}
This field describes resources related to this distribution.
Valid subkeys include:
=over
=item homepage
The official home of this project on the web.
=item license
A List of I<URL>'s that relate to this distribution's license. As with the
top-level C<license> field, distribution documentation should be consulted
to clarify the interpretation of multiple licenses provided here.
=item bugtracker
This entry describes the bug tracking system for this distribution. It
is a Map with the following valid keys:
web - a URL pointing to a web front-end for the bug tracker
mailto - an email address to which bugs can be sent
=item repository
This entry describes the source control repository for this distribution. It
is a Map with the following valid keys:
url - a URL pointing to the repository itself
web - a URL pointing to a web front-end for the repository
type - a lowercase string indicating the VCS used
Because a url like C<http://myrepo.example.com/> is ambiguous as to
type, producers should provide a C<type> whenever a C<url> key is given.
The C<type> field should be the name of the most common program used
to work with the repository, e.g. git, svn, cvs, darcs, bzr or hg.
=back
=head2 DEPRECATED FIELDS
=head3 build_requires
I<(Deprecated in Spec 2)> [optional] {String}
Replaced by C<prereqs>
=head3 configure_requires
I<(Deprecated in Spec 2)> [optional] {String}
Replaced by C<prereqs>
=head3 conflicts
I<(Deprecated in Spec 2)> [optional] {String}
Replaced by C<prereqs>
=head3 distribution_type
I<(Deprecated in Spec 2)> [optional] {String}
This field indicated 'module' or 'script' but was considered
meaningless, since many distributions are hybrids of several kinds of
things.
=head3 license_uri
I<(Deprecated in Spec 1.2)> [optional] {URL}
Replaced by C<license> in C<resources>
=head3 private
I<(Deprecated in Spec 1.2)> [optional] {Map}
This field has been renamed to L</"no_index">.
=head3 recommends
I<(Deprecated in Spec 2)> [optional] {String}
Replaced by C<prereqs>
=head3 requires
I<(Deprecated in Spec 2)> [optional] {String}
Replaced by C<prereqs>
=head1 VERSION NUMBERS
=head2 Version Formats
This section defines the Version type, used by several fields in the
CPAN Meta Spec.
Version numbers must be treated as strings, not numbers. For
example, C<1.200> B<must not> be serialized as C<1.2>. Version
comparison should be delegated to the Perl L<version> module, version
0.80 or newer.
Unless otherwise specified, version numbers B<must> appear in one of two
formats:
=over
=item Decimal versions
Decimal versions are regular "decimal numbers", with some limitations.
They B<must> be non-negative and B<must> begin and end with a digit. A
single underscore B<may> be included, but B<must> be between two digits.
They B<must not> use exponential notation ("1.23e-2").
version => '1.234' # OK
version => '1.23_04' # OK
version => '1.23_04_05' # Illegal
version => '1.' # Illegal
version => '.1' # Illegal
=item Dotted-integer versions
Dotted-integer (also known as dotted-decimal) versions consist of
positive integers separated by full stop characters (i.e. "dots",
"periods" or "decimal points"). This are equivalent in format to Perl
"v-strings", with some additional restrictions on form. They must be
given in "normal" form, which has a leading "v" character and at least
three integer components. To retain a one-to-one mapping with decimal
versions, all components after the first B<should> be restricted to the
range 0 to 999. The final component B<may> be separated by an
underscore character instead of a period.
version => 'v1.2.3' # OK
version => 'v1.2_3' # OK
version => 'v1.2.3.4' # OK
version => 'v1.2.3_4' # OK
version => 'v2009.10.31' # OK
version => 'v1.2' # Illegal
version => '1.2.3' # Illegal
version => 'v1.2_3_4' # Illegal
version => 'v1.2009.10.31' # Not recommended
=back
=head2 Version Ranges
Some fields (prereq, optional_features) indicate the particular
version(s) of some other module that may be required as a prerequisite.
This section details the Version Range type used to provide this
information.
The simplest format for a Version Range is just the version
number itself, e.g. C<2.4>. This means that B<at least> version 2.4
must be present. To indicate that B<any> version of a prerequisite is
okay, even if the prerequisite doesn't define a version at all, use
the version C<0>.
Alternatively, a version range B<may> use the operators E<lt> (less than),
E<lt>= (less than or equal), E<gt> (greater than), E<gt>= (greater than
or equal), == (equal), and != (not equal). For example, the
specification C<E<lt> 2.0> means that any version of the prerequisite
less than 2.0 is suitable.
For more complicated situations, version specifications B<may> be AND-ed
together using commas. The specification C<E<gt>= 1.2, != 1.5, E<lt>
2.0> indicates a version that must be B<at least> 1.2, B<less than> 2.0,
and B<not equal to> 1.5.
=head1 PREREQUISITES
=head2 Prereq Spec
The C<prereqs> key in the top-level metadata and within
C<optional_features> define the relationship between a distribution and
other packages. The prereq spec structure is a hierarchical data
structure which divides prerequisites into I<Phases> of activity in the
installation process and I<Relationships> that indicate how
prerequisites should be resolved.
For example, to specify that C<Data::Dumper> is C<required> during the
C<test> phase, this entry would appear in the distribution metadata:
prereqs => {
test => {
requires => {
'Data::Dumper' => '2.00'
}
}
}
=head3 Phases
Requirements for regular use must be listed in the C<runtime> phase.
Other requirements should be listed in the earliest stage in which they
are required and consumers must accumulate and satisfy requirements
across phases before executing the activity. For example, C<build>
requirements must also be available during the C<test> phase.
before action requirements that must be met
---------------- --------------------------------
perl Build.PL configure
perl Makefile.PL
make configure, runtime, build
Build
make test configure, runtime, build, test
Build test
Consumers that install the distribution must ensure that
I<runtime> requirements are also installed and may install
dependencies from other phases.
after action requirements that must be met
---------------- --------------------------------
make install runtime
Build install
=over
=item configure
The configure phase occurs before any dynamic configuration has been
attempted. Libraries required by the configure phase B<must> be
available for use before the distribution building tool has been
executed.
=item build
The build phase is when the distribution's source code is compiled (if
necessary) and otherwise made ready for installation.
=item test
The test phase is when the distribution's automated test suite is run.
Any library that is needed only for testing and not for subsequent use
should be listed here.
=item runtime
The runtime phase refers not only to when the distribution's contents
are installed, but also to its continued use. Any library that is a
prerequisite for regular use of this distribution should be indicated
here.
=item develop
The develop phase's prereqs are libraries needed to work on the
distribution's source code as its author does. These tools might be
needed to build a release tarball, to run author-only tests, or to
perform other tasks related to developing new versions of the
distribution.
=back
=head3 Relationships
=over
=item requires
These dependencies B<must> be installed for proper completion of the
phase.
=item recommends
Recommended dependencies are I<strongly> encouraged and should be
satisfied except in resource constrained environments.
=item suggests
These dependencies are optional, but are suggested for enhanced operation
of the described distribution.
=item conflicts
These libraries cannot be installed when the phase is in operation.
This is a very rare situation, and the C<conflicts> relationship should
be used with great caution, or not at all.
=back
=head2 Merging and Resolving Prerequisites
Whenever metadata consumers merge prerequisites, either from different
phases or from C<optional_features>, they should merged in a way which
preserves the intended semantics of the prerequisite structure. Generally,
this means concatenating the version specifications using commas, as
described in the L<Version Ranges> section.
Another subtle error that can occur in resolving prerequisites comes from
the way that modules in prerequisites are indexed to distribution files on
CPAN. When a module is deleted from a distribution, prerequisites calling
for that module could indicate an older distribution should installed,
potentially overwriting files from a newer distribution.
For example, as of Oct 31, 2009, the CPAN index file contained these
module-distribution mappings:
Class::MOP 0.94 D/DR/DROLSKY/Class-MOP-0.94.tar.gz
Class::MOP::Class 0.94 D/DR/DROLSKY/Class-MOP-0.94.tar.gz
Class::MOP::Class::Immutable 0.04 S/ST/STEVAN/Class-MOP-0.36.tar.gz
Consider the case where "Class::MOP" 0.94 is installed. If a
distribution specified "Class::MOP::Class::Immutable" as a prerequisite,
it could result in Class-MOP-0.36.tar.gz being installed, overwriting
any files from Class-MOP-0.94.tar.gz.
Consumers of metadata B<should> test whether prerequisites would result
in installed module files being "downgraded" to an older version and
B<may> warn users or ignore the prerequisite that would cause such a
result.
=head1 SERIALIZATION
Distribution metadata should be serialized (as a hashref) as
JSON-encoded data and packaged with distributions as the file
F<META.json>.
In the past, the distribution metadata structure had been packed with
distributions as F<META.yml>, a file in the YAML Tiny format (for which,
see L<YAML::Tiny>). Tools that consume distribution metadata from disk
should be capable of loading F<META.yml>, but should prefer F<META.json>
if both are found.
=head1 NOTES FOR IMPLEMENTORS
=head2 Extracting Version Numbers from Perl Modules
To get the version number from a Perl module, consumers should use the
C<< MM->parse_version($file) >> method provided by
L<ExtUtils::MakeMaker> or L<Module::Metadata>. For example, for the
module given by C<$mod>, the version may be retrieved in one of the
following ways:
# via ExtUtils::MakeMaker
my $file = MM->_installed_file_for_module($mod);
my $version = MM->parse_version($file)
The private C<_installed_file_for_module> method may be replaced with
other methods for locating a module in C<@INC>.
# via Module::Metadata
my $info = Module::Metadata->new_from_module($mod);
my $version = $info->version;
If only a filename is available, the following approach may be used:
# via Module::Build
my $info = Module::Metadata->new_from_file($file);
my $version = $info->version;
=head2 Comparing Version Numbers
The L<version> module provides the most reliable way to compare version
numbers in all the various ways they might be provided or might exist
within modules. Given two strings containing version numbers, C<$v1> and
C<$v2>, they should be converted to C<version> objects before using
ordinary comparison operators. For example:
use version;
if ( version->new($v1) <=> version->new($v2) ) {
print "Versions are not equal\n";
}
If the only comparison needed is whether an installed module is of a
sufficiently high version, a direct test may be done using the string
form of C<eval> and the C<use> function. For example, for module C<$mod>
and version prerequisite C<$prereq>:
if ( eval "use $mod $prereq (); 1" ) {
print "Module $mod version is OK.\n";
}
If the values of C<$mod> and C<$prereq> have not been scrubbed, however,
this presents security implications.
=head1 SEE ALSO
CPAN, L<http://www.cpan.org/>
CPAN.pm, L<http://search.cpan.org/dist/CPAN/>
CPANPLUS, L<http://search.cpan.org/dist/CPANPLUS/>
ExtUtils::MakeMaker, L<http://search.cpan.org/dist/ExtUtils-MakeMaker/>
Module::Build, L<http://search.cpan.org/dist/Module-Build/>
Module::Install, L<http://search.cpan.org/dist/Module-Install/>
JSON, L<http://json.org/>
YAML, L<http://www.yaml.org/>
=head1 CONTRIBUTORS
Ken Williams wrote the original CPAN Meta Spec (also known as the
"META.yml spec") in 2003 and maintained it through several revisions
with input from various members of the community. In 2005, Randy
Sims redrafted it from HTML to POD for the version 1.2 release. Ken
continued to maintain the spec through version 1.4.
In late 2009, David Golden organized the version 2 proposal review
process. David and Ricardo Signes drafted the final version 2 spec
in April 2010 based on the version 1.4 spec and patches contributed
during the proposal process.
Several others have contributed patches over the years. The full list
of contributors in the repository history currently includes:
2shortplanks
Avar Arnfjord Bjarmason
Christopher J. Madsen
Damyan Ivanov
David Golden
Eric Wilhelm
Ken Williams
Lars DIECKOW
Michael G. Schwern
Randy Sims
Ricardo Signes
=head1 AUTHORS
=over 4
=item *
David Golden <dagolden@cpan.org>
=item *
Ricardo Signes <rjbs@cpan.org>
=back
=head1 CONTRIBUTORS
=over 4
=item *
Ansgar Burchardt <ansgar@cpan.org>
=item *
Avar Arnfjord Bjarmason <avar@cpan.org>
=item *
Christopher J. Madsen <cjm@cpan.org>
=item *
Cory G Watson <gphat@cpan.org>
=item *
Damyan Ivanov <dam@cpan.org>
=item *
Eric Wilhelm <ewilhelm@cpan.org>
=item *
Gregor Hermann <gregoa@debian.org>
=item *
Ken Williams <kwilliams@cpan.org>
=item *
Kenichi Ishigaki <ishigaki@cpan.org>
=item *
Lars Dieckow <daxim@cpan.org>
=item *
Leon Timmermans <leont@cpan.org>
=item *
Mark Fowler <markf@cpan.org>
=item *
Michael G. Schwern <mschwern@cpan.org>
=item *
Randy Sims <randys@thepierianspring.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
CPAN_META_SPEC
$fatpacked{"CPAN/Meta/Validator.pm"} = <<'CPAN_META_VALIDATOR';
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Validator;
our $VERSION = '2.131560'; # VERSION
#--------------------------------------------------------------------------#
# This code copied and adapted from Test::CPAN::Meta
# by Barbie, <barbie@cpan.org> for Miss Barbell Productions,
# L<http://www.missbarbell.co.uk>
#--------------------------------------------------------------------------#
#--------------------------------------------------------------------------#
# Specification Definitions
#--------------------------------------------------------------------------#
my %known_specs = (
'1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
'1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html',
'1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
'1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html',
'1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html'
);
my %known_urls = map {$known_specs{$_} => $_} keys %known_specs;
my $module_map1 = { 'map' => { ':key' => { name => \&module, value => \&exversion } } };
my $module_map2 = { 'map' => { ':key' => { name => \&module, value => \&version } } };
my $no_index_2 = {
'map' => { file => { list => { value => \&string } },
directory => { list => { value => \&string } },
'package' => { list => { value => \&string } },
namespace => { list => { value => \&string } },
':key' => { name => \&custom_2, value => \&anything },
}
};
my $no_index_1_3 = {
'map' => { file => { list => { value => \&string } },
directory => { list => { value => \&string } },
'package' => { list => { value => \&string } },
namespace => { list => { value => \&string } },
':key' => { name => \&string, value => \&anything },
}
};
my $no_index_1_2 = {
'map' => { file => { list => { value => \&string } },
dir => { list => { value => \&string } },
'package' => { list => { value => \&string } },
namespace => { list => { value => \&string } },
':key' => { name => \&string, value => \&anything },
}
};
my $no_index_1_1 = {
'map' => { ':key' => { name => \&string, list => { value => \&string } },
}
};
my $prereq_map = {
map => {
':key' => {
name => \&phase,
'map' => {
':key' => {
name => \&relation,
%$module_map1,
},
},
}
},
};
my %definitions = (
'2' => {
# REQUIRED
'abstract' => { mandatory => 1, value => \&string },
'author' => { mandatory => 1, lazylist => { value => \&string } },
'dynamic_config' => { mandatory => 1, value => \&boolean },
'generated_by' => { mandatory => 1, value => \&string },
'license' => { mandatory => 1, lazylist => { value => \&license } },
'meta-spec' => {
mandatory => 1,
'map' => {
version => { mandatory => 1, value => \&version},
url => { value => \&url },
':key' => { name => \&custom_2, value => \&anything },
}
},
'name' => { mandatory => 1, value => \&string },
'release_status' => { mandatory => 1, value => \&release_status },
'version' => { mandatory => 1, value => \&version },
# OPTIONAL
'description' => { value => \&string },
'keywords' => { lazylist => { value => \&string } },
'no_index' => $no_index_2,
'optional_features' => {
'map' => {
':key' => {
name => \&string,
'map' => {
description => { value => \&string },
prereqs => $prereq_map,
':key' => { name => \&custom_2, value => \&anything },
}
}
}
},
'prereqs' => $prereq_map,
'provides' => {
'map' => {
':key' => {
name => \&module,
'map' => {
file => { mandatory => 1, value => \&file },
version => { value => \&version },
':key' => { name => \&custom_2, value => \&anything },
}
}
}
},
'resources' => {
'map' => {
license => { lazylist => { value => \&url } },
homepage => { value => \&url },
bugtracker => {
'map' => {
web => { value => \&url },
mailto => { value => \&string},
':key' => { name => \&custom_2, value => \&anything },
}
},
repository => {
'map' => {
web => { value => \&url },
url => { value => \&url },
type => { value => \&string },
':key' => { name => \&custom_2, value => \&anything },
}
},
':key' => { value => \&string, name => \&custom_2 },
}
},
# CUSTOM -- additional user defined key/value pairs
# note we can only validate the key name, as the structure is user defined
':key' => { name => \&custom_2, value => \&anything },
},
'1.4' => {
'meta-spec' => {
mandatory => 1,
'map' => {
version => { mandatory => 1, value => \&version},
url => { mandatory => 1, value => \&urlspec },
':key' => { name => \&string, value => \&anything },
},
},
'name' => { mandatory => 1, value => \&string },
'version' => { mandatory => 1, value => \&version },
'abstract' => { mandatory => 1, value => \&string },
'author' => { mandatory => 1, list => { value => \&string } },
'license' => { mandatory => 1, value => \&license },
'generated_by' => { mandatory => 1, value => \&string },
'distribution_type' => { value => \&string },
'dynamic_config' => { value => \&boolean },
'requires' => $module_map1,
'recommends' => $module_map1,
'build_requires' => $module_map1,
'configure_requires' => $module_map1,
'conflicts' => $module_map2,
'optional_features' => {
'map' => {
':key' => { name => \&string,
'map' => { description => { value => \&string },
requires => $module_map1,
recommends => $module_map1,
build_requires => $module_map1,
conflicts => $module_map2,
':key' => { name => \&string, value => \&anything },
}
}
}
},
'provides' => {
'map' => {
':key' => { name => \&module,
'map' => {
file => { mandatory => 1, value => \&file },
version => { value => \&version },
':key' => { name => \&string, value => \&anything },
}
}
}
},
'no_index' => $no_index_1_3,
'private' => $no_index_1_3,
'keywords' => { list => { value => \&string } },
'resources' => {
'map' => { license => { value => \&url },
homepage => { value => \&url },
bugtracker => { value => \&url },
repository => { value => \&url },
':key' => { value => \&string, name => \&custom_1 },
}
},
# additional user defined key/value pairs
# note we can only validate the key name, as the structure is user defined
':key' => { name => \&string, value => \&anything },
},
'1.3' => {
'meta-spec' => {
mandatory => 1,
'map' => {
version => { mandatory => 1, value => \&version},
url => { mandatory => 1, value => \&urlspec },
':key' => { name => \&string, value => \&anything },
},
},
'name' => { mandatory => 1, value => \&string },
'version' => { mandatory => 1, value => \&version },
'abstract' => { mandatory => 1, value => \&string },
'author' => { mandatory => 1, list => { value => \&string } },
'license' => { mandatory => 1, value => \&license },
'generated_by' => { mandatory => 1, value => \&string },
'distribution_type' => { value => \&string },
'dynamic_config' => { value => \&boolean },
'requires' => $module_map1,
'recommends' => $module_map1,
'build_requires' => $module_map1,
'conflicts' => $module_map2,
'optional_features' => {
'map' => {
':key' => { name => \&string,
'map' => { description => { value => \&string },
requires => $module_map1,
recommends => $module_map1,
build_requires => $module_map1,
conflicts => $module_map2,
':key' => { name => \&string, value => \&anything },
}
}
}
},
'provides' => {
'map' => {
':key' => { name => \&module,
'map' => {
file => { mandatory => 1, value => \&file },
version => { value => \&version },
':key' => { name => \&string, value => \&anything },
}
}
}
},
'no_index' => $no_index_1_3,
'private' => $no_index_1_3,
'keywords' => { list => { value => \&string } },
'resources' => {
'map' => { license => { value => \&url },
homepage => { value => \&url },
bugtracker => { value => \&url },
repository => { value => \&url },
':key' => { value => \&string, name => \&custom_1 },
}
},
# additional user defined key/value pairs
# note we can only validate the key name, as the structure is user defined
':key' => { name => \&string, value => \&anything },
},
# v1.2 is misleading, it seems to assume that a number of fields where created
# within v1.1, when they were created within v1.2. This may have been an
# original mistake, and that a v1.1 was retro fitted into the timeline, when
# v1.2 was originally slated as v1.1. But I could be wrong ;)
'1.2' => {
'meta-spec' => {
mandatory => 1,
'map' => {
version => { mandatory => 1, value => \&version},
url => { mandatory => 1, value => \&urlspec },
':key' => { name => \&string, value => \&anything },
},
},
'name' => { mandatory => 1, value => \&string },
'version' => { mandatory => 1, value => \&version },
'license' => { mandatory => 1, value => \&license },
'generated_by' => { mandatory => 1, value => \&string },
'author' => { mandatory => 1, list => { value => \&string } },
'abstract' => { mandatory => 1, value => \&string },
'distribution_type' => { value => \&string },
'dynamic_config' => { value => \&boolean },
'keywords' => { list => { value => \&string } },
'private' => $no_index_1_2,
'$no_index' => $no_index_1_2,
'requires' => $module_map1,
'recommends' => $module_map1,
'build_requires' => $module_map1,
'conflicts' => $module_map2,
'optional_features' => {
'map' => {
':key' => { name => \&string,
'map' => { description => { value => \&string },
requires => $module_map1,
recommends => $module_map1,
build_requires => $module_map1,
conflicts => $module_map2,
':key' => { name => \&string, value => \&anything },
}
}
}
},
'provides' => {
'map' => {
':key' => { name => \&module,
'map' => {
file => { mandatory => 1, value => \&file },
version => { value => \&version },
':key' => { name => \&string, value => \&anything },
}
}
}
},
'resources' => {
'map' => { license => { value => \&url },
homepage => { value => \&url },
bugtracker => { value => \&url },
repository => { value => \&url },
':key' => { value => \&string, name => \&custom_1 },
}
},
# additional user defined key/value pairs
# note we can only validate the key name, as the structure is user defined
':key' => { name => \&string, value => \&anything },
},
# note that the 1.1 spec only specifies 'version' as mandatory
'1.1' => {
'name' => { value => \&string },
'version' => { mandatory => 1, value => \&version },
'license' => { value => \&license },
'generated_by' => { value => \&string },
'license_uri' => { value => \&url },
'distribution_type' => { value => \&string },
'dynamic_config' => { value => \&boolean },
'private' => $no_index_1_1,
'requires' => $module_map1,
'recommends' => $module_map1,
'build_requires' => $module_map1,
'conflicts' => $module_map2,
# additional user defined key/value pairs
# note we can only validate the key name, as the structure is user defined
':key' => { name => \&string, value => \&anything },
},
# note that the 1.0 spec doesn't specify optional or mandatory fields
# but we will treat version as mandatory since otherwise META 1.0 is
# completely arbitrary and pointless
'1.0' => {
'name' => { value => \&string },
'version' => { mandatory => 1, value => \&version },
'license' => { value => \&license },
'generated_by' => { value => \&string },
'license_uri' => { value => \&url },
'distribution_type' => { value => \&string },
'dynamic_config' => { value => \&boolean },
'requires' => $module_map1,
'recommends' => $module_map1,
'build_requires' => $module_map1,
'conflicts' => $module_map2,
# additional user defined key/value pairs
# note we can only validate the key name, as the structure is user defined
':key' => { name => \&string, value => \&anything },
},
);
#--------------------------------------------------------------------------#
# Code
#--------------------------------------------------------------------------#
sub new {
my ($class,$data) = @_;
# create an attributes hash
my $self = {
'data' => $data,
'spec' => $data->{'meta-spec'}{'version'} || "1.0",
'errors' => undef,
};
# create the object
return bless $self, $class;
}
sub is_valid {
my $self = shift;
my $data = $self->{data};
my $spec_version = $self->{spec};
$self->check_map($definitions{$spec_version},$data);
return ! $self->errors;
}
sub errors {
my $self = shift;
return () unless(defined $self->{errors});
return @{$self->{errors}};
}
my $spec_error = "Missing validation action in specification. "
. "Must be one of 'map', 'list', 'lazylist', or 'value'";
sub check_map {
my ($self,$spec,$data) = @_;
if(ref($spec) ne 'HASH') {
$self->_error( "Unknown META specification, cannot validate." );
return;
}
if(ref($data) ne 'HASH') {
$self->_error( "Expected a map structure from string or file." );
return;
}
for my $key (keys %$spec) {
next unless($spec->{$key}->{mandatory});
next if(defined $data->{$key});
push @{$self->{stack}}, $key;
$self->_error( "Missing mandatory field, '$key'" );
pop @{$self->{stack}};
}
for my $key (keys %$data) {
push @{$self->{stack}}, $key;
if($spec->{$key}) {
if($spec->{$key}{value}) {
$spec->{$key}{value}->($self,$key,$data->{$key});
} elsif($spec->{$key}{'map'}) {
$self->check_map($spec->{$key}{'map'},$data->{$key});
} elsif($spec->{$key}{'list'}) {
$self->check_list($spec->{$key}{'list'},$data->{$key});
} elsif($spec->{$key}{'lazylist'}) {
$self->check_lazylist($spec->{$key}{'lazylist'},$data->{$key});
} else {
$self->_error( "$spec_error for '$key'" );
}
} elsif ($spec->{':key'}) {
$spec->{':key'}{name}->($self,$key,$key);
if($spec->{':key'}{value}) {
$spec->{':key'}{value}->($self,$key,$data->{$key});
} elsif($spec->{':key'}{'map'}) {
$self->check_map($spec->{':key'}{'map'},$data->{$key});
} elsif($spec->{':key'}{'list'}) {
$self->check_list($spec->{':key'}{'list'},$data->{$key});
} elsif($spec->{':key'}{'lazylist'}) {
$self->check_lazylist($spec->{':key'}{'lazylist'},$data->{$key});
} else {
$self->_error( "$spec_error for ':key'" );
}
} else {
$self->_error( "Unknown key, '$key', found in map structure" );
}
pop @{$self->{stack}};
}
}
# if it's a string, make it into a list and check the list
sub check_lazylist {
my ($self,$spec,$data) = @_;
if ( defined $data && ! ref($data) ) {
$data = [ $data ];
}
$self->check_list($spec,$data);
}
sub check_list {
my ($self,$spec,$data) = @_;
if(ref($data) ne 'ARRAY') {
$self->_error( "Expected a list structure" );
return;
}
if(defined $spec->{mandatory}) {
if(!defined $data->[0]) {
$self->_error( "Missing entries from mandatory list" );
}
}
for my $value (@$data) {
push @{$self->{stack}}, $value || "<undef>";
if(defined $spec->{value}) {
$spec->{value}->($self,'list',$value);
} elsif(defined $spec->{'map'}) {
$self->check_map($spec->{'map'},$value);
} elsif(defined $spec->{'list'}) {
$self->check_list($spec->{'list'},$value);
} elsif(defined $spec->{'lazylist'}) {
$self->check_lazylist($spec->{'lazylist'},$value);
} elsif ($spec->{':key'}) {
$self->check_map($spec,$value);
} else {
$self->_error( "$spec_error associated with '$self->{stack}[-2]'" );
}
pop @{$self->{stack}};
}
}
sub header {
my ($self,$key,$value) = @_;
if(defined $value) {
return 1 if($value && $value =~ /^--- #YAML:1.0/);
}
$self->_error( "file does not have a valid YAML header." );
return 0;
}
sub release_status {
my ($self,$key,$value) = @_;
if(defined $value) {
my $version = $self->{data}{version} || '';
if ( $version =~ /_/ ) {
return 1 if ( $value =~ /\A(?:testing|unstable)\z/ );
$self->_error( "'$value' for '$key' is invalid for version '$version'" );
}
else {
return 1 if ( $value =~ /\A(?:stable|testing|unstable)\z/ );
$self->_error( "'$value' for '$key' is invalid" );
}
}
else {
$self->_error( "'$key' is not defined" );
}
return 0;
}
# _uri_split taken from URI::Split by Gisle Aas, Copyright 2003
sub _uri_split {
return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,;
}
sub url {
my ($self,$key,$value) = @_;
if(defined $value) {
my ($scheme, $auth, $path, $query, $frag) = _uri_split($value);
unless ( defined $scheme && length $scheme ) {
$self->_error( "'$value' for '$key' does not have a URL scheme" );
return 0;
}
unless ( defined $auth && length $auth ) {
$self->_error( "'$value' for '$key' does not have a URL authority" );
return 0;
}
return 1;
}
$value ||= '';
$self->_error( "'$value' for '$key' is not a valid URL." );
return 0;
}
sub urlspec {
my ($self,$key,$value) = @_;
if(defined $value) {
return 1 if($value && $known_specs{$self->{spec}} eq $value);
if($value && $known_urls{$value}) {
$self->_error( 'META specification URL does not match version' );
return 0;
}
}
$self->_error( 'Unknown META specification' );
return 0;
}
sub anything { return 1 }
sub string {
my ($self,$key,$value) = @_;
if(defined $value) {
return 1 if($value || $value =~ /^0$/);
}
$self->_error( "value is an undefined string" );
return 0;
}
sub string_or_undef {
my ($self,$key,$value) = @_;
return 1 unless(defined $value);
return 1 if($value || $value =~ /^0$/);
$self->_error( "No string defined for '$key'" );
return 0;
}
sub file {
my ($self,$key,$value) = @_;
return 1 if(defined $value);
$self->_error( "No file defined for '$key'" );
return 0;
}
sub exversion {
my ($self,$key,$value) = @_;
if(defined $value && ($value || $value =~ /0/)) {
my $pass = 1;
for(split(",",$value)) { $self->version($key,$_) or ($pass = 0); }
return $pass;
}
$value = '<undef>' unless(defined $value);
$self->_error( "'$value' for '$key' is not a valid version." );
return 0;
}
sub version {
my ($self,$key,$value) = @_;
if(defined $value) {
return 0 unless($value || $value =~ /0/);
return 1 if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/);
} else {
$value = '<undef>';
}
$self->_error( "'$value' for '$key' is not a valid version." );
return 0;
}
sub boolean {
my ($self,$key,$value) = @_;
if(defined $value) {
return 1 if($value =~ /^(0|1|true|false)$/);
} else {
$value = '<undef>';
}
$self->_error( "'$value' for '$key' is not a boolean value." );
return 0;
}
my %v1_licenses = (
'perl' => 'http://dev.perl.org/licenses/',
'gpl' => 'http://www.opensource.org/licenses/gpl-license.php',
'apache' => 'http://apache.org/licenses/LICENSE-2.0',
'artistic' => 'http://opensource.org/licenses/artistic-license.php',
'artistic_2' => 'http://opensource.org/licenses/artistic-license-2.0.php',
'lgpl' => 'http://www.opensource.org/licenses/lgpl-license.php',
'bsd' => 'http://www.opensource.org/licenses/bsd-license.php',
'gpl' => 'http://www.opensource.org/licenses/gpl-license.php',
'mit' => 'http://opensource.org/licenses/mit-license.php',
'mozilla' => 'http://opensource.org/licenses/mozilla1.1.php',
'open_source' => undef,
'unrestricted' => undef,
'restrictive' => undef,
'unknown' => undef,
);
my %v2_licenses = map { $_ => 1 } qw(
agpl_3
apache_1_1
apache_2_0
artistic_1
artistic_2
bsd
freebsd
gfdl_1_2
gfdl_1_3
gpl_1
gpl_2
gpl_3
lgpl_2_1
lgpl_3_0
mit
mozilla_1_0
mozilla_1_1
openssl
perl_5
qpl_1_0
ssleay
sun
zlib
open_source
restricted
unrestricted
unknown
);
sub license {
my ($self,$key,$value) = @_;
my $licenses = $self->{spec} < 2 ? \%v1_licenses : \%v2_licenses;
if(defined $value) {
return 1 if($value && exists $licenses->{$value});
} else {
$value = '<undef>';
}
$self->_error( "License '$value' is invalid" );
return 0;
}
sub custom_1 {
my ($self,$key) = @_;
if(defined $key) {
# a valid user defined key should be alphabetic
# and contain at least one capital case letter.
return 1 if($key && $key =~ /^[_a-z]+$/i && $key =~ /[A-Z]/);
} else {
$key = '<undef>';
}
$self->_error( "Custom resource '$key' must be in CamelCase." );
return 0;
}
sub custom_2 {
my ($self,$key) = @_;
if(defined $key) {
return 1 if($key && $key =~ /^x_/i); # user defined
} else {
$key = '<undef>';
}
$self->_error( "Custom key '$key' must begin with 'x_' or 'X_'." );
return 0;
}
sub identifier {
my ($self,$key) = @_;
if(defined $key) {
return 1 if($key && $key =~ /^([a-z][_a-z]+)$/i); # spec 2.0 defined
} else {
$key = '<undef>';
}
$self->_error( "Key '$key' is not a legal identifier." );
return 0;
}
sub module {
my ($self,$key) = @_;
if(defined $key) {
return 1 if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/);
} else {
$key = '<undef>';
}
$self->_error( "Key '$key' is not a legal module name." );
return 0;
}
my @valid_phases = qw/ configure build test runtime develop /;
sub phase {
my ($self,$key) = @_;
if(defined $key) {
return 1 if( length $key && grep { $key eq $_ } @valid_phases );
return 1 if $key =~ /x_/i;
} else {
$key = '<undef>';
}
$self->_error( "Key '$key' is not a legal phase." );
return 0;
}
my @valid_relations = qw/ requires recommends suggests conflicts /;
sub relation {
my ($self,$key) = @_;
if(defined $key) {
return 1 if( length $key && grep { $key eq $_ } @valid_relations );
return 1 if $key =~ /x_/i;
} else {
$key = '<undef>';
}
$self->_error( "Key '$key' is not a legal prereq relationship." );
return 0;
}
sub _error {
my $self = shift;
my $mess = shift;
$mess .= ' ('.join(' -> ',@{$self->{stack}}).')' if($self->{stack});
$mess .= " [Validation: $self->{spec}]";
push @{$self->{errors}}, $mess;
}
1;
# ABSTRACT: validate CPAN distribution metadata structures
__END__
=pod
=encoding utf-8
=head1 NAME
CPAN::Meta::Validator - validate CPAN distribution metadata structures
=head1 VERSION
version 2.131560
=head1 SYNOPSIS
my $struct = decode_json_file('META.json');
my $cmv = CPAN::Meta::Validator->new( $struct );
unless ( $cmv->is_valid ) {
my $msg = "Invalid META structure. Errors found:\n";
$msg .= join( "\n", $cmv->errors );
die $msg;
}
=head1 DESCRIPTION
This module validates a CPAN Meta structure against the version of the
the specification claimed in the C<meta-spec> field of the structure.
=head1 METHODS
=head2 new
my $cmv = CPAN::Meta::Validator->new( $struct )
The constructor must be passed a metadata structure.
=head2 is_valid
if ( $cmv->is_valid ) {
...
}
Returns a boolean value indicating whether the metadata provided
is valid.
=head2 errors
warn( join "\n", $cmv->errors );
Returns a list of errors seen during validation.
=begin :internals
=head2 Check Methods
=over
=item *
check_map($spec,$data)
Checks whether a map (or hash) part of the data structure conforms to the
appropriate specification definition.
=item *
check_list($spec,$data)
Checks whether a list (or array) part of the data structure conforms to
the appropriate specification definition.
=item *
check_lazylist($spec,$data)
Checks whether a list conforms, but converts strings to a single-element list
=back
=head2 Validator Methods
=over
=item *
header($self,$key,$value)
Validates that the header is valid.
Note: No longer used as we now read the data structure, not the file.
=item *
url($self,$key,$value)
Validates that a given value is in an acceptable URL format
=item *
urlspec($self,$key,$value)
Validates that the URL to a META specification is a known one.
=item *
string_or_undef($self,$key,$value)
Validates that the value is either a string or an undef value. Bit of a
catchall function for parts of the data structure that are completely user
defined.
=item *
string($self,$key,$value)
Validates that a string exists for the given key.
=item *
file($self,$key,$value)
Validate that a file is passed for the given key. This may be made more
thorough in the future. For now it acts like \&string.
=item *
exversion($self,$key,$value)
Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'.
=item *
version($self,$key,$value)
Validates a single version string. Versions of the type '5.8.8' and '0.00_00'
are both valid. A leading 'v' like 'v1.2.3' is also valid.
=item *
boolean($self,$key,$value)
Validates for a boolean value. Currently these values are '1', '0', 'true',
'false', however the latter 2 may be removed.
=item *
license($self,$key,$value)
Validates that a value is given for the license. Returns 1 if an known license
type, or 2 if a value is given but the license type is not a recommended one.
=item *
custom_1($self,$key,$value)
Validates that the given key is in CamelCase, to indicate a user defined
keyword and only has characters in the class [-_a-zA-Z]. In version 1.X
of the spec, this was only explicitly stated for 'resources'.
=item *
custom_2($self,$key,$value)
Validates that the given key begins with 'x_' or 'X_', to indicate a user
defined keyword and only has characters in the class [-_a-zA-Z]
=item *
identifier($self,$key,$value)
Validates that key is in an acceptable format for the META specification,
for an identifier, i.e. any that matches the regular expression
qr/[a-z][a-z_]/i.
=item *
module($self,$key,$value)
Validates that a given key is in an acceptable module name format, e.g.
'Test::CPAN::Meta::Version'.
=back
=end :internals
=for Pod::Coverage anything boolean check_lazylist check_list custom_1 custom_2 exversion file
identifier license module phase relation release_status string string_or_undef
url urlspec version header check_map
=head1 BUGS
Please report any bugs or feature using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.
=head1 AUTHORS
=over 4
=item *
David Golden <dagolden@cpan.org>
=item *
Ricardo Signes <rjbs@cpan.org>
=back
=head1 CONTRIBUTORS
=over 4
=item *
Ansgar Burchardt <ansgar@cpan.org>
=item *
Avar Arnfjord Bjarmason <avar@cpan.org>
=item *
Christopher J. Madsen <cjm@cpan.org>
=item *
Cory G Watson <gphat@cpan.org>
=item *
Damyan Ivanov <dam@cpan.org>
=item *
Eric Wilhelm <ewilhelm@cpan.org>
=item *
Gregor Hermann <gregoa@debian.org>
=item *
Ken Williams <kwilliams@cpan.org>
=item *
Kenichi Ishigaki <ishigaki@cpan.org>
=item *
Lars Dieckow <daxim@cpan.org>
=item *
Leon Timmermans <leont@cpan.org>
=item *
Mark Fowler <markf@cpan.org>
=item *
Michael G. Schwern <mschwern@cpan.org>
=item *
Randy Sims <randys@thepierianspring.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
CPAN_META_VALIDATOR
$fatpacked{"CPAN/Meta/YAML.pm"} = <<'CPAN_META_YAML';
package CPAN::Meta::YAML;
{
$CPAN::Meta::YAML::VERSION = '0.008';
}
use strict;
# UTF Support?
sub HAVE_UTF8 () { $] >= 5.007003 }
BEGIN {
if ( HAVE_UTF8 ) {
# The string eval helps hide this from Test::MinimumVersion
eval "require utf8;";
die "Failed to load UTF-8 support" if $@;
}
# Class structure
require 5.004;
require Exporter;
require Carp;
@CPAN::Meta::YAML::ISA = qw{ Exporter };
@CPAN::Meta::YAML::EXPORT = qw{ Load Dump };
@CPAN::Meta::YAML::EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };
# Error storage
$CPAN::Meta::YAML::errstr = '';
}
# The character class of all characters we need to escape
# NOTE: Inlined, since it's only used once
# my $RE_ESCAPE = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f\"\n]';
# Printed form of the unprintable characters in the lowest range
# of ASCII characters, listed by ASCII ordinal position.
my @UNPRINTABLE = qw(
z x01 x02 x03 x04 x05 x06 a
x08 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 = (
z => "\x00", a => "\x07", t => "\x09",
n => "\x0a", v => "\x0b", f => "\x0c",
r => "\x0d", e => "\x1b", '\\' => '\\',
);
# Special magic boolean words
my %QUOTE = map { $_ => 1 } qw{
null Null NULL
y Y yes Yes YES n N no No NO
true True TRUE false False FALSE
on On ON off Off OFF
};
#####################################################################
# Implementation
# Create an empty CPAN::Meta::YAML object
sub new {
my $class = shift;
bless [ @_ ], $class;
}
# Create an object from a file
sub read {
my $class = ref $_[0] ? ref shift : shift;
# Check the file
my $file = shift or return $class->_error( 'You did not specify a file name' );
return $class->_error( "File '$file' does not exist" ) unless -e $file;
return $class->_error( "'$file' is a directory, not a file" ) unless -f _;
return $class->_error( "Insufficient permissions to read '$file'" ) unless -r _;
# Slurp in the file
local $/ = undef;
local *CFG;
unless ( open(CFG, $file) ) {
return $class->_error("Failed to open file '$file': $!");
}
my $contents = <CFG>;
unless ( close(CFG) ) {
return $class->_error("Failed to close file '$file': $!");
}
$class->read_string( $contents );
}
# Create an object from a string
sub read_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";
}
# Byte order marks
# NOTE: Keeping this here to educate maintainers
# my %BOM = (
# "\357\273\277" => 'UTF-8',
# "\376\377" => 'UTF-16BE',
# "\377\376" => 'UTF-16LE',
# "\377\376\0\0" => 'UTF-32LE'
# "\0\0\376\377" => 'UTF-32BE',
# );
if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) {
die \"Stream has a non UTF-8 BOM";
} else {
# Strip UTF-8 bom if found, we'll just ignore it
$string =~ s/^\357\273\277//;
}
# Try to decode as utf8
utf8::decode($string) if HAVE_UTF8;
# Check for some special cases
return $self unless length $string;
unless ( $string =~ /[\012\015]+\z/ ) {
die \"Stream does not end with newline character";
}
# 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
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->_read_scalar( "$1", [ undef ], \@lines );
next;
}
}
if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
# A naked document
push @$self, undef;
while ( @lines and $lines[0] !~ /^---/ ) {
shift @lines;
}
} elsif ( $lines[0] =~ /^\s*\-/ ) {
# An array at the root
my $document = [ ];
push @$self, $document;
$self->_read_array( $document, [ 0 ], \@lines );
} elsif ( $lines[0] =~ /^(\s*)\S/ ) {
# A hash at the root
my $document = { };
push @$self, $document;
$self->_read_hash( $document, [ length($1) ], \@lines );
} else {
die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
}
}
};
if ( ref $@ eq 'SCALAR' ) {
return $self->_error(${$@});
} elsif ( $@ ) {
require Carp;
Carp::croak($@);
}
return $self;
}
# Deparse a scalar string to the actual scalar
sub _read_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 =~ /^\'(.*?)\'(?:\s+\#.*)?\z/ ) {
return '' unless defined $1;
$string = $1;
$string =~ s/\'\'/\'/g;
return $string;
}
# Double quote.
# 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.
# if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) {
if ( $string =~ /^\"([^\\"]*(?:\\.[^\\"]*)*)\"(?:\s+\#.*)?\z/ ) {
# Reusing the variable is a little ugly,
# but avoids a new variable and a string copy.
$string = $1;
$string =~ s/\\"/"/g;
$string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex;
return $string;
}
# 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 !~ /^[>|]/ ) {
if (
$string =~ /^(?:-(?:\s|$)|[\@\%\`])/
or
$string =~ /:(?:\s|$)/
) {
die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'";
}
$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;
}
# Parse an array
sub _read_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->_read_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
} elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
# Array entry with a value
shift @$lines;
push @$array, $self->_read_scalar( "$2", [ @$indent, undef ], $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->_read_array( $array->[-1], [ @$indent, $indent2 ], $lines );
}
} elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
push @$array, { };
$self->_read_hash( $array->[-1], [ @$indent, length("$1") ], $lines );
} else {
die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
}
} 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;
}
# Parse an array
sub _read_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]'";
}
# Get the key
unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+(?:\#.*)?|$)// ) {
if ( $lines->[0] =~ /^\s*[?\'\"]/ ) {
die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'";
}
die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
}
my $key = $1;
# Do we have a value?
if ( length $lines->[0] ) {
# Yes
$hash->{$key} = $self->_read_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->_read_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->_read_hash( $hash->{$key}, [ @$indent, length($1) ], $lines );
}
}
}
}
return 1;
}
# Save an object to a file
sub write {
my $self = shift;
my $file = shift or return $self->_error('No file name provided');
# Write it to the file
open( CFG, '>' . $file ) or return $self->_error(
"Failed to open file '$file' for writing: $!"
);
print CFG $self->write_string;
close CFG;
return 1;
}
# Save an object to a string
sub write_string {
my $self = shift;
return '' unless @$self;
# Iterate over the documents
my $indent = 0;
my @lines = ();
foreach my $cursor ( @$self ) {
push @lines, '---';
# An empty document
if ( ! defined $cursor ) {
# Do nothing
# A scalar document
} elsif ( ! ref $cursor ) {
$lines[-1] .= ' ' . $self->_write_scalar( $cursor, $indent );
# A list at the root
} elsif ( ref $cursor eq 'ARRAY' ) {
unless ( @$cursor ) {
$lines[-1] .= ' []';
next;
}
push @lines, $self->_write_array( $cursor, $indent, {} );
# A hash at the root
} elsif ( ref $cursor eq 'HASH' ) {
unless ( %$cursor ) {
$lines[-1] .= ' {}';
next;
}
push @lines, $self->_write_hash( $cursor, $indent, {} );
} else {
Carp::croak("Cannot serialize " . ref($cursor));
}
}
join '', map { "$_\n" } @lines;
}
sub _write_scalar {
my $string = $_[1];
return '~' unless defined $string;
return "''" unless length $string;
if ( $string =~ /[\x00-\x08\x0b-\x0d\x0e-\x1f\"\'\n]/ ) {
$string =~ s/\\/\\\\/g;
$string =~ s/"/\\"/g;
$string =~ s/\n/\\n/g;
$string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
return qq|"$string"|;
}
if ( $string =~ /(?:^\W|\s|:\z)/ or $QUOTE{$string} ) {
return "'$string'";
}
return $string;
}
sub _write_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->_write_scalar( $el, $indent + 1 );
push @lines, $line;
} elsif ( $type eq 'ARRAY' ) {
if ( @$el ) {
push @lines, $line;
push @lines, $self->_write_array( $el, $indent + 1, $seen );
} else {
$line .= ' []';
push @lines, $line;
}
} elsif ( $type eq 'HASH' ) {
if ( keys %$el ) {
push @lines, $line;
push @lines, $self->_write_hash( $el, $indent + 1, $seen );
} else {
$line .= ' {}';
push @lines, $line;
}
} else {
die "CPAN::Meta::YAML does not support $type references";
}
}
@lines;
}
sub _write_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) . "$name:";
my $type = ref $el;
if ( ! $type ) {
$line .= ' ' . $self->_write_scalar( $el, $indent + 1 );
push @lines, $line;
} elsif ( $type eq 'ARRAY' ) {
if ( @$el ) {
push @lines, $line;
push @lines, $self->_write_array( $el, $indent + 1, $seen );
} else {
$line .= ' []';
push @lines, $line;
}
} elsif ( $type eq 'HASH' ) {
if ( keys %$el ) {
push @lines, $line;
push @lines, $self->_write_hash( $el, $indent + 1, $seen );
} else {
$line .= ' {}';
push @lines, $line;
}
} else {
die "CPAN::Meta::YAML does not support $type references";
}
}
@lines;
}
# Set error
sub _error {
$CPAN::Meta::YAML::errstr = $_[1];
undef;
}
# Retrieve error
sub errstr {
$CPAN::Meta::YAML::errstr;
}
#####################################################################
# YAML Compatibility
sub Dump {
CPAN::Meta::YAML->new(@_)->write_string;
}
sub Load {
my $self = CPAN::Meta::YAML->read_string(@_);
unless ( $self ) {
Carp::croak("Failed to load YAML document from string");
}
if ( wantarray ) {
return @$self;
} else {
# To match YAML.pm, return the last document
return $self->[-1];
}
}
BEGIN {
*freeze = *Dump;
*thaw = *Load;
}
sub DumpFile {
my $file = shift;
CPAN::Meta::YAML->new(@_)->write($file);
}
sub LoadFile {
my $self = CPAN::Meta::YAML->read($_[0]);
unless ( $self ) {
Carp::croak("Failed to load YAML document from '" . ($_[0] || '') . "'");
}
if ( wantarray ) {
return @$self;
} else {
# Return only the last document to match YAML.pm,
return $self->[-1];
}
}
#####################################################################
# Use Scalar::Util if possible, otherwise emulate it
BEGIN {
local $@;
eval {
require Scalar::Util;
};
my $v = eval("$Scalar::Util::VERSION") || 0;
if ( $@ or $v < 1.18 ) {
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 { local $^W; hex $1 };
bless $_[0], $pkg if defined $pkg;
$i;
}
END_PERL
} else {
*refaddr = *Scalar::Util::refaddr;
}
}
1;
=pod
=head1 NAME
CPAN::Meta::YAML - Read and write a subset of YAML for CPAN Meta files
=head1 VERSION
version 0.008
=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<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=YAML-Tiny>
=head1 SEE ALSO
L<YAML::Tiny>, L<YAML>, L<YAML::XS>
=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
=head1 SUPPORT
=head2 Bugs / Feature Requests
Please report any bugs or feature requests through the issue tracker
at L<http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta-YAML>.
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/dagolden/cpan-meta-yaml>
git clone https://github.com/dagolden/cpan-meta-yaml.git
=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
CPAN_META_YAML
$fatpacked{"Exporter.pm"} = <<'EXPORTER';
package Exporter;
require 5.006;
# Be lean.
#use strict;
#no strict 'refs';
our $Debug = 0;
our $ExportLevel = 0;
our $Verbose ||= 0;
our $VERSION = '5.68';
our (%Cache);
sub as_heavy {
require Exporter::Heavy;
# Unfortunately, this does not work if the caller is aliased as *name = \&foo
# Thus the need to create a lot of identical subroutines
my $c = (caller(1))[3];
$c =~ s/.*:://;
\&{"Exporter::Heavy::heavy_$c"};
}
sub export {
goto &{as_heavy()};
}
sub import {
my $pkg = shift;
my $callpkg = caller($ExportLevel);
if ($pkg eq "Exporter" and @_ and $_[0] eq "import") {
*{$callpkg."::import"} = \&import;
return;
}
# We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-(
my $exports = \@{"$pkg\::EXPORT"};
# But, avoid creating things if they don't exist, which saves a couple of
# hundred bytes per package processed.
my $fail = ${$pkg . '::'}{EXPORT_FAIL} && \@{"$pkg\::EXPORT_FAIL"};
return export $pkg, $callpkg, @_
if $Verbose or $Debug or $fail && @$fail > 1;
my $export_cache = ($Cache{$pkg} ||= {});
my $args = @_ or @_ = @$exports;
if ($args and not %$export_cache) {
s/^&//, $export_cache->{$_} = 1
foreach (@$exports, @{"$pkg\::EXPORT_OK"});
}
my $heavy;
# Try very hard not to use {} and hence have to enter scope on the foreach
# We bomb out of the loop with last as soon as heavy is set.
if ($args or $fail) {
($heavy = (/\W/ or $args and not exists $export_cache->{$_}
or $fail and @$fail and $_ eq $fail->[0])) and last
foreach (@_);
} else {
($heavy = /\W/) and last
foreach (@_);
}
return export $pkg, $callpkg, ($args ? @_ : ()) if $heavy;
local $SIG{__WARN__} =
sub {require Carp; &Carp::carp} if not $SIG{__WARN__};
# shortcut for the common case of no type character
*{"$callpkg\::$_"} = \&{"$pkg\::$_"} foreach @_;
}
# Default methods
sub export_fail {
my $self = shift;
@_;
}
# Unfortunately, caller(1)[3] "does not work" if the caller is aliased as
# *name = \&foo. Thus the need to create a lot of identical subroutines
# Otherwise we could have aliased them to export().
sub export_to_level {
goto &{as_heavy()};
}
sub export_tags {
goto &{as_heavy()};
}
sub export_ok_tags {
goto &{as_heavy()};
}
sub require_version {
goto &{as_heavy()};
}
1;
__END__
=head1 NAME
Exporter - Implements default import method for modules
=head1 SYNOPSIS
In module F<YourModule.pm>:
package YourModule;
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(munge frobnicate); # symbols to export on request
or
package YourModule;
use Exporter 'import'; # gives you Exporter's import() method directly
@EXPORT_OK = qw(munge frobnicate); # symbols to export on request
In other files which wish to use C<YourModule>:
use YourModule qw(frobnicate); # import listed symbols
frobnicate ($left, $right) # calls YourModule::frobnicate
Take a look at L</Good Practices> for some variants
you will like to use in modern Perl code.
=head1 DESCRIPTION
The Exporter module implements an C<import> method which allows a module
to export functions and variables to its users' namespaces. Many modules
use Exporter rather than implementing their own C<import> method because
Exporter provides a highly flexible interface, with an implementation optimised
for the common case.
Perl automatically calls the C<import> method when processing a
C<use> statement for a module. Modules and C<use> are documented
in L<perlfunc> and L<perlmod>. Understanding the concept of
modules and how the C<use> statement operates is important to
understanding the Exporter.
=head2 How to Export
The arrays C<@EXPORT> and C<@EXPORT_OK> in a module hold lists of
symbols that are going to be exported into the users name space by
default, or which they can request to be exported, respectively. The
symbols can represent functions, scalars, arrays, hashes, or typeglobs.
The symbols must be given by full name with the exception that the
ampersand in front of a function is optional, e.g.
@EXPORT = qw(afunc $scalar @array); # afunc is a function
@EXPORT_OK = qw(&bfunc %hash *typeglob); # explicit prefix on &bfunc
If you are only exporting function names it is recommended to omit the
ampersand, as the implementation is faster this way.
=head2 Selecting What to Export
Do B<not> export method names!
Do B<not> export anything else by default without a good reason!
Exports pollute the namespace of the module user. If you must export
try to use C<@EXPORT_OK> in preference to C<@EXPORT> and avoid short or
common symbol names to reduce the risk of name clashes.
Generally anything not exported is still accessible from outside the
module using the C<YourModule::item_name> (or C<< $blessed_ref->method >>)
syntax. By convention you can use a leading underscore on names to
informally indicate that they are 'internal' and not for public use.
(It is actually possible to get private functions by saying:
my $subref = sub { ... };
$subref->(@args); # Call it as a function
$obj->$subref(@args); # Use it as a method
However if you use them for methods it is up to you to figure out
how to make inheritance work.)
As a general rule, if the module is trying to be object oriented
then export nothing. If it's just a collection of functions then
C<@EXPORT_OK> anything but use C<@EXPORT> with caution. For function and
method names use barewords in preference to names prefixed with
ampersands for the export lists.
Other module design guidelines can be found in L<perlmod>.
=head2 How to Import
In other files which wish to use your module there are three basic ways for
them to load your module and import its symbols:
=over 4
=item C<use YourModule;>
This imports all the symbols from YourModule's C<@EXPORT> into the namespace
of the C<use> statement.
=item C<use YourModule ();>
This causes perl to load your module but does not import any symbols.
=item C<use YourModule qw(...);>
This imports only the symbols listed by the caller into their namespace.
All listed symbols must be in your C<@EXPORT> or C<@EXPORT_OK>, else an error
occurs. The advanced export features of Exporter are accessed like this,
but with list entries that are syntactically distinct from symbol names.
=back
Unless you want to use its advanced features, this is probably all you
need to know to use Exporter.
=head1 Advanced Features
=head2 Specialised Import Lists
If any of the entries in an import list begins with !, : or / then
the list is treated as a series of specifications which either add to
or delete from the list of names to import. They are processed left to
right. Specifications are in the form:
[!]name This name only
[!]:DEFAULT All names in @EXPORT
[!]:tag All names in $EXPORT_TAGS{tag} anonymous list
[!]/pattern/ All names in @EXPORT and @EXPORT_OK which match
A leading ! indicates that matching names should be deleted from the
list of names to import. If the first specification is a deletion it
is treated as though preceded by :DEFAULT. If you just want to import
extra names in addition to the default set you will still need to
include :DEFAULT explicitly.
e.g., F<Module.pm> defines:
@EXPORT = qw(A1 A2 A3 A4 A5);
@EXPORT_OK = qw(B1 B2 B3 B4 B5);
%EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]);
Note that you cannot use tags in @EXPORT or @EXPORT_OK.
Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK.
An application using Module can say something like:
use Module qw(:DEFAULT :T2 !B3 A3);
Other examples include:
use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET);
use POSIX qw(:errno_h :termios_h !TCSADRAIN !/^EXIT/);
Remember that most patterns (using //) will need to be anchored
with a leading ^, e.g., C</^EXIT/> rather than C</EXIT/>.
You can say C<BEGIN { $Exporter::Verbose=1 }> to see how the
specifications are being processed and what is actually being imported
into modules.
=head2 Exporting Without Using Exporter's import Method
Exporter has a special method, 'export_to_level' which is used in situations
where you can't directly call Exporter's
import method. The export_to_level
method looks like:
MyPackage->export_to_level(
$where_to_export, $package, @what_to_export
);
where C<$where_to_export> is an integer telling how far up the calling stack
to export your symbols, and C<@what_to_export> is an array telling what
symbols *to* export (usually this is C<@_>). The C<$package> argument is
currently unused.
For example, suppose that you have a module, A, which already has an
import function:
package A;
@ISA = qw(Exporter);
@EXPORT_OK = qw ($b);
sub import
{
$A::b = 1; # not a very useful import method
}
and you want to Export symbol C<$A::b> back to the module that called
package A. Since Exporter relies on the import method to work, via
inheritance, as it stands Exporter::import() will never get called.
Instead, say the following:
package A;
@ISA = qw(Exporter);
@EXPORT_OK = qw ($b);
sub import
{
$A::b = 1;
A->export_to_level(1, @_);
}
This will export the symbols one level 'above' the current package - ie: to
the program or module that used package A.
Note: Be careful not to modify C<@_> at all before you call export_to_level
- or people using your package will get very unexplained results!
=head2 Exporting Without Inheriting from Exporter
By including Exporter in your C<@ISA> you inherit an Exporter's import() method
but you also inherit several other helper methods which you probably don't
want. To avoid this you can do
package YourModule;
use Exporter qw( import );
which will export Exporter's own import() method into YourModule.
Everything will work as before but you won't need to include Exporter in
C<@YourModule::ISA>.
Note: This feature was introduced in version 5.57
of Exporter, released with perl 5.8.3.
=head2 Module Version Checking
The Exporter module will convert an attempt to import a number from a
module into a call to C<< $module_name->VERSION($value) >>. This can
be used to validate that the version of the module being used is
greater than or equal to the required version.
For historical reasons, Exporter supplies a C<require_version> method that
simply delegates to C<VERSION>. Originally, before C<UNIVERSAL::VERSION>
existed, Exporter would call C<require_version>.
Since the C<UNIVERSAL::VERSION> method treats the C<$VERSION> number as
a simple numeric value it will regard version 1.10 as lower than
1.9. For this reason it is strongly recommended that you use numbers
with at least two decimal places, e.g., 1.09.
=head2 Managing Unknown Symbols
In some situations you may want to prevent certain symbols from being
exported. Typically this applies to extensions which have functions
or constants that may not exist on some systems.
The names of any symbols that cannot be exported should be listed
in the C<@EXPORT_FAIL> array.
If a module attempts to import any of these symbols the Exporter
will give the module an opportunity to handle the situation before
generating an error. The Exporter will call an export_fail method
with a list of the failed symbols:
@failed_symbols = $module_name->export_fail(@failed_symbols);
If the C<export_fail> method returns an empty list then no error is
recorded and all the requested symbols are exported. If the returned
list is not empty then an error is generated for each symbol and the
export fails. The Exporter provides a default C<export_fail> method which
simply returns the list unchanged.
Uses for the C<export_fail> method include giving better error messages
for some symbols and performing lazy architectural checks (put more
symbols into C<@EXPORT_FAIL> by default and then take them out if someone
actually tries to use them and an expensive check shows that they are
usable on that platform).
=head2 Tag Handling Utility Functions
Since the symbols listed within C<%EXPORT_TAGS> must also appear in either
C<@EXPORT> or C<@EXPORT_OK>, two utility functions are provided which allow
you to easily add tagged sets of symbols to C<@EXPORT> or C<@EXPORT_OK>:
%EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);
Exporter::export_tags('foo'); # add aa, bb and cc to @EXPORT
Exporter::export_ok_tags('bar'); # add aa, cc and dd to @EXPORT_OK
Any names which are not tags are added to C<@EXPORT> or C<@EXPORT_OK>
unchanged but will trigger a warning (with C<-w>) to avoid misspelt tags
names being silently added to C<@EXPORT> or C<@EXPORT_OK>. Future versions
may make this a fatal error.
=head2 Generating Combined Tags
If several symbol categories exist in C<%EXPORT_TAGS>, it's usually
useful to create the utility ":all" to simplify "use" statements.
The simplest way to do this is:
%EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);
# add all the other ":class" tags to the ":all" class,
# deleting duplicates
{
my %seen;
push @{$EXPORT_TAGS{all}},
grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS;
}
F<CGI.pm> creates an ":all" tag which contains some (but not really
all) of its categories. That could be done with one small
change:
# add some of the other ":class" tags to the ":all" class,
# deleting duplicates
{
my %seen;
push @{$EXPORT_TAGS{all}},
grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}}
foreach qw/html2 html3 netscape form cgi internal/;
}
Note that the tag names in C<%EXPORT_TAGS> don't have the leading ':'.
=head2 C<AUTOLOAD>ed Constants
Many modules make use of C<AUTOLOAD>ing for constant subroutines to
avoid having to compile and waste memory on rarely used values (see
L<perlsub> for details on constant subroutines). Calls to such
constant subroutines are not optimized away at compile time because
they can't be checked at compile time for constancy.
Even if a prototype is available at compile time, the body of the
subroutine is not (it hasn't been C<AUTOLOAD>ed yet). perl needs to
examine both the C<()> prototype and the body of a subroutine at
compile time to detect that it can safely replace calls to that
subroutine with the constant value.
A workaround for this is to call the constants once in a C<BEGIN> block:
package My ;
use Socket ;
foo( SO_LINGER ); ## SO_LINGER NOT optimized away; called at runtime
BEGIN { SO_LINGER }
foo( SO_LINGER ); ## SO_LINGER optimized away at compile time.
This forces the C<AUTOLOAD> for C<SO_LINGER> to take place before
SO_LINGER is encountered later in C<My> package.
If you are writing a package that C<AUTOLOAD>s, consider forcing
an C<AUTOLOAD> for any constants explicitly imported by other packages
or which are usually used when your package is C<use>d.
=head1 Good Practices
=head2 Declaring C<@EXPORT_OK> and Friends
When using C<Exporter> with the standard C<strict> and C<warnings>
pragmas, the C<our> keyword is needed to declare the package
variables C<@EXPORT_OK>, C<@EXPORT>, C<@ISA>, etc.
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(munge frobnicate);
If backward compatibility for Perls under 5.6 is important,
one must write instead a C<use vars> statement.
use vars qw(@ISA @EXPORT_OK);
@ISA = qw(Exporter);
@EXPORT_OK = qw(munge frobnicate);
=head2 Playing Safe
There are some caveats with the use of runtime statements
like C<require Exporter> and the assignment to package
variables, which can very subtle for the unaware programmer.
This may happen for instance with mutually recursive
modules, which are affected by the time the relevant
constructions are executed.
The ideal (but a bit ugly) way to never have to think
about that is to use C<BEGIN> blocks. So the first part
of the L</SYNOPSIS> code could be rewritten as:
package YourModule;
use strict;
use warnings;
our (@ISA, @EXPORT_OK);
BEGIN {
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(munge frobnicate); # symbols to export on request
}
The C<BEGIN> will assure that the loading of F<Exporter.pm>
and the assignments to C<@ISA> and C<@EXPORT_OK> happen
immediately, leaving no room for something to get awry
or just plain wrong.
With respect to loading C<Exporter> and inheriting, there
are alternatives with the use of modules like C<base> and C<parent>.
use base qw( Exporter );
# or
use parent qw( Exporter );
Any of these statements are nice replacements for
C<BEGIN { require Exporter; @ISA = qw(Exporter); }>
with the same compile-time effect. The basic difference
is that C<base> code interacts with declared C<fields>
while C<parent> is a streamlined version of the older
C<base> code to just establish the IS-A relationship.
For more details, see the documentation and code of
L<base> and L<parent>.
Another thorough remedy to that runtime
vs. compile-time trap is to use L<Exporter::Easy>,
which is a wrapper of Exporter that allows all
boilerplate code at a single gulp in the
use statement.
use Exporter::Easy (
OK => [ qw(munge frobnicate) ],
);
# @ISA setup is automatic
# all assignments happen at compile time
=head2 What Not to Export
You have been warned already in L</Selecting What to Export>
to not export:
=over 4
=item *
method names (because you don't need to
and that's likely to not do what you want),
=item *
anything by default (because you don't want to surprise your users...
badly)
=item *
anything you don't need to (because less is more)
=back
There's one more item to add to this list. Do B<not>
export variable names. Just because C<Exporter> lets you
do that, it does not mean you should.
@EXPORT_OK = qw( $svar @avar %hvar ); # DON'T!
Exporting variables is not a good idea. They can
change under the hood, provoking horrible
effects at-a-distance, that are too hard to track
and to fix. Trust me: they are not worth it.
To provide the capability to set/get class-wide
settings, it is best instead to provide accessors
as subroutines or class methods instead.
=head1 SEE ALSO
C<Exporter> is definitely not the only module with
symbol exporter capabilities. At CPAN, you may find
a bunch of them. Some are lighter. Some
provide improved APIs and features. Peek the one
that fits your needs. The following is
a sample list of such modules.
Exporter::Easy
Exporter::Lite
Exporter::Renaming
Exporter::Tidy
Sub::Exporter / Sub::Installer
Perl6::Export / Perl6::Export::Attrs
=head1 LICENSE
This library is free software. You can redistribute it
and/or modify it under the same terms as Perl itself.
=cut
EXPORTER
$fatpacked{"Exporter/Heavy.pm"} = <<'EXPORTER_HEAVY';
package Exporter::Heavy;
use strict;
no strict 'refs';
# On one line so MakeMaker will see it.
require Exporter; our $VERSION = $Exporter::VERSION;
=head1 NAME
Exporter::Heavy - Exporter guts
=head1 SYNOPSIS
(internal use only)
=head1 DESCRIPTION
No user-serviceable parts inside.
=cut
#
# We go to a lot of trouble not to 'require Carp' at file scope,
# because Carp requires Exporter, and something has to give.
#
sub _rebuild_cache {
my ($pkg, $exports, $cache) = @_;
s/^&// foreach @$exports;
@{$cache}{@$exports} = (1) x @$exports;
my $ok = \@{"${pkg}::EXPORT_OK"};
if (@$ok) {
s/^&// foreach @$ok;
@{$cache}{@$ok} = (1) x @$ok;
}
}
sub heavy_export {
# First make import warnings look like they're coming from the "use".
local $SIG{__WARN__} = sub {
my $text = shift;
if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) {
require Carp;
local $Carp::CarpLevel = 1; # ignore package calling us too.
Carp::carp($text);
}
else {
warn $text;
}
};
local $SIG{__DIE__} = sub {
require Carp;
local $Carp::CarpLevel = 1; # ignore package calling us too.
Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")
if $_[0] =~ /^Unable to create sub named "(.*?)::"/;
};
my($pkg, $callpkg, @imports) = @_;
my($type, $sym, $cache_is_current, $oops);
my($exports, $export_cache) = (\@{"${pkg}::EXPORT"},
$Exporter::Cache{$pkg} ||= {});
if (@imports) {
if (!%$export_cache) {
_rebuild_cache ($pkg, $exports, $export_cache);
$cache_is_current = 1;
}
if (grep m{^[/!:]}, @imports) {
my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
my $tagdata;
my %imports;
my($remove, $spec, @names, @allexports);
# negated first item implies starting with default set:
unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/;
foreach $spec (@imports){
$remove = $spec =~ s/^!//;
if ($spec =~ s/^://){
if ($spec eq 'DEFAULT'){
@names = @$exports;
}
elsif ($tagdata = $tagsref->{$spec}) {
@names = @$tagdata;
}
else {
warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];
++$oops;
next;
}
}
elsif ($spec =~ m:^/(.*)/$:){
my $patn = $1;
@allexports = keys %$export_cache unless @allexports; # only do keys once
@names = grep(/$patn/, @allexports); # not anchored by default
}
else {
@names = ($spec); # is a normal symbol name
}
warn "Import ".($remove ? "del":"add").": @names "
if $Exporter::Verbose;
if ($remove) {
foreach $sym (@names) { delete $imports{$sym} }
}
else {
@imports{@names} = (1) x @names;
}
}
@imports = keys %imports;
}
my @carp;
foreach $sym (@imports) {
if (!$export_cache->{$sym}) {
if ($sym =~ m/^\d/) {
$pkg->VERSION($sym); # inherit from UNIVERSAL
# If the version number was the only thing specified
# then we should act as if nothing was specified:
if (@imports == 1) {
@imports = @$exports;
last;
}
# We need a way to emulate 'use Foo ()' but still
# allow an easy version check: "use Foo 1.23, ''";
if (@imports == 2 and !$imports[1]) {
@imports = ();
last;
}
} elsif ($sym !~ s/^&// || !$export_cache->{$sym}) {
# Last chance - see if they've updated EXPORT_OK since we
# cached it.
unless ($cache_is_current) {
%$export_cache = ();
_rebuild_cache ($pkg, $exports, $export_cache);
$cache_is_current = 1;
}
if (!$export_cache->{$sym}) {
# accumulate the non-exports
push @carp,
qq["$sym" is not exported by the $pkg module\n];
$oops++;
}
}
}
}
if ($oops) {
require Carp;
Carp::croak("@{carp}Can't continue after import errors");
}
}
else {
@imports = @$exports;
}
my($fail, $fail_cache) = (\@{"${pkg}::EXPORT_FAIL"},
$Exporter::FailCache{$pkg} ||= {});
if (@$fail) {
if (!%$fail_cache) {
# Build cache of symbols. Optimise the lookup by adding
# barewords twice... both with and without a leading &.
# (Technique could be applied to $export_cache at cost of memory)
my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @$fail;
warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Exporter::Verbose;
@{$fail_cache}{@expanded} = (1) x @expanded;
}
my @failed;
foreach $sym (@imports) { push(@failed, $sym) if $fail_cache->{$sym} }
if (@failed) {
@failed = $pkg->export_fail(@failed);
foreach $sym (@failed) {
require Carp;
Carp::carp(qq["$sym" is not implemented by the $pkg module ],
"on this architecture");
}
if (@failed) {
require Carp;
Carp::croak("Can't continue after import errors");
}
}
}
warn "Importing into $callpkg from $pkg: ",
join(", ",sort @imports) if $Exporter::Verbose;
foreach $sym (@imports) {
# shortcut for the common case of no type character
(*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next)
unless $sym =~ s/^(\W)//;
$type = $1;
no warnings 'once';
*{"${callpkg}::$sym"} =
$type eq '&' ? \&{"${pkg}::$sym"} :
$type eq '$' ? \${"${pkg}::$sym"} :
$type eq '@' ? \@{"${pkg}::$sym"} :
$type eq '%' ? \%{"${pkg}::$sym"} :
$type eq '*' ? *{"${pkg}::$sym"} :
do { require Carp; Carp::croak("Can't export symbol: $type$sym") };
}
}
sub heavy_export_to_level
{
my $pkg = shift;
my $level = shift;
(undef) = shift; # XXX redundant arg
my $callpkg = caller($level);
$pkg->export($callpkg, @_);
}
# Utility functions
sub _push_tags {
my($pkg, $var, $syms) = @_;
my @nontag = ();
my $export_tags = \%{"${pkg}::EXPORT_TAGS"};
push(@{"${pkg}::$var"},
map { $export_tags->{$_} ? @{$export_tags->{$_}}
: scalar(push(@nontag,$_),$_) }
(@$syms) ? @$syms : keys %$export_tags);
if (@nontag and $^W) {
# This may change to a die one day
require Carp;
Carp::carp(join(", ", @nontag)." are not tags of $pkg");
}
}
sub heavy_require_version {
my($self, $wanted) = @_;
my $pkg = ref $self || $self;
return ${pkg}->VERSION($wanted);
}
sub heavy_export_tags {
_push_tags((caller)[0], "EXPORT", \@_);
}
sub heavy_export_ok_tags {
_push_tags((caller)[0], "EXPORT_OK", \@_);
}
1;
EXPORTER_HEAVY
$fatpacked{"File/pushd.pm"} = <<'FILE_PUSHD';
use strict;
use warnings;
package File::pushd;
# ABSTRACT: change directory temporarily for a limited scope
our $VERSION = '1.005'; # VERSION
our @EXPORT = qw( pushd tempd );
our @ISA = qw( Exporter );
use Exporter;
use Carp;
use Cwd qw( getcwd abs_path );
use File::Path qw( rmtree );
use File::Temp qw();
use File::Spec;
use overload
q{""} => sub { File::Spec->canonpath( $_[0]->{_pushd} ) },
fallback => 1;
#--------------------------------------------------------------------------#
# pushd()
#--------------------------------------------------------------------------#
sub pushd {
my ($target_dir, $options) = @_;
$options->{untaint_pattern} ||= qr{^([-+@\w./]+)$};
$target_dir = "." unless defined $target_dir;
croak "Can't locate directory $target_dir" unless -d $target_dir;
my $tainted_orig = getcwd;
my $orig;
if ( $tainted_orig =~ $options->{untaint_pattern} ) {
$orig = $1;
}
else {
$orig = $tainted_orig;
}
my $tainted_dest;
eval { $tainted_dest = $target_dir ? abs_path( $target_dir ) : $orig };
croak "Can't locate absolute path for $target_dir: $@" if $@;
my $dest;
if ( $tainted_dest =~ $options->{untaint_pattern} ) {
$dest = $1;
}
else {
$dest = $tainted_dest;
}
if ($dest ne $orig) {
chdir $dest or croak "Can't chdir to $dest\: $!";
}
my $self = bless {
_pushd => $dest,
_original => $orig
}, __PACKAGE__;
return $self;
}
#--------------------------------------------------------------------------#
# tempd()
#--------------------------------------------------------------------------#
sub tempd {
my ($options) = @_;
my $dir;
eval { $dir = pushd( File::Temp::tempdir( CLEANUP => 0 ), $options ) };
croak $@ if $@;
$dir->{_tempd} = 1;
return $dir;
}
#--------------------------------------------------------------------------#
# preserve()
#--------------------------------------------------------------------------#
sub preserve {
my $self = shift;
return 1 if ! $self->{"_tempd"};
if ( @_ == 0 ) {
return $self->{_preserve} = 1;
}
else {
return $self->{_preserve} = $_[0] ? 1 : 0;
}
}
#--------------------------------------------------------------------------#
# DESTROY()
# Revert to original directory as object is destroyed and cleanup
# if necessary
#--------------------------------------------------------------------------#
sub DESTROY {
my ($self) = @_;
my $orig = $self->{_original};
chdir $orig if $orig; # should always be so, but just in case...
if ( $self->{_tempd} &&
!$self->{_preserve} ) {
# don't destroy existing $@ if there is no error.
my $err = do {
local $@;
eval { rmtree( $self->{_pushd} ) };
$@;
};
carp $err if $err;
}
}
1;
__END__
=pod
=head1 NAME
File::pushd - change directory temporarily for a limited scope
=head1 VERSION
version 1.005
=head1 SYNOPSIS
use File::pushd;
chdir $ENV{HOME};
# change directory again for a limited scope
{
my $dir = pushd( '/tmp' );
# working directory changed to /tmp
}
# working directory has reverted to $ENV{HOME}
# tempd() is equivalent to pushd( File::Temp::tempdir )
{
my $dir = tempd();
}
# object stringifies naturally as an absolute path
{
my $dir = pushd( '/tmp' );
my $filename = File::Spec->catfile( $dir, "somefile.txt" );
# gives /tmp/somefile.txt
}
=head1 DESCRIPTION
File::pushd does a temporary C<<< chdir >>> that is easily and automatically
reverted, similar to C<<< pushd >>> in some Unix command shells. It works by
creating an object that caches the original working directory. When the object
is destroyed, the destructor calls C<<< chdir >>> to revert to the original working
directory. By storing the object in a lexical variable with a limited scope,
this happens automatically at the end of the scope.
This is very handy when working with temporary directories for tasks like
testing; a function is provided to streamline getting a temporary
directory from L<File::Temp>.
For convenience, the object stringifies as the canonical form of the absolute
pathname of the directory entered.
=head1 USAGE
use File::pushd;
Using File::pushd automatically imports the C<<< pushd >>> and C<<< tempd >>> functions.
=head2 pushd
{
my $dir = pushd( $target_directory );
}
Caches the current working directory, calls C<<< chdir >>> to change to the target
directory, and returns a File::pushd object. When the object is
destroyed, the working directory reverts to the original directory.
The provided target directory can be a relative or absolute path. If
called with no arguments, it uses the current directory as its target and
returns to the current directory when the object is destroyed.
If the target directory does not exist or if the directory change fails
for some reason, C<<< pushd >>> will die with an error message.
Can be given a hashref as an optional second argument. The only supported
option is C<<< untaint_pattern >>>, which is used to untaint file paths involved.
It defaults to C<<< qr{^([-+@\w./]+)$} >>>, which is reasonably restrictive (e.g.
it does not even allow spaces in the path). Change this to suit your
circumstances and security needs if running under taint mode. B<Note>: you
must include the parentheses in the pattern to capture the untainted
portion of the path.
=head2 tempd
{
my $dir = tempd();
}
This function is like C<<< pushd >>> but automatically creates and calls C<<< chdir >>> to
a temporary directory created by L<File::Temp>. Unlike normal L<File::Temp>
cleanup which happens at the end of the program, this temporary directory is
removed when the object is destroyed. (But also see C<<< preserve >>>.) A warning
will be issued if the directory cannot be removed.
As with C<<< pushd >>>, C<<< tempd >>> will die if C<<< chdir >>> fails.
It may be given a single options hash that will be passed internally
to CE<lt>pushdE<gt>.
=head2 preserve
{
my $dir = tempd();
$dir->preserve; # mark to preserve at end of scope
$dir->preserve(0); # mark to delete at end of scope
}
Controls whether a temporary directory will be cleaned up when the object is
destroyed. With no arguments, C<<< preserve >>> sets the directory to be preserved.
With an argument, the directory will be preserved if the argument is true, or
marked for cleanup if the argument is false. Only C<<< tempd >>> objects may be
marked for cleanup. (Target directories to C<<< pushd >>> are always preserved.)
C<<< preserve >>> returns true if the directory will be preserved, and false
otherwise.
=head1 SEE ALSO
=over
=item *
L<File::chdir>
=back
=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
=head1 SUPPORT
=head2 Bugs / Feature Requests
Please report any bugs or feature requests through the issue tracker
at L<https://github.com/dagolden/file-pushd/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/dagolden/file-pushd>
git clone git://github.com/dagolden/file-pushd.git
=head1 AUTHOR
David Golden <dagolden@cpan.org>
=head1 CONTRIBUTOR
Diab Jerius <djerius@cfa.harvard.edu>
=head1 COPYRIGHT AND LICENSE
This software is Copyright (c) 2013 by David A Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
FILE_PUSHD
$fatpacked{"HTTP/Tiny.pm"} = <<'HTTP_TINY';
# vim: ts=4 sts=4 sw=4 et:
package HTTP::Tiny;
use strict;
use warnings;
# ABSTRACT: A small, simple, correct HTTP/1.1 client
our $VERSION = '0.034'; # VERSION
use Carp ();
my @attributes;
BEGIN {
@attributes = qw(cookie_jar default_headers local_address max_redirect max_size proxy no_proxy timeout SSL_options verify_SSL);
no strict 'refs';
for my $accessor ( @attributes ) {
*{$accessor} = sub {
@_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
};
}
}
sub agent {
my($self, $agent) = @_;
if( @_ > 1 ){
$self->{agent} =
(defined $agent && $agent =~ / $/) ? $agent . $self->_agent : $agent;
}
return $self->{agent};
}
sub new {
my($class, %args) = @_;
my $self = {
max_redirect => 5,
timeout => 60,
verify_SSL => $args{verify_SSL} || $args{verify_ssl} || 0, # no verification by default
no_proxy => $ENV{no_proxy},
};
bless $self, $class;
$class->_validate_cookie_jar( $args{cookie_jar} ) if $args{cookie_jar};
for my $key ( @attributes ) {
$self->{$key} = $args{$key} if exists $args{$key}
}
$self->agent( exists $args{agent} ? $args{agent} : $class->_agent );
# Never override proxy argument as this breaks backwards compat.
if (!exists $self->{proxy} && (my $http_proxy = $ENV{http_proxy})) {
if ($http_proxy =~ m{\Ahttp://[^/?#:@]+:\d+/?\z}) {
$self->{proxy} = $http_proxy;
}
else {
Carp::croak(qq{Environment 'http_proxy' must be in format http://<host>:<port>/\n});
}
}
# Split no_proxy to array reference if not provided as such
unless ( ref $self->{no_proxy} eq 'ARRAY' ) {
$self->{no_proxy} =
(defined $self->{no_proxy}) ? [ split /\s*,\s*/, $self->{no_proxy} ] : [];
}
return $self;
}
for my $sub_name ( qw/get head put post delete/ ) {
my $req_method = uc $sub_name;
no strict 'refs';
eval <<"HERE"; ## no critic
sub $sub_name {
my (\$self, \$url, \$args) = \@_;
\@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH')
or Carp::croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n");
return \$self->request('$req_method', \$url, \$args || {});
}
HERE
}
sub post_form {
my ($self, $url, $data, $args) = @_;
(@_ == 3 || @_ == 4 && ref $args eq 'HASH')
or Carp::croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ . "\n");
my $headers = {};
while ( my ($key, $value) = each %{$args->{headers} || {}} ) {
$headers->{lc $key} = $value;
}
delete $args->{headers};
return $self->request('POST', $url, {
%$args,
content => $self->www_form_urlencode($data),
headers => {
%$headers,
'content-type' => 'application/x-www-form-urlencoded'
},
}
);
}
sub mirror {
my ($self, $url, $file, $args) = @_;
@_ == 3 || (@_ == 4 && ref $args eq 'HASH')
or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ . "\n");
if ( -e $file and my $mtime = (stat($file))[9] ) {
$args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime);
}
my $tempfile = $file . int(rand(2**31));
open my $fh, ">", $tempfile
or Carp::croak(qq/Error: Could not open temporary file $tempfile for downloading: $!\n/);
binmode $fh;
$args->{data_callback} = sub { print {$fh} $_[0] };
my $response = $self->request('GET', $url, $args);
close $fh
or Carp::croak(qq/Error: Could not close temporary file $tempfile: $!\n/);
if ( $response->{success} ) {
rename $tempfile, $file
or Carp::croak(qq/Error replacing $file with $tempfile: $!\n/);
my $lm = $response->{headers}{'last-modified'};
if ( $lm and my $mtime = $self->_parse_http_date($lm) ) {
utime $mtime, $mtime, $file;
}
}
$response->{success} ||= $response->{status} eq '304';
unlink $tempfile;
return $response;
}
my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/;
sub request {
my ($self, $method, $url, $args) = @_;
@_ == 3 || (@_ == 4 && ref $args eq 'HASH')
or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ . "\n");
$args ||= {}; # we keep some state in this during _request
# RFC 2616 Section 8.1.4 mandates a single retry on broken socket
my $response;
for ( 0 .. 1 ) {
$response = eval { $self->_request($method, $url, $args) };
last unless $@ && $idempotent{$method}
&& $@ =~ m{^(?:Socket closed|Unexpected end)};
}
if (my $e = "$@") {
$response = {
url => $url,
success => q{},
status => 599,
reason => 'Internal Exception',
content => $e,
headers => {
'content-type' => 'text/plain',
'content-length' => length $e,
}
};
}
return $response;
}
sub www_form_urlencode {
my ($self, $data) = @_;
(@_ == 2 && ref $data)
or Carp::croak(q/Usage: $http->www_form_urlencode(DATAREF)/ . "\n");
(ref $data eq 'HASH' || ref $data eq 'ARRAY')
or Carp::croak("form data must be a hash or array reference\n");
my @params = ref $data eq 'HASH' ? %$data : @$data;
@params % 2 == 0
or Carp::croak("form data reference must have an even number of terms\n");
my @terms;
while( @params ) {
my ($key, $value) = splice(@params, 0, 2);
if ( ref $value eq 'ARRAY' ) {
unshift @params, map { $key => $_ } @$value;
}
else {
push @terms, join("=", map { $self->_uri_escape($_) } $key, $value);
}
}
return join("&", sort @terms);
}
#--------------------------------------------------------------------------#
# private methods
#--------------------------------------------------------------------------#
my %DefaultPort = (
http => 80,
https => 443,
);
sub _agent {
my $class = ref($_[0]) || $_[0];
(my $default_agent = $class) =~ s{::}{-}g;
return $default_agent . "/" . ($class->VERSION || 0);
}
sub _request {
my ($self, $method, $url, $args) = @_;
my ($scheme, $host, $port, $path_query, $auth) = $self->_split_url($url);
my $request = {
method => $method,
scheme => $scheme,
host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
uri => $path_query,
headers => {},
};
my $handle = HTTP::Tiny::Handle->new(
timeout => $self->{timeout},
SSL_options => $self->{SSL_options},
verify_SSL => $self->{verify_SSL},
local_address => $self->{local_address},
);
if ($self->{proxy} && ! grep { $host =~ /\Q$_\E$/ } @{$self->{no_proxy}}) {
$request->{uri} = "$scheme://$request->{host_port}$path_query";
die(qq/HTTPS via proxy is not supported\n/)
if $request->{scheme} eq 'https';
$handle->connect(($self->_split_url($self->{proxy}))[0..2]);
}
else {
$handle->connect($scheme, $host, $port);
}
$self->_prepare_headers_and_cb($request, $args, $url, $auth);
$handle->write_request($request);
my $response;
do { $response = $handle->read_response_header }
until (substr($response->{status},0,1) ne '1');
$self->_update_cookie_jar( $url, $response ) if $self->{cookie_jar};
if ( my @redir_args = $self->_maybe_redirect($request, $response, $args) ) {
$handle->close;
return $self->_request(@redir_args, $args);
}
if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) {
# response has no message body
}
else {
my $data_cb = $self->_prepare_data_cb($response, $args);
$handle->read_body($data_cb, $response);
}
$handle->close;
$response->{success} = substr($response->{status},0,1) eq '2';
$response->{url} = $url;
return $response;
}
sub _prepare_headers_and_cb {
my ($self, $request, $args, $url, $auth) = @_;
for ($self->{default_headers}, $args->{headers}) {
next unless defined;
while (my ($k, $v) = each %$_) {
$request->{headers}{lc $k} = $v;
}
}
$request->{headers}{'host'} = $request->{host_port};
$request->{headers}{'connection'} = "close";
$request->{headers}{'user-agent'} ||= $self->{agent};
if ( defined $args->{content} ) {
if (ref $args->{content} eq 'CODE') {
$request->{headers}{'content-type'} ||= "application/octet-stream";
$request->{headers}{'transfer-encoding'} = 'chunked'
unless $request->{headers}{'content-length'}
|| $request->{headers}{'transfer-encoding'};
$request->{cb} = $args->{content};
}
elsif ( length $args->{content} ) {
my $content = $args->{content};
if ( $] ge '5.008' ) {
utf8::downgrade($content, 1)
or die(qq/Wide character in request message body\n/);
}
$request->{headers}{'content-type'} ||= "application/octet-stream";
$request->{headers}{'content-length'} = length $content
unless $request->{headers}{'content-length'}
|| $request->{headers}{'transfer-encoding'};
$request->{cb} = sub { substr $content, 0, length $content, '' };
}
$request->{trailer_cb} = $args->{trailer_callback}
if ref $args->{trailer_callback} eq 'CODE';
}
### If we have a cookie jar, then maybe add relevant cookies
if ( $self->{cookie_jar} ) {
my $cookies = $self->cookie_jar->cookie_header( $url );
$request->{headers}{cookie} = $cookies if length $cookies;
}
# if we have Basic auth parameters, add them
if ( length $auth && ! defined $request->{headers}{authentication} ) {
require MIME::Base64;
$request->{headers}{authorization} =
"Basic " . MIME::Base64::encode_base64($auth, "");
}
return;
}
sub _prepare_data_cb {
my ($self, $response, $args) = @_;
my $data_cb = $args->{data_callback};
$response->{content} = '';
if (!$data_cb || $response->{status} !~ /^2/) {
if (defined $self->{max_size}) {
$data_cb = sub {
$_[1]->{content} .= $_[0];
die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/)
if length $_[1]->{content} > $self->{max_size};
};
}
else {
$data_cb = sub { $_[1]->{content} .= $_[0] };
}
}
return $data_cb;
}
sub _update_cookie_jar {
my ($self, $url, $response) = @_;
my $cookies = $response->{headers}->{'set-cookie'};
return unless defined $cookies;
my @cookies = ref $cookies ? @$cookies : $cookies;
$self->cookie_jar->add( $url, $_ ) for @cookies;
return;
}
sub _validate_cookie_jar {
my ($class, $jar) = @_;
# duck typing
for my $method ( qw/add cookie_header/ ) {
Carp::croak(qq/Cookie jar must provide the '$method' method\n/)
unless ref($jar) && ref($jar)->can($method);
}
return;
}
sub _maybe_redirect {
my ($self, $request, $response, $args) = @_;
my $headers = $response->{headers};
my ($status, $method) = ($response->{status}, $request->{method});
if (($status eq '303' or ($status =~ /^30[127]/ && $method =~ /^GET|HEAD$/))
and $headers->{location}
and ++$args->{redirects} <= $self->{max_redirect}
) {
my $location = ($headers->{location} =~ /^\//)
? "$request->{scheme}://$request->{host_port}$headers->{location}"
: $headers->{location} ;
return (($status eq '303' ? 'GET' : $method), $location);
}
return;
}
sub _split_url {
my $url = pop;
# URI regex adapted from the URI module
my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
or die(qq/Cannot parse URL: '$url'\n/);
$scheme = lc $scheme;
$path_query = "/$path_query" unless $path_query =~ m<\A/>;
my ($auth,$host);
$authority = (length($authority)) ? $authority : 'localhost';
if ( $authority =~ /@/ ) {
($auth,$host) = $authority =~ m/\A([^@]*)@(.*)\z/; # user:pass@host
}
else {
$host = $authority;
$auth = '';
}
$host = lc $host;
my $port = do {
$host =~ s/:([0-9]*)\z// && length $1
? $1
: ($scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef);
};
return ($scheme, $host, $port, $path_query, $auth);
}
# Date conversions adapted from HTTP::Date
my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat";
my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec";
sub _http_date {
my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[1]);
return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
substr($DoW,$wday*4,3),
$mday, substr($MoY,$mon*4,3), $year+1900,
$hour, $min, $sec
);
}
sub _parse_http_date {
my ($self, $str) = @_;
require Time::Local;
my @tl_parts;
if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) {
@tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
}
elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) {
@tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
}
elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) {
@tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6);
}
return eval {
my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1;
$t < 0 ? undef : $t;
};
}
# URI escaping adapted from URI::Escape
# c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1
# perl 5.6 ready UTF-8 encoding adapted from JSON::PP
my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
$escapes{' '}="+";
my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/;
sub _uri_escape {
my ($self, $str) = @_;
if ( $] ge '5.008' ) {
utf8::encode($str);
}
else {
$str = pack("U*", unpack("C*", $str)) # UTF-8 encode a byte string
if ( length $str == do { use bytes; length $str } );
$str = pack("C*", unpack("C*", $str)); # clear UTF-8 flag
}
$str =~ s/($unsafe_char)/$escapes{$1}/ge;
return $str;
}
package
HTTP::Tiny::Handle; # hide from PAUSE/indexers
use strict;
use warnings;
use Errno qw[EINTR EPIPE];
use IO::Socket qw[SOCK_STREAM];
sub BUFSIZE () { 32768 } ## no critic
my $Printable = sub {
local $_ = shift;
s/\r/\\r/g;
s/\n/\\n/g;
s/\t/\\t/g;
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
$_;
};
my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
sub new {
my ($class, %args) = @_;
return bless {
rbuf => '',
timeout => 60,
max_line_size => 16384,
max_header_lines => 64,
verify_SSL => 0,
SSL_options => {},
%args
}, $class;
}
sub connect {
@_ == 4 || die(q/Usage: $handle->connect(scheme, host, port)/ . "\n");
my ($self, $scheme, $host, $port) = @_;
if ( $scheme eq 'https' ) {
# Need IO::Socket::SSL 1.42 for SSL_create_ctx_callback
die(qq/IO::Socket::SSL 1.42 must be installed for https support\n/)
unless eval {require IO::Socket::SSL; IO::Socket::SSL->VERSION(1.42)};
# Need Net::SSLeay 1.49 for MODE_AUTO_RETRY
die(qq/Net::SSLeay 1.49 must be installed for https support\n/)
unless eval {require Net::SSLeay; Net::SSLeay->VERSION(1.49)};
}
elsif ( $scheme ne 'http' ) {
die(qq/Unsupported URL scheme '$scheme'\n/);
}
$self->{fh} = 'IO::Socket::INET'->new(
PeerHost => $host,
PeerPort => $port,
$self->{local_address} ?
( LocalAddr => $self->{local_address} ) : (),
Proto => 'tcp',
Type => SOCK_STREAM,
Timeout => $self->{timeout}
) or die(qq/Could not connect to '$host:$port': $@\n/);
binmode($self->{fh})
or die(qq/Could not binmode() socket: '$!'\n/);
if ( $scheme eq 'https') {
my $ssl_args = $self->_ssl_args($host);
IO::Socket::SSL->start_SSL(
$self->{fh},
%$ssl_args,
SSL_create_ctx_callback => sub {
my $ctx = shift;
Net::SSLeay::CTX_set_mode($ctx, Net::SSLeay::MODE_AUTO_RETRY());
},
);
unless ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
my $ssl_err = IO::Socket::SSL->errstr;
die(qq/SSL connection failed for $host: $ssl_err\n/);
}
}
$self->{host} = $host;
$self->{port} = $port;
return $self;
}
sub close {
@_ == 1 || die(q/Usage: $handle->close()/ . "\n");
my ($self) = @_;
CORE::close($self->{fh})
or die(qq/Could not close socket: '$!'\n/);
}
sub write {
@_ == 2 || die(q/Usage: $handle->write(buf)/ . "\n");
my ($self, $buf) = @_;
if ( $] ge '5.008' ) {
utf8::downgrade($buf, 1)
or die(qq/Wide character in write()\n/);
}
my $len = length $buf;
my $off = 0;
local $SIG{PIPE} = 'IGNORE';
while () {
$self->can_write
or die(qq/Timed out while waiting for socket to become ready for writing\n/);
my $r = syswrite($self->{fh}, $buf, $len, $off);
if (defined $r) {
$len -= $r;
$off += $r;
last unless $len > 0;
}
elsif ($! == EPIPE) {
die(qq/Socket closed by remote server: $!\n/);
}
elsif ($! != EINTR) {
if ($self->{fh}->can('errstr')){
my $err = $self->{fh}->errstr();
die (qq/Could not write to SSL socket: '$err'\n /);
}
else {
die(qq/Could not write to socket: '$!'\n/);
}
}
}
return $off;
}
sub read {
@_ == 2 || @_ == 3 || die(q/Usage: $handle->read(len [, allow_partial])/ . "\n");
my ($self, $len, $allow_partial) = @_;
my $buf = '';
my $got = length $self->{rbuf};
if ($got) {
my $take = ($got < $len) ? $got : $len;
$buf = substr($self->{rbuf}, 0, $take, '');
$len -= $take;
}
while ($len > 0) {
$self->can_read
or die(q/Timed out while waiting for socket to become ready for reading/ . "\n");
my $r = sysread($self->{fh}, $buf, $len, length $buf);
if (defined $r) {
last unless $r;
$len -= $r;
}
elsif ($! != EINTR) {
if ($self->{fh}->can('errstr')){
my $err = $self->{fh}->errstr();
die (qq/Could not read from SSL socket: '$err'\n /);
}
else {
die(qq/Could not read from socket: '$!'\n/);
}
}
}
if ($len && !$allow_partial) {
die(qq/Unexpected end of stream\n/);
}
return $buf;
}
sub readline {
@_ == 1 || die(q/Usage: $handle->readline()/ . "\n");
my ($self) = @_;
while () {
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
return $1;
}
if (length $self->{rbuf} >= $self->{max_line_size}) {
die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/);
}
$self->can_read
or die(qq/Timed out while waiting for socket to become ready for reading\n/);
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
if (defined $r) {
last unless $r;
}
elsif ($! != EINTR) {
if ($self->{fh}->can('errstr')){
my $err = $self->{fh}->errstr();
die (qq/Could not read from SSL socket: '$err'\n /);
}
else {
die(qq/Could not read from socket: '$!'\n/);
}
}
}
die(qq/Unexpected end of stream while looking for line\n/);
}
sub read_header_lines {
@_ == 1 || @_ == 2 || die(q/Usage: $handle->read_header_lines([headers])/ . "\n");
my ($self, $headers) = @_;
$headers ||= {};
my $lines = 0;
my $val;
while () {
my $line = $self->readline;
if (++$lines >= $self->{max_header_lines}) {
die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/);
}
elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
my ($field_name) = lc $1;
if (exists $headers->{$field_name}) {
for ($headers->{$field_name}) {
$_ = [$_] unless ref $_ eq "ARRAY";
push @$_, $2;
$val = \$_->[-1];
}
}
else {
$val = \($headers->{$field_name} = $2);
}
}
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
$val
or die(qq/Unexpected header continuation line\n/);
next unless length $1;
$$val .= ' ' if length $$val;
$$val .= $1;
}
elsif ($line =~ /\A \x0D?\x0A \z/x) {
last;
}
else {
die(q/Malformed header line: / . $Printable->($line) . "\n");
}
}
return $headers;
}
sub write_request {
@_ == 2 || die(q/Usage: $handle->write_request(request)/ . "\n");
my($self, $request) = @_;
$self->write_request_header(@{$request}{qw/method uri headers/});
$self->write_body($request) if $request->{cb};
return;
}
my %HeaderCase = (
'content-md5' => 'Content-MD5',
'etag' => 'ETag',
'te' => 'TE',
'www-authenticate' => 'WWW-Authenticate',
'x-xss-protection' => 'X-XSS-Protection',
);
sub write_header_lines {
(@_ == 2 && ref $_[1] eq 'HASH') || die(q/Usage: $handle->write_header_lines(headers)/ . "\n");
my($self, $headers) = @_;
my $buf = '';
while (my ($k, $v) = each %$headers) {
my $field_name = lc $k;
if (exists $HeaderCase{$field_name}) {
$field_name = $HeaderCase{$field_name};
}
else {
$field_name =~ /\A $Token+ \z/xo
or die(q/Invalid HTTP header field name: / . $Printable->($field_name) . "\n");
$field_name =~ s/\b(\w)/\u$1/g;
$HeaderCase{lc $field_name} = $field_name;
}
for (ref $v eq 'ARRAY' ? @$v : $v) {
/[^\x0D\x0A]/
or die(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_). "\n");
$buf .= "$field_name: $_\x0D\x0A";
}
}
$buf .= "\x0D\x0A";
return $self->write($buf);
}
sub read_body {
@_ == 3 || die(q/Usage: $handle->read_body(callback, response)/ . "\n");
my ($self, $cb, $response) = @_;
my $te = $response->{headers}{'transfer-encoding'} || '';
if ( grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ) {
$self->read_chunked_body($cb, $response);
}
else {
$self->read_content_body($cb, $response);
}
return;
}
sub write_body {
@_ == 2 || die(q/Usage: $handle->write_body(request)/ . "\n");
my ($self, $request) = @_;
if ($request->{headers}{'content-length'}) {
return $self->write_content_body($request);
}
else {
return $self->write_chunked_body($request);
}
}
sub read_content_body {
@_ == 3 || @_ == 4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ . "\n");
my ($self, $cb, $response, $content_length) = @_;
$content_length ||= $response->{headers}{'content-length'};
if ( defined $content_length ) {
my $len = $content_length;
while ($len > 0) {
my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
$cb->($self->read($read, 0), $response);
$len -= $read;
}
}
else {
my $chunk;
$cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) );
}
return;
}
sub write_content_body {
@_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n");
my ($self, $request) = @_;
my ($len, $content_length) = (0, $request->{headers}{'content-length'});
while () {
my $data = $request->{cb}->();
defined $data && length $data
or last;
if ( $] ge '5.008' ) {
utf8::downgrade($data, 1)
or die(qq/Wide character in write_content()\n/);
}
$len += $self->write($data);
}
$len == $content_length
or die(qq/Content-Length missmatch (got: $len expected: $content_length)\n/);
return $len;
}
sub read_chunked_body {
@_ == 3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ . "\n");
my ($self, $cb, $response) = @_;
while () {
my $head = $self->readline;
$head =~ /\A ([A-Fa-f0-9]+)/x
or die(q/Malformed chunk head: / . $Printable->($head) . "\n");
my $len = hex($1)
or last;
$self->read_content_body($cb, $response, $len);
$self->read(2) eq "\x0D\x0A"
or die(qq/Malformed chunk: missing CRLF after chunk data\n/);
}
$self->read_header_lines($response->{headers});
return;
}
sub write_chunked_body {
@_ == 2 || die(q/Usage: $handle->write_chunked_body(request)/ . "\n");
my ($self, $request) = @_;
my $len = 0;
while () {
my $data = $request->{cb}->();
defined $data && length $data
or last;
if ( $] ge '5.008' ) {
utf8::downgrade($data, 1)
or die(qq/Wide character in write_chunked_body()\n/);
}
$len += length $data;
my $chunk = sprintf '%X', length $data;
$chunk .= "\x0D\x0A";
$chunk .= $data;
$chunk .= "\x0D\x0A";
$self->write($chunk);
}
$self->write("0\x0D\x0A");
$self->write_header_lines($request->{trailer_cb}->())
if ref $request->{trailer_cb} eq 'CODE';
return $len;
}
sub read_response_header {
@_ == 1 || die(q/Usage: $handle->read_response_header()/ . "\n");
my ($self) = @_;
my $line = $self->readline;
$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
or die(q/Malformed Status-Line: / . $Printable->($line). "\n");
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
die (qq/Unsupported HTTP protocol: $protocol\n/)
unless $version =~ /0*1\.0*[01]/;
return {
status => $status,
reason => $reason,
headers => $self->read_header_lines,
protocol => $protocol,
};
}
sub write_request_header {
@_ == 4 || die(q/Usage: $handle->write_request_header(method, request_uri, headers)/ . "\n");
my ($self, $method, $request_uri, $headers) = @_;
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
+ $self->write_header_lines($headers);
}
sub _do_timeout {
my ($self, $type, $timeout) = @_;
$timeout = $self->{timeout}
unless defined $timeout && $timeout >= 0;
my $fd = fileno $self->{fh};
defined $fd && $fd >= 0
or die(qq/select(2): 'Bad file descriptor'\n/);
my $initial = time;
my $pending = $timeout;
my $nfound;
vec(my $fdset = '', $fd, 1) = 1;
while () {
$nfound = ($type eq 'read')
? select($fdset, undef, undef, $pending)
: select(undef, $fdset, undef, $pending) ;
if ($nfound == -1) {
$! == EINTR
or die(qq/select(2): '$!'\n/);
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
$nfound = 0;
}
last;
}
$! = 0;
return $nfound;
}
sub can_read {
@_ == 1 || @_ == 2 || die(q/Usage: $handle->can_read([timeout])/ . "\n");
my $self = shift;
return $self->_do_timeout('read', @_)
}
sub can_write {
@_ == 1 || @_ == 2 || die(q/Usage: $handle->can_write([timeout])/ . "\n");
my $self = shift;
return $self->_do_timeout('write', @_)
}
# Try to find a CA bundle to validate the SSL cert,
# prefer Mozilla::CA or fallback to a system file
sub _find_CA_file {
my $self = shift();
return $self->{SSL_options}->{SSL_ca_file}
if $self->{SSL_options}->{SSL_ca_file} and -e $self->{SSL_options}->{SSL_ca_file};
return Mozilla::CA::SSL_ca_file()
if eval { require Mozilla::CA };
foreach my $ca_bundle (qw{
/etc/ssl/certs/ca-certificates.crt
/etc/pki/tls/certs/ca-bundle.crt
/etc/ssl/ca-bundle.pem
}
) {
return $ca_bundle if -e $ca_bundle;
}
die qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/
. qq/Try installing Mozilla::CA from CPAN\n/;
}
sub _ssl_args {
my ($self, $host) = @_;
my %ssl_args;
# This test reimplements IO::Socket::SSL::can_client_sni(), which wasn't
# added until IO::Socket::SSL 1.84
if ( Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x01000000 ) {
$ssl_args{SSL_hostname} = $host, # Sane SNI support
}
if ($self->{verify_SSL}) {
$ssl_args{SSL_verifycn_scheme} = 'http'; # enable CN validation
$ssl_args{SSL_verifycn_name} = $host; # set validation hostname
$ssl_args{SSL_verify_mode} = 0x01; # enable cert validation
$ssl_args{SSL_ca_file} = $self->_find_CA_file;
}
else {
$ssl_args{SSL_verifycn_scheme} = 'none'; # disable CN validation
$ssl_args{SSL_verify_mode} = 0x00; # disable cert validation
}
# user options override settings from verify_SSL
for my $k ( keys %{$self->{SSL_options}} ) {
$ssl_args{$k} = $self->{SSL_options}{$k} if $k =~ m/^SSL_/;
}
return \%ssl_args;
}
1;
__END__
=pod
=encoding utf-8
=head1 NAME
HTTP::Tiny - A small, simple, correct HTTP/1.1 client
=head1 VERSION
version 0.034
=head1 SYNOPSIS
use HTTP::Tiny;
my $response = HTTP::Tiny->new->get('http://example.com/');
die "Failed!\n" unless $response->{success};
print "$response->{status} $response->{reason}\n";
while (my ($k, $v) = each %{$response->{headers}}) {
for (ref $v eq 'ARRAY' ? @$v : $v) {
print "$k: $_\n";
}
}
print $response->{content} if length $response->{content};
=head1 DESCRIPTION
This is a very simple HTTP/1.1 client, designed for doing simple GET
requests without the overhead of a large framework like L<LWP::UserAgent>.
It is more correct and more complete than L<HTTP::Lite>. It supports
proxies (currently only non-authenticating ones) and redirection. It
also correctly resumes after EINTR.
=head1 METHODS
=head2 new
$http = HTTP::Tiny->new( %attributes );
This constructor returns a new HTTP::Tiny object. Valid attributes include:
=over 4
=item *
C<agent>
A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C<agent> ends in a space character, the default user-agent string is appended.
=item *
C<cookie_jar>
An instance of L<HTTP::CookieJar> or equivalent class that supports the C<add> and C<cookie_header> methods
=item *
C<default_headers>
A hashref of default headers to apply to requests
=item *
C<local_address>
The local IP address to bind to
=item *
C<max_redirect>
Maximum number of redirects allowed (defaults to 5)
=item *
C<max_size>
Maximum response size (only when not using a data callback). If defined,
responses larger than this will return an exception.
=item *
C<proxy>
URL of a proxy server to use (default is C<$ENV{http_proxy}> if set)
=item *
C<no_proxy>
List of domain suffixes that should not be proxied. Must be a comma-separated string or an array reference. (default is C<$ENV{no_proxy}>)
=item *
C<timeout>
Request timeout in seconds (default is 60)
=item *
C<verify_SSL>
A boolean that indicates whether to validate the SSL certificate of an C<https>
connection (default is false)
=item *
C<SSL_options>
A hashref of C<SSL_*> options to pass through to L<IO::Socket::SSL>
=back
Exceptions from C<max_size>, C<timeout> or other errors will result in a
pseudo-HTTP status code of 599 and a reason of "Internal Exception". The
content field in the response will contain the text of the exception.
See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.
=head2 get|head|put|post|delete
$response = $http->get($url);
$response = $http->get($url, \%options);
$response = $http->head($url);
These methods are shorthand for calling C<request()> for the given method. The
URL must have unsafe characters escaped and international domain names encoded.
See C<request()> for valid options and a description of the response.
The C<success> field of the response will be true if the status code is 2XX.
=head2 post_form
$response = $http->post_form($url, $form_data);
$response = $http->post_form($url, $form_data, \%options);
This method executes a C<POST> request and sends the key/value pairs from a
form data hash or array reference to the given URL with a C<content-type> of
C<application/x-www-form-urlencoded>. See documentation for the
C<www_form_urlencode> method for details on the encoding.
The URL must have unsafe characters escaped and international domain names
encoded. See C<request()> for valid options and a description of the response.
Any C<content-type> header or content in the options hashref will be ignored.
The C<success> field of the response will be true if the status code is 2XX.
=head2 mirror
$response = $http->mirror($url, $file, \%options)
if ( $response->{success} ) {
print "$file is up to date\n";
}
Executes a C<GET> request for the URL and saves the response body to the file
name provided. The URL must have unsafe characters escaped and international
domain names encoded. If the file already exists, the request will include an
C<If-Modified-Since> header with the modification timestamp of the file. You
may specify a different C<If-Modified-Since> header yourself in the C<<
$options->{headers} >> hash.
The C<success> field of the response will be true if the status code is 2XX
or if the status code is 304 (unmodified).
If the file was modified and the server response includes a properly
formatted C<Last-Modified> header, the file modification time will
be updated accordingly.
=head2 request
$response = $http->request($method, $url);
$response = $http->request($method, $url, \%options);
Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST',
'PUT', etc.) on the given URL. The URL must have unsafe characters escaped and
international domain names encoded.
If the URL includes a "user:password" stanza, they will be used for Basic-style
authorization headers. (Authorization headers will not be included in a
redirected request.) For example:
$http->request('GET', 'http://Aladdin:open sesame@example.com/');
A hashref of options may be appended to modify the request.
Valid options are:
=over 4
=item *
C<headers>
A hashref containing headers to include with the request. If the value for
a header is an array reference, the header will be output multiple times with
each value in the array. These headers over-write any default headers.
=item *
C<content>
A scalar to include as the body of the request OR a code reference
that will be called iteratively to produce the body of the request
=item *
C<trailer_callback>
A code reference that will be called if it exists to provide a hashref
of trailing headers (only used with chunked transfer-encoding)
=item *
C<data_callback>
A code reference that will be called for each chunks of the response
body received.
=back
If the C<content> option is a code reference, it will be called iteratively
to provide the content body of the request. It should return the empty
string or undef when the iterator is exhausted.
If the C<content> option is the empty string, no C<content-type> or
C<content-length> headers will be generated.
If the C<data_callback> option is provided, it will be called iteratively until
the entire response body is received. The first argument will be a string
containing a chunk of the response body, the second argument will be the
in-progress response hash reference, as described below. (This allows
customizing the action of the callback based on the C<status> or C<headers>
received prior to the content body.)
The C<request> method returns a hashref containing the response. The hashref
will have the following keys:
=over 4
=item *
C<success>
Boolean indicating whether the operation returned a 2XX status code
=item *
C<url>
URL that provided the response. This is the URL of the request unless
there were redirections, in which case it is the last URL queried
in a redirection chain
=item *
C<status>
The HTTP status code of the response
=item *
C<reason>
The response phrase returned by the server
=item *
C<content>
The body of the response. If the response does not have any content
or if a data callback is provided to consume the response body,
this will be the empty string
=item *
C<headers>
A hashref of header fields. All header field names will be normalized
to be lower case. If a header is repeated, the value will be an arrayref;
it will otherwise be a scalar string containing the value
=back
On an exception during the execution of the request, the C<status> field will
contain 599, and the C<content> field will contain the text of the exception.
=head2 www_form_urlencode
$params = $http->www_form_urlencode( $data );
$response = $http->get("http://example.com/query?$params");
This method converts the key/value pairs from a data hash or array reference
into a C<x-www-form-urlencoded> string. The keys and values from the data
reference will be UTF-8 encoded and escaped per RFC 3986. If a value is an
array reference, the key will be repeated with each of the values of the array
reference. The key/value pairs in the resulting string will be sorted by key
and value.
=for Pod::Coverage agent
cookie_jar
default_headers
local_address
max_redirect
max_size
proxy
no_proxy
timeout
verify_SSL
SSL_options
=head1 SSL SUPPORT
Direct C<https> connections are supported only if L<IO::Socket::SSL> 1.56 or
greater and L<Net::SSLeay> 1.49 or greater are installed. An exception will be
thrown if a new enough versions of these modules not installed or if the SSL
encryption fails. There is no support for C<https> connections via proxy (i.e.
RFC 2817).
SSL provides two distinct capabilities:
=over 4
=item *
Encrypted communication channel
=item *
Verification of server identity
=back
B<By default, HTTP::Tiny does not verify server identity>.
Server identity verification is controversial and potentially tricky because it
depends on a (usually paid) third-party Certificate Authority (CA) trust model
to validate a certificate as legitimate. This discriminates against servers
with self-signed certificates or certificates signed by free, community-driven
CA's such as L<CAcert.org|http://cacert.org>.
By default, HTTP::Tiny does not make any assumptions about your trust model,
threat level or risk tolerance. It just aims to give you an encrypted channel
when you need one.
Setting the C<verify_SSL> attribute to a true value will make HTTP::Tiny verify
that an SSL connection has a valid SSL certificate corresponding to the host
name of the connection and that the SSL certificate has been verified by a CA.
Assuming you trust the CA, this will protect against a L<man-in-the-middle
attack|http://en.wikipedia.org/wiki/Man-in-the-middle_attack>. If you are
concerned about security, you should enable this option.
Certificate verification requires a file containing trusted CA certificates.
If the L<Mozilla::CA> module is installed, HTTP::Tiny will use the CA file
included with it as a source of trusted CA's. (This means you trust Mozilla,
the author of Mozilla::CA, the CPAN mirror where you got Mozilla::CA, the
toolchain used to install it, and your operating system security, right?)
If that module is not available, then HTTP::Tiny will search several
system-specific default locations for a CA certificate file:
=over 4
=item *
/etc/ssl/certs/ca-certificates.crt
=item *
/etc/pki/tls/certs/ca-bundle.crt
=item *
/etc/ssl/ca-bundle.pem
=back
An exception will be raised if C<verify_SSL> is true and no CA certificate file
is available.
If you desire complete control over SSL connections, the C<SSL_options> attribute
lets you provide a hash reference that will be passed through to
C<IO::Socket::SSL::start_SSL()>, overriding any options set by HTTP::Tiny. For
example, to provide your own trusted CA file:
SSL_options => {
SSL_ca_file => $file_path,
}
The C<SSL_options> attribute could also be used for such things as providing a
client certificate for authentication to a server or controlling the choice of
cipher used for the SSL connection. See L<IO::Socket::SSL> documentation for
details.
=head1 LIMITATIONS
HTTP::Tiny is I<conditionally compliant> with the
L<HTTP/1.1 specification|http://www.w3.org/Protocols/rfc2616/rfc2616.html>.
It attempts to meet all "MUST" requirements of the specification, but does not
implement all "SHOULD" requirements.
Some particular limitations of note include:
=over
=item *
HTTP::Tiny focuses on correct transport. Users are responsible for ensuring
that user-defined headers and content are compliant with the HTTP/1.1
specification.
=item *
Users must ensure that URLs are properly escaped for unsafe characters and that
international domain names are properly encoded to ASCII. See L<URI::Escape>,
L<URI::_punycode> and L<Net::IDN::Encode>.
=item *
Redirection is very strict against the specification. Redirection is only
automatic for response codes 301, 302 and 307 if the request method is 'GET' or
'HEAD'. Response code 303 is always converted into a 'GET' redirection, as
mandated by the specification. There is no automatic support for status 305
("Use proxy") redirections.
=item *
Persistent connections are not supported. The C<Connection> header will
always be set to C<close>.
=item *
Cookie support requires L<HTTP::CookieJar> or an equivalent class.
=item *
Only the C<http_proxy> environment variable is supported in the format
C<http://HOST:PORT/>. If a C<proxy> argument is passed to C<new> (including
undef), then the C<http_proxy> environment variable is ignored.
=item *
C<no_proxy> environment variable is supported in the format comma-separated
list of domain extensions proxy should not be used for. If a C<no_proxy>
argument is passed to C<new>, then the C<no_proxy> environment variable is
ignored.
=item *
There is no provision for delaying a request body using an C<Expect> header.
Unexpected C<1XX> responses are silently ignored as per the specification.
=item *
Only 'chunked' C<Transfer-Encoding> is supported.
=item *
There is no support for a Request-URI of '*' for the 'OPTIONS' request.
=item *
There is no support for IPv6 of any kind.
=back
=head1 SEE ALSO
=over 4
=item *
L<HTTP::Thin> - HTTP::Tiny wrapper with L<HTTP::Request>/L<HTTP::Response> compatibility
=item *
L<HTTP::Tiny::Mech> - Wrap L<WWW::Mechanize> instance in HTTP::Tiny compatible interface
=item *
L<IO::Socket::SSL> - Required for SSL support
=item *
L<LWP::UserAgent> - If HTTP::Tiny isn't enough for you, this is the "standard" way to do things
=item *
L<Mozilla::CA> - Required if you want to validate SSL certificates
=item *
L<Net::SSLeay> - Required for SSL support
=back
=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
=head1 SUPPORT
=head2 Bugs / Feature Requests
Please report any bugs or feature requests through the issue tracker
at L<https://github.com/chansen/p5-http-tiny/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/chansen/p5-http-tiny>
git clone git://github.com/chansen/p5-http-tiny.git
=head1 AUTHORS
=over 4
=item *
Christian Hansen <chansen@cpan.org>
=item *
David Golden <dagolden@cpan.org>
=back
=head1 CONTRIBUTORS
=over 4
=item *
Alan Gardner <gardner@pythian.com>
=item *
Alessandro Ghedini <al3xbio@gmail.com>
=item *
Brad Gilbert <bgills@cpan.org>
=item *
Chris Nehren <apeiron@cpan.org>
=item *
Chris Weyl <cweyl@alumni.drew.edu>
=item *
Claes Jakobsson <claes@surfar.nu>
=item *
Craig Berry <cberry@cpan.org>
=item *
David Mitchell <davem@iabyn.com>
=item *
Edward Zborowski <ed@rubensteintech.com>
=item *
Jess Robinson <castaway@desert-island.me.uk>
=item *
Lukas Eklund <leklund@gmail.com>
=item *
Martin-Louis Bright <mlbright@gmail.com>
=item *
Mike Doherty <doherty@cpan.org>
=item *
Serguei Trouchelle <stro@cpan.org>
=item *
Syohei YOSHIDA <syohex@gmail.com>
=item *
Tony Cook <tony@develop-help.com>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2013 by Christian Hansen.
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
HTTP_TINY
$fatpacked{"JSON/PP.pm"} = <<'JSON_PP';
package JSON::PP;
# JSON-2.0
use 5.005;
use strict;
use base qw(Exporter);
use overload ();
use Carp ();
use B ();
#use Devel::Peek;
$JSON::PP::VERSION = '2.27202';
@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
# instead of hash-access, i tried index-access for speed.
# but this method is not faster than what i expected. so it will be changed.
use constant P_ASCII => 0;
use constant P_LATIN1 => 1;
use constant P_UTF8 => 2;
use constant P_INDENT => 3;
use constant P_CANONICAL => 4;
use constant P_SPACE_BEFORE => 5;
use constant P_SPACE_AFTER => 6;
use constant P_ALLOW_NONREF => 7;
use constant P_SHRINK => 8;
use constant P_ALLOW_BLESSED => 9;
use constant P_CONVERT_BLESSED => 10;
use constant P_RELAXED => 11;
use constant P_LOOSE => 12;
use constant P_ALLOW_BIGNUM => 13;
use constant P_ALLOW_BAREKEY => 14;
use constant P_ALLOW_SINGLEQUOTE => 15;
use constant P_ESCAPE_SLASH => 16;
use constant P_AS_NONBLESSED => 17;
use constant P_ALLOW_UNKNOWN => 18;
use constant OLD_PERL => $] < 5.008 ? 1 : 0;
BEGIN {
my @xs_compati_bit_properties = qw(
latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink
allow_blessed convert_blessed relaxed allow_unknown
);
my @pp_bit_properties = qw(
allow_singlequote allow_bignum loose
allow_barekey escape_slash as_nonblessed
);
# Perl version check, Unicode handling is enable?
# Helper module sets @JSON::PP::_properties.
if ($] < 5.008 ) {
my $helper = $] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005';
eval qq| require $helper |;
if ($@) { Carp::croak $@; }
}
for my $name (@xs_compati_bit_properties, @pp_bit_properties) {
my $flag_name = 'P_' . uc($name);
eval qq/
sub $name {
my \$enable = defined \$_[1] ? \$_[1] : 1;
if (\$enable) {
\$_[0]->{PROPS}->[$flag_name] = 1;
}
else {
\$_[0]->{PROPS}->[$flag_name] = 0;
}
\$_[0];
}
sub get_$name {
\$_[0]->{PROPS}->[$flag_name] ? 1 : '';
}
/;
}
}
# Functions
my %encode_allow_method
= map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash
allow_blessed convert_blessed indent indent_length allow_bignum
as_nonblessed
/;
my %decode_allow_method
= map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum
allow_barekey max_size relaxed/;
my $JSON; # cache
sub encode_json ($) { # encode
($JSON ||= __PACKAGE__->new->utf8)->encode(@_);
}
sub decode_json { # decode
($JSON ||= __PACKAGE__->new->utf8)->decode(@_);
}
# Obsoleted
sub to_json($) {
Carp::croak ("JSON::PP::to_json has been renamed to encode_json.");
}
sub from_json($) {
Carp::croak ("JSON::PP::from_json has been renamed to decode_json.");
}
# Methods
sub new {
my $class = shift;
my $self = {
max_depth => 512,
max_size => 0,
indent => 0,
FLAGS => 0,
fallback => sub { encode_error('Invalid value. JSON can only reference.') },
indent_length => 3,
};
bless $self, $class;
}
sub encode {
return $_[0]->PP_encode_json($_[1]);
}
sub decode {
return $_[0]->PP_decode_json($_[1], 0x00000000);
}
sub decode_prefix {
return $_[0]->PP_decode_json($_[1], 0x00000001);
}
# accessor
# pretty printing
sub pretty {
my ($self, $v) = @_;
my $enable = defined $v ? $v : 1;
if ($enable) { # indent_length(3) for JSON::XS compatibility
$self->indent(1)->indent_length(3)->space_before(1)->space_after(1);
}
else {
$self->indent(0)->space_before(0)->space_after(0);
}
$self;
}
# etc
sub max_depth {
my $max = defined $_[1] ? $_[1] : 0x80000000;
$_[0]->{max_depth} = $max;
$_[0];
}
sub get_max_depth { $_[0]->{max_depth}; }
sub max_size {
my $max = defined $_[1] ? $_[1] : 0;
$_[0]->{max_size} = $max;
$_[0];
}
sub get_max_size { $_[0]->{max_size}; }
sub filter_json_object {
$_[0]->{cb_object} = defined $_[1] ? $_[1] : 0;
$_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
$_[0];
}
sub filter_json_single_key_object {
if (@_ > 1) {
$_[0]->{cb_sk_object}->{$_[1]} = $_[2];
}
$_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
$_[0];
}
sub indent_length {
if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) {
Carp::carp "The acceptable range of indent_length() is 0 to 15.";
}
else {
$_[0]->{indent_length} = $_[1];
}
$_[0];
}
sub get_indent_length {
$_[0]->{indent_length};
}
sub sort_by {
$_[0]->{sort_by} = defined $_[1] ? $_[1] : 1;
$_[0];
}
sub allow_bigint {
Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted.");
}
###############################
###
### Perl => JSON
###
{ # Convert
my $max_depth;
my $indent;
my $ascii;
my $latin1;
my $utf8;
my $space_before;
my $space_after;
my $canonical;
my $allow_blessed;
my $convert_blessed;
my $indent_length;
my $escape_slash;
my $bignum;
my $as_nonblessed;
my $depth;
my $indent_count;
my $keysort;
sub PP_encode_json {
my $self = shift;
my $obj = shift;
$indent_count = 0;
$depth = 0;
my $idx = $self->{PROPS};
($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed,
$convert_blessed, $escape_slash, $bignum, $as_nonblessed)
= @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED,
P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED];
($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/};
$keysort = $canonical ? sub { $a cmp $b } : undef;
if ($self->{sort_by}) {
$keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by}
: $self->{sort_by} =~ /\D+/ ? $self->{sort_by}
: sub { $a cmp $b };
}
encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")
if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]);
my $str = $self->object_to_json($obj);
$str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible
unless ($ascii or $latin1 or $utf8) {
utf8::upgrade($str);
}
if ($idx->[ P_SHRINK ]) {
utf8::downgrade($str, 1);
}
return $str;
}
sub object_to_json {
my ($self, $obj) = @_;
my $type = ref($obj);
if($type eq 'HASH'){
return $self->hash_to_json($obj);
}
elsif($type eq 'ARRAY'){
return $self->array_to_json($obj);
}
elsif ($type) { # blessed object?
if (blessed($obj)) {
return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') );
if ( $convert_blessed and $obj->can('TO_JSON') ) {
my $result = $obj->TO_JSON();
if ( defined $result and ref( $result ) ) {
if ( refaddr( $obj ) eq refaddr( $result ) ) {
encode_error( sprintf(
"%s::TO_JSON method returned same object as was passed instead of a new one",
ref $obj
) );
}
}
return $self->object_to_json( $result );
}
return "$obj" if ( $bignum and _is_bignum($obj) );
return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed.
encode_error( sprintf("encountered object '%s', but neither allow_blessed "
. "nor convert_blessed settings are enabled", $obj)
) unless ($allow_blessed);
return 'null';
}
else {
return $self->value_to_json($obj);
}
}
else{
return $self->value_to_json($obj);
}
}
sub hash_to_json {
my ($self, $obj) = @_;
my @res;
encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
if (++$depth > $max_depth);
my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : '');
for my $k ( _sort( $obj ) ) {
if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized
push @res, string_to_json( $self, $k )
. $del
. ( $self->object_to_json( $obj->{$k} ) || $self->value_to_json( $obj->{$k} ) );
}
--$depth;
$self->_down_indent() if ($indent);
return '{' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . '}';
}
sub array_to_json {
my ($self, $obj) = @_;
my @res;
encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
if (++$depth > $max_depth);
my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
for my $v (@$obj){
push @res, $self->object_to_json($v) || $self->value_to_json($v);
}
--$depth;
$self->_down_indent() if ($indent);
return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']';
}
sub value_to_json {
my ($self, $value) = @_;
return 'null' if(!defined $value);
my $b_obj = B::svref_2object(\$value); # for round trip problem
my $flags = $b_obj->FLAGS;
return $value # as is
if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV?
my $type = ref($value);
if(!$type){
return string_to_json($self, $value);
}
elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){
return $$value == 1 ? 'true' : 'false';
}
elsif ($type) {
if ((overload::StrVal($value) =~ /=(\w+)/)[0]) {
return $self->value_to_json("$value");
}
if ($type eq 'SCALAR' and defined $$value) {
return $$value eq '1' ? 'true'
: $$value eq '0' ? 'false'
: $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null'
: encode_error("cannot encode reference to scalar");
}
if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) {
return 'null';
}
else {
if ( $type eq 'SCALAR' or $type eq 'REF' ) {
encode_error("cannot encode reference to scalar");
}
else {
encode_error("encountered $value, but JSON can only represent references to arrays or hashes");
}
}
}
else {
return $self->{fallback}->($value)
if ($self->{fallback} and ref($self->{fallback}) eq 'CODE');
return 'null';
}
}
my %esc = (
"\n" => '\n',
"\r" => '\r',
"\t" => '\t',
"\f" => '\f',
"\b" => '\b',
"\"" => '\"',
"\\" => '\\\\',
"\'" => '\\\'',
);
sub string_to_json {
my ($self, $arg) = @_;
$arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
$arg =~ s/\//\\\//g if ($escape_slash);
$arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
if ($ascii) {
$arg = JSON_PP_encode_ascii($arg);
}
if ($latin1) {
$arg = JSON_PP_encode_latin1($arg);
}
if ($utf8) {
utf8::encode($arg);
}
return '"' . $arg . '"';
}
sub blessed_to_json {
my $reftype = reftype($_[1]) || '';
if ($reftype eq 'HASH') {
return $_[0]->hash_to_json($_[1]);
}
elsif ($reftype eq 'ARRAY') {
return $_[0]->array_to_json($_[1]);
}
else {
return 'null';
}
}
sub encode_error {
my $error = shift;
Carp::croak "$error";
}
sub _sort {
defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]};
}
sub _up_indent {
my $self = shift;
my $space = ' ' x $indent_length;
my ($pre,$post) = ('','');
$post = "\n" . $space x $indent_count;
$indent_count++;
$pre = "\n" . $space x $indent_count;
return ($pre,$post);
}
sub _down_indent { $indent_count--; }
sub PP_encode_box {
{
depth => $depth,
indent_count => $indent_count,
};
}
} # Convert
sub _encode_ascii {
join('',
map {
$_ <= 127 ?
chr($_) :
$_ <= 65535 ?
sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
} unpack('U*', $_[0])
);
}
sub _encode_latin1 {
join('',
map {
$_ <= 255 ?
chr($_) :
$_ <= 65535 ?
sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
} unpack('U*', $_[0])
);
}
sub _encode_surrogates { # from perlunicode
my $uni = $_[0] - 0x10000;
return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
}
sub _is_bignum {
$_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat');
}
#
# JSON => Perl
#
my $max_intsize;
BEGIN {
my $checkint = 1111;
for my $d (5..64) {
$checkint .= 1;
my $int = eval qq| $checkint |;
if ($int =~ /[eE]/) {
$max_intsize = $d - 1;
last;
}
}
}
{ # PARSE
my %escapes = ( # by Jeremy Muhlich <jmuhlich [at] bitflood.org>
b => "\x8",
t => "\x9",
n => "\xA",
f => "\xC",
r => "\xD",
'\\' => '\\',
'"' => '"',
'/' => '/',
);
my $text; # json data
my $at; # offset
my $ch; # 1chracter
my $len; # text length (changed according to UTF8 or NON UTF8)
# INTERNAL
my $depth; # nest counter
my $encoding; # json text encoding
my $is_valid_utf8; # temp variable
my $utf8_len; # utf8 byte length
# FLAGS
my $utf8; # must be utf8
my $max_depth; # max nest nubmer of objects and arrays
my $max_size;
my $relaxed;
my $cb_object;
my $cb_sk_object;
my $F_HOOK;
my $allow_bigint; # using Math::BigInt
my $singlequote; # loosely quoting
my $loose; #
my $allow_barekey; # bareKey
# $opt flag
# 0x00000001 .... decode_prefix
# 0x10000000 .... incr_parse
sub PP_decode_json {
my ($self, $opt); # $opt is an effective flag during this decode_json.
($self, $text, $opt) = @_;
($at, $ch, $depth) = (0, '', 0);
if ( !defined $text or ref $text ) {
decode_error("malformed JSON string, neither array, object, number, string or atom");
}
my $idx = $self->{PROPS};
($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote)
= @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE];
if ( $utf8 ) {
utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
}
else {
utf8::upgrade( $text );
}
$len = length $text;
($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK)
= @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/};
if ($max_size > 1) {
use bytes;
my $bytes = length $text;
decode_error(
sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s"
, $bytes, $max_size), 1
) if ($bytes > $max_size);
}
# Currently no effect
# should use regexp
my @octets = unpack('C4', $text);
$encoding = ( $octets[0] and $octets[1]) ? 'UTF-8'
: (!$octets[0] and $octets[1]) ? 'UTF-16BE'
: (!$octets[0] and !$octets[1]) ? 'UTF-32BE'
: ( $octets[2] ) ? 'UTF-16LE'
: (!$octets[2] ) ? 'UTF-32LE'
: 'unknown';
white(); # remove head white space
my $valid_start = defined $ch; # Is there a first character for JSON structure?
my $result = value();
return undef if ( !$result && ( $opt & 0x10000000 ) ); # for incr_parse
decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start;
if ( !$idx->[ P_ALLOW_NONREF ] and !ref $result ) {
decode_error(
'JSON text must be an object or array (but found number, string, true, false or null,'
. ' use allow_nonref to allow this)', 1);
}
Carp::croak('something wrong.') if $len < $at; # we won't arrive here.
my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length
white(); # remove tail white space
if ( $ch ) {
return ( $result, $consumed ) if ($opt & 0x00000001); # all right if decode_prefix
decode_error("garbage after JSON object");
}
( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result;
}
sub next_chr {
return $ch = undef if($at >= $len);
$ch = substr($text, $at++, 1);
}
sub value {
white();
return if(!defined $ch);
return object() if($ch eq '{');
return array() if($ch eq '[');
return string() if($ch eq '"' or ($singlequote and $ch eq "'"));
return number() if($ch =~ /[0-9]/ or $ch eq '-');
return word();
}
sub string {
my ($i, $s, $t, $u);
my $utf16;
my $is_utf8;
($is_valid_utf8, $utf8_len) = ('', 0);
$s = ''; # basically UTF8 flag on
if($ch eq '"' or ($singlequote and $ch eq "'")){
my $boundChar = $ch;
OUTER: while( defined(next_chr()) ){
if($ch eq $boundChar){
next_chr();
if ($utf16) {
decode_error("missing low surrogate character in surrogate pair");
}
utf8::decode($s) if($is_utf8);
return $s;
}
elsif($ch eq '\\'){
next_chr();
if(exists $escapes{$ch}){
$s .= $escapes{$ch};
}
elsif($ch eq 'u'){ # UNICODE handling
my $u = '';
for(1..4){
$ch = next_chr();
last OUTER if($ch !~ /[0-9a-fA-F]/);
$u .= $ch;
}
# U+D800 - U+DBFF
if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate?
$utf16 = $u;
}
# U+DC00 - U+DFFF
elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate?
unless (defined $utf16) {
decode_error("missing high surrogate character in surrogate pair");
}
$is_utf8 = 1;
$s .= JSON_PP_decode_surrogates($utf16, $u) || next;
$utf16 = undef;
}
else {
if (defined $utf16) {
decode_error("surrogate pair expected");
}
if ( ( my $hex = hex( $u ) ) > 127 ) {
$is_utf8 = 1;
$s .= JSON_PP_decode_unicode($u) || next;
}
else {
$s .= chr $hex;
}
}
}
else{
unless ($loose) {
$at -= 2;
decode_error('illegal backslash escape sequence in string');
}
$s .= $ch;
}
}
else{
if ( ord $ch > 127 ) {
if ( $utf8 ) {
unless( $ch = is_valid_utf8($ch) ) {
$at -= 1;
decode_error("malformed UTF-8 character in JSON string");
}
else {
$at += $utf8_len - 1;
}
}
else {
utf8::encode( $ch );
}
$is_utf8 = 1;
}
if (!$loose) {
if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok
$at--;
decode_error('invalid character encountered while parsing JSON string');
}
}
$s .= $ch;
}
}
}
decode_error("unexpected end of string while parsing JSON string");
}
sub white {
while( defined $ch ){
if($ch le ' '){
next_chr();
}
elsif($ch eq '/'){
next_chr();
if(defined $ch and $ch eq '/'){
1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r");
}
elsif(defined $ch and $ch eq '*'){
next_chr();
while(1){
if(defined $ch){
if($ch eq '*'){
if(defined(next_chr()) and $ch eq '/'){
next_chr();
last;
}
}
else{
next_chr();
}
}
else{
decode_error("Unterminated comment");
}
}
next;
}
else{
$at--;
decode_error("malformed JSON string, neither array, object, number, string or atom");
}
}
else{
if ($relaxed and $ch eq '#') { # correctly?
pos($text) = $at;
$text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;
$at = pos($text);
next_chr;
next;
}
last;
}
}
}
sub array {
my $a = $_[0] || []; # you can use this code to use another array ref object.
decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
if (++$depth > $max_depth);
next_chr();
white();
if(defined $ch and $ch eq ']'){
--$depth;
next_chr();
return $a;
}
else {
while(defined($ch)){
push @$a, value();
white();
if (!defined $ch) {
last;
}
if($ch eq ']'){
--$depth;
next_chr();
return $a;
}
if($ch ne ','){
last;
}
next_chr();
white();
if ($relaxed and $ch eq ']') {
--$depth;
next_chr();
return $a;
}
}
}
decode_error(", or ] expected while parsing array");
}
sub object {
my $o = $_[0] || {}; # you can use this code to use another hash ref object.
my $k;
decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
if (++$depth > $max_depth);
next_chr();
white();
if(defined $ch and $ch eq '}'){
--$depth;
next_chr();
if ($F_HOOK) {
return _json_object_hook($o);
}
return $o;
}
else {
while (defined $ch) {
$k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string();
white();
if(!defined $ch or $ch ne ':'){
$at--;
decode_error("':' expected");
}
next_chr();
$o->{$k} = value();
white();
last if (!defined $ch);
if($ch eq '}'){
--$depth;
next_chr();
if ($F_HOOK) {
return _json_object_hook($o);
}
return $o;
}
if($ch ne ','){
last;
}
next_chr();
white();
if ($relaxed and $ch eq '}') {
--$depth;
next_chr();
if ($F_HOOK) {
return _json_object_hook($o);
}
return $o;
}
}
}
$at--;
decode_error(", or } expected while parsing object/hash");
}
sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition
my $key;
while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){
$key .= $ch;
next_chr();
}
return $key;
}
sub word {
my $word = substr($text,$at-1,4);
if($word eq 'true'){
$at += 3;
next_chr;
return $JSON::PP::true;
}
elsif($word eq 'null'){
$at += 3;
next_chr;
return undef;
}
elsif($word eq 'fals'){
$at += 3;
if(substr($text,$at,1) eq 'e'){
$at++;
next_chr;
return $JSON::PP::false;
}
}
$at--; # for decode_error report
decode_error("'null' expected") if ($word =~ /^n/);
decode_error("'true' expected") if ($word =~ /^t/);
decode_error("'false' expected") if ($word =~ /^f/);
decode_error("malformed JSON string, neither array, object, number, string or atom");
}
sub number {
my $n = '';
my $v;
# According to RFC4627, hex or oct digts are invalid.
if($ch eq '0'){
my $peek = substr($text,$at,1);
my $hex = $peek =~ /[xX]/; # 0 or 1
if($hex){
decode_error("malformed number (leading zero must not be followed by another digit)");
($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/);
}
else{ # oct
($n) = ( substr($text, $at) =~ /^([0-7]+)/);
if (defined $n and length $n > 1) {
decode_error("malformed number (leading zero must not be followed by another digit)");
}
}
if(defined $n and length($n)){
if (!$hex and length($n) == 1) {
decode_error("malformed number (leading zero must not be followed by another digit)");
}
$at += length($n) + $hex;
next_chr;
return $hex ? hex($n) : oct($n);
}
}
if($ch eq '-'){
$n = '-';
next_chr;
if (!defined $ch or $ch !~ /\d/) {
decode_error("malformed number (no digits after initial minus)");
}
}
while(defined $ch and $ch =~ /\d/){
$n .= $ch;
next_chr;
}
if(defined $ch and $ch eq '.'){
$n .= '.';
next_chr;
if (!defined $ch or $ch !~ /\d/) {
decode_error("malformed number (no digits after decimal point)");
}
else {
$n .= $ch;
}
while(defined(next_chr) and $ch =~ /\d/){
$n .= $ch;
}
}
if(defined $ch and ($ch eq 'e' or $ch eq 'E')){
$n .= $ch;
next_chr;
if(defined($ch) and ($ch eq '+' or $ch eq '-')){
$n .= $ch;
next_chr;
if (!defined $ch or $ch =~ /\D/) {
decode_error("malformed number (no digits after exp sign)");
}
$n .= $ch;
}
elsif(defined($ch) and $ch =~ /\d/){
$n .= $ch;
}
else {
decode_error("malformed number (no digits after exp sign)");
}
while(defined(next_chr) and $ch =~ /\d/){
$n .= $ch;
}
}
$v .= $n;
if ($v !~ /[.eE]/ and length $v > $max_intsize) {
if ($allow_bigint) { # from Adam Sussman
require Math::BigInt;
return Math::BigInt->new($v);
}
else {
return "$v";
}
}
elsif ($allow_bigint) {
require Math::BigFloat;
return Math::BigFloat->new($v);
}
return 0+$v;
}
sub is_valid_utf8 {
$utf8_len = $_[0] =~ /[\x00-\x7F]/ ? 1
: $_[0] =~ /[\xC2-\xDF]/ ? 2
: $_[0] =~ /[\xE0-\xEF]/ ? 3
: $_[0] =~ /[\xF0-\xF4]/ ? 4
: 0
;
return unless $utf8_len;
my $is_valid_utf8 = substr($text, $at - 1, $utf8_len);
return ( $is_valid_utf8 =~ /^(?:
[\x00-\x7F]
|[\xC2-\xDF][\x80-\xBF]
|[\xE0][\xA0-\xBF][\x80-\xBF]
|[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
|[\xED][\x80-\x9F][\x80-\xBF]
|[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
|[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
|[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
|[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
)$/x ) ? $is_valid_utf8 : '';
}
sub decode_error {
my $error = shift;
my $no_rep = shift;
my $str = defined $text ? substr($text, $at) : '';
my $mess = '';
my $type = $] >= 5.008 ? 'U*'
: $] < 5.006 ? 'C*'
: utf8::is_utf8( $str ) ? 'U*' # 5.6
: 'C*'
;
for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
$mess .= $c == 0x07 ? '\a'
: $c == 0x09 ? '\t'
: $c == 0x0a ? '\n'
: $c == 0x0d ? '\r'
: $c == 0x0c ? '\f'
: $c < 0x20 ? sprintf('\x{%x}', $c)
: $c == 0x5c ? '\\\\'
: $c < 0x80 ? chr($c)
: sprintf('\x{%x}', $c)
;
if ( length $mess >= 20 ) {
$mess .= '...';
last;
}
}
unless ( length $mess ) {
$mess = '(end of string)';
}
Carp::croak (
$no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")"
);
}
sub _json_object_hook {
my $o = $_[0];
my @ks = keys %{$o};
if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) {
my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} );
if (@val == 1) {
return $val[0];
}
}
my @val = $cb_object->($o) if ($cb_object);
if (@val == 0 or @val > 1) {
return $o;
}
else {
return $val[0];
}
}
sub PP_decode_box {
{
text => $text,
at => $at,
ch => $ch,
len => $len,
depth => $depth,
encoding => $encoding,
is_valid_utf8 => $is_valid_utf8,
};
}
} # PARSE
sub _decode_surrogates { # from perlunicode
my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00);
my $un = pack('U*', $uni);
utf8::encode( $un );
return $un;
}
sub _decode_unicode {
my $un = pack('U', hex shift);
utf8::encode( $un );
return $un;
}
#
# Setup for various Perl versions (the code from JSON::PP58)
#
BEGIN {
unless ( defined &utf8::is_utf8 ) {
require Encode;
*utf8::is_utf8 = *Encode::is_utf8;
}
if ( $] >= 5.008 ) {
*JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii;
*JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1;
*JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates;
*JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode;
}
if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken.
package JSON::PP;
require subs;
subs->import('join');
eval q|
sub join {
return '' if (@_ < 2);
my $j = shift;
my $str = shift;
for (@_) { $str .= $j . $_; }
return $str;
}
|;
}
sub JSON::PP::incr_parse {
local $Carp::CarpLevel = 1;
( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
}
sub JSON::PP::incr_skip {
( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
}
sub JSON::PP::incr_reset {
( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
}
eval q{
sub JSON::PP::incr_text : lvalue {
$_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
Carp::croak("incr_text can not be called when the incremental parser already started parsing");
}
$_[0]->{_incr_parser}->{incr_text};
}
} if ( $] >= 5.006 );
} # Setup for various Perl versions (the code from JSON::PP58)
###############################
# Utilities
#
BEGIN {
eval 'require Scalar::Util';
unless($@){
*JSON::PP::blessed = \&Scalar::Util::blessed;
*JSON::PP::reftype = \&Scalar::Util::reftype;
*JSON::PP::refaddr = \&Scalar::Util::refaddr;
}
else{ # This code is from Sclar::Util.
# warn $@;
eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';
*JSON::PP::blessed = sub {
local($@, $SIG{__DIE__}, $SIG{__WARN__});
ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef;
};
my %tmap = qw(
B::NULL SCALAR
B::HV HASH
B::AV ARRAY
B::CV CODE
B::IO IO
B::GV GLOB
B::REGEXP REGEXP
);
*JSON::PP::reftype = sub {
my $r = shift;
return undef unless length(ref($r));
my $t = ref(B::svref_2object($r));
return
exists $tmap{$t} ? $tmap{$t}
: length(ref($$r)) ? 'REF'
: 'SCALAR';
};
*JSON::PP::refaddr = sub {
return undef unless length(ref($_[0]));
my $addr;
if(defined(my $pkg = blessed($_[0]))) {
$addr .= bless $_[0], 'Scalar::Util::Fake';
bless $_[0], $pkg;
}
else {
$addr .= $_[0]
}
$addr =~ /0x(\w+)/;
local $^W;
#no warnings 'portable';
hex($1);
}
}
}
# shamely copied and modified from JSON::XS code.
$JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); }
sub true { $JSON::PP::true }
sub false { $JSON::PP::false }
sub null { undef; }
###############################
package JSON::PP::Boolean;
use overload (
"0+" => sub { ${$_[0]} },
"++" => sub { $_[0] = ${$_[0]} + 1 },
"--" => sub { $_[0] = ${$_[0]} - 1 },
fallback => 1,
);
###############################
package JSON::PP::IncrParser;
use strict;
use constant INCR_M_WS => 0; # initial whitespace skipping
use constant INCR_M_STR => 1; # inside string
use constant INCR_M_BS => 2; # inside backslash
use constant INCR_M_JSON => 3; # outside anything, count nesting
use constant INCR_M_C0 => 4;
use constant INCR_M_C1 => 5;
$JSON::PP::IncrParser::VERSION = '1.01';
my $unpack_format = $] < 5.006 ? 'C*' : 'U*';
sub new {
my ( $class ) = @_;
bless {
incr_nest => 0,
incr_text => undef,
incr_parsing => 0,
incr_p => 0,
}, $class;
}
sub incr_parse {
my ( $self, $coder, $text ) = @_;
$self->{incr_text} = '' unless ( defined $self->{incr_text} );
if ( defined $text ) {
if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) {
utf8::upgrade( $self->{incr_text} ) ;
utf8::decode( $self->{incr_text} ) ;
}
$self->{incr_text} .= $text;
}
my $max_size = $coder->get_max_size;
if ( defined wantarray ) {
$self->{incr_mode} = INCR_M_WS unless defined $self->{incr_mode};
if ( wantarray ) {
my @ret;
$self->{incr_parsing} = 1;
do {
push @ret, $self->_incr_parse( $coder, $self->{incr_text} );
unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) {
$self->{incr_mode} = INCR_M_WS if $self->{incr_mode} != INCR_M_STR;
}
} until ( length $self->{incr_text} >= $self->{incr_p} );
$self->{incr_parsing} = 0;
return @ret;
}
else { # in scalar context
$self->{incr_parsing} = 1;
my $obj = $self->_incr_parse( $coder, $self->{incr_text} );
$self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans
return $obj ? $obj : undef; # $obj is an empty string, parsing was completed.
}
}
}
sub _incr_parse {
my ( $self, $coder, $text, $skip ) = @_;
my $p = $self->{incr_p};
my $restore = $p;
my @obj;
my $len = length $text;
if ( $self->{incr_mode} == INCR_M_WS ) {
while ( $len > $p ) {
my $s = substr( $text, $p, 1 );
$p++ and next if ( 0x20 >= unpack($unpack_format, $s) );
$self->{incr_mode} = INCR_M_JSON;
last;
}
}
while ( $len > $p ) {
my $s = substr( $text, $p++, 1 );
if ( $s eq '"' ) {
if (substr( $text, $p - 2, 1 ) eq '\\' ) {
next;
}
if ( $self->{incr_mode} != INCR_M_STR ) {
$self->{incr_mode} = INCR_M_STR;
}
else {
$self->{incr_mode} = INCR_M_JSON;
unless ( $self->{incr_nest} ) {
last;
}
}
}
if ( $self->{incr_mode} == INCR_M_JSON ) {
if ( $s eq '[' or $s eq '{' ) {
if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
}
}
elsif ( $s eq ']' or $s eq '}' ) {
last if ( --$self->{incr_nest} <= 0 );
}
elsif ( $s eq '#' ) {
while ( $len > $p ) {
last if substr( $text, $p++, 1 ) eq "\n";
}
}
}
}
$self->{incr_p} = $p;
return if ( $self->{incr_mode} == INCR_M_STR and not $self->{incr_nest} );
return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 );
return '' unless ( length substr( $self->{incr_text}, 0, $p ) );
local $Carp::CarpLevel = 2;
$self->{incr_p} = $restore;
$self->{incr_c} = $p;
my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 );
$self->{incr_text} = substr( $self->{incr_text}, $p );
$self->{incr_p} = 0;
return $obj or '';
}
sub incr_text {
if ( $_[0]->{incr_parsing} ) {
Carp::croak("incr_text can not be called when the incremental parser already started parsing");
}
$_[0]->{incr_text};
}
sub incr_skip {
my $self = shift;
$self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} );
$self->{incr_p} = 0;
}
sub incr_reset {
my $self = shift;
$self->{incr_text} = undef;
$self->{incr_p} = 0;
$self->{incr_mode} = 0;
$self->{incr_nest} = 0;
$self->{incr_parsing} = 0;
}
###############################
1;
__END__
=pod
=head1 NAME
JSON::PP - JSON::XS compatible pure-Perl module.
=head1 SYNOPSIS
use JSON::PP;
# exported functions, they croak on error
# and expect/generate UTF-8
$utf8_encoded_json_text = encode_json $perl_hash_or_arrayref;
$perl_hash_or_arrayref = decode_json $utf8_encoded_json_text;
# OO-interface
$coder = JSON::PP->new->ascii->pretty->allow_nonref;
$json_text = $json->encode( $perl_scalar );
$perl_scalar = $json->decode( $json_text );
$pretty_printed = $json->pretty->encode( $perl_scalar ); # pretty-printing
# Note that JSON version 2.0 and above will automatically use
# JSON::XS or JSON::PP, so you should be able to just:
use JSON;
=head1 VERSION
2.27202
L<JSON::XS> 2.27 (~2.30) compatible.
=head1 NOTE
JSON::PP had been inculded in JSON distribution (CPAN module).
It was a perl core module in Perl 5.14.
=head1 DESCRIPTION
This module is L<JSON::XS> compatible pure Perl module.
(Perl 5.8 or later is recommended)
JSON::XS is the fastest and most proper JSON module on CPAN.
It is written by Marc Lehmann in C, so must be compiled and
installed in the used environment.
JSON::PP is a pure-Perl module and has compatibility to JSON::XS.
=head2 FEATURES
=over
=item * correct unicode handling
This module knows how to handle Unicode (depending on Perl version).
See to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL> and L<UNICODE HANDLING ON PERLS>.
=item * round-trip integrity
When you serialise a perl data structure using only data types supported
by JSON and Perl, the deserialised data structure is identical on the Perl
level. (e.g. the string "2.0" doesn't suddenly become "2" just because
it looks like a number). There I<are> minor exceptions to this, read the
MAPPING section below to learn about those.
=item * strict checking of JSON correctness
There is no guessing, no generating of illegal JSON texts by default,
and only JSON is accepted as input by default (the latter is a security feature).
But when some options are set, loose chcking features are available.
=back
=head1 FUNCTIONAL INTERFACE
Some documents are copied and modified from L<JSON::XS/FUNCTIONAL INTERFACE>.
=head2 encode_json
$json_text = encode_json $perl_scalar
Converts the given Perl data structure to a UTF-8 encoded, binary string.
This function call is functionally identical to:
$json_text = JSON::PP->new->utf8->encode($perl_scalar)
=head2 decode_json
$perl_scalar = decode_json $json_text
The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries
to parse that as an UTF-8 encoded JSON text, returning the resulting
reference.
This function call is functionally identical to:
$perl_scalar = JSON::PP->new->utf8->decode($json_text)
=head2 JSON::PP::is_bool
$is_boolean = JSON::PP::is_bool($scalar)
Returns true if the passed scalar represents either JSON::PP::true or
JSON::PP::false, two constants that act like C<1> and C<0> respectively
and are also used to represent JSON C<true> and C<false> in Perl strings.
=head2 JSON::PP::true
Returns JSON true value which is blessed object.
It C<isa> JSON::PP::Boolean object.
=head2 JSON::PP::false
Returns JSON false value which is blessed object.
It C<isa> JSON::PP::Boolean object.
=head2 JSON::PP::null
Returns C<undef>.
See L<MAPPING>, below, for more information on how JSON values are mapped to
Perl.
=head1 HOW DO I DECODE A DATA FROM OUTER AND ENCODE TO OUTER
This section supposes that your perl vresion is 5.8 or later.
If you know a JSON text from an outer world - a network, a file content, and so on,
is encoded in UTF-8, you should use C<decode_json> or C<JSON> module object
with C<utf8> enable. And the decoded result will contain UNICODE characters.
# from network
my $json = JSON::PP->new->utf8;
my $json_text = CGI->new->param( 'json_data' );
my $perl_scalar = $json->decode( $json_text );
# from file content
local $/;
open( my $fh, '<', 'json.data' );
$json_text = <$fh>;
$perl_scalar = decode_json( $json_text );
If an outer data is not encoded in UTF-8, firstly you should C<decode> it.
use Encode;
local $/;
open( my $fh, '<', 'json.data' );
my $encoding = 'cp932';
my $unicode_json_text = decode( $encoding, <$fh> ); # UNICODE
# or you can write the below code.
#
# open( my $fh, "<:encoding($encoding)", 'json.data' );
# $unicode_json_text = <$fh>;
In this case, C<$unicode_json_text> is of course UNICODE string.
So you B<cannot> use C<decode_json> nor C<JSON> module object with C<utf8> enable.
Instead of them, you use C<JSON> module object with C<utf8> disable.
$perl_scalar = $json->utf8(0)->decode( $unicode_json_text );
Or C<encode 'utf8'> and C<decode_json>:
$perl_scalar = decode_json( encode( 'utf8', $unicode_json_text ) );
# this way is not efficient.
And now, you want to convert your C<$perl_scalar> into JSON data and
send it to an outer world - a network or a file content, and so on.
Your data usually contains UNICODE strings and you want the converted data to be encoded
in UTF-8, you should use C<encode_json> or C<JSON> module object with C<utf8> enable.
print encode_json( $perl_scalar ); # to a network? file? or display?
# or
print $json->utf8->encode( $perl_scalar );
If C<$perl_scalar> does not contain UNICODE but C<$encoding>-encoded strings
for some reason, then its characters are regarded as B<latin1> for perl
(because it does not concern with your $encoding).
You B<cannot> use C<encode_json> nor C<JSON> module object with C<utf8> enable.
Instead of them, you use C<JSON> module object with C<utf8> disable.
Note that the resulted text is a UNICODE string but no problem to print it.
# $perl_scalar contains $encoding encoded string values
$unicode_json_text = $json->utf8(0)->encode( $perl_scalar );
# $unicode_json_text consists of characters less than 0x100
print $unicode_json_text;
Or C<decode $encoding> all string values and C<encode_json>:
$perl_scalar->{ foo } = decode( $encoding, $perl_scalar->{ foo } );
# ... do it to each string values, then encode_json
$json_text = encode_json( $perl_scalar );
This method is a proper way but probably not efficient.
See to L<Encode>, L<perluniintro>.
=head1 METHODS
Basically, check to L<JSON> or L<JSON::XS>.
=head2 new
$json = JSON::PP->new
Rturns a new JSON::PP object that can be used to de/encode JSON
strings.
All boolean flags described below are by default I<disabled>.
The mutators for flags all return the JSON object again and thus calls can
be chained:
my $json = JSON::PP->new->utf8->space_after->encode({a => [1,2]})
=> {"a": [1, 2]}
=head2 ascii
$json = $json->ascii([$enable])
$enabled = $json->get_ascii
If $enable is true (or missing), then the encode method will not generate characters outside
the code range 0..127. Any Unicode characters outside that range will be escaped using either
a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627.
(See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>).
In Perl 5.005, there is no character having high value (more than 255).
See to L<UNICODE HANDLING ON PERLS>.
If $enable is false, then the encode method will not escape Unicode characters unless
required by the JSON syntax or other flags. This results in a faster and more compact format.
JSON::PP->new->ascii(1)->encode([chr 0x10401])
=> ["\ud801\udc01"]
=head2 latin1
$json = $json->latin1([$enable])
$enabled = $json->get_latin1
If $enable is true (or missing), then the encode method will encode the resulting JSON
text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255.
If $enable is false, then the encode method will not escape Unicode characters
unless required by the JSON syntax or other flags.
JSON::XS->new->latin1->encode (["\x{89}\x{abc}"]
=> ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not)
See to L<UNICODE HANDLING ON PERLS>.
=head2 utf8
$json = $json->utf8([$enable])
$enabled = $json->get_utf8
If $enable is true (or missing), then the encode method will encode the JSON result
into UTF-8, as required by many protocols, while the decode method expects to be handled
an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any
characters outside the range 0..255, they are thus useful for bytewise/binary I/O.
(In Perl 5.005, any character outside the range 0..255 does not exist.
See to L<UNICODE HANDLING ON PERLS>.)
In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32
encoding families, as described in RFC4627.
If $enable is false, then the encode method will return the JSON string as a (non-encoded)
Unicode string, while decode expects thus a Unicode string. Any decoding or encoding
(e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module.
Example, output UTF-16BE-encoded JSON:
use Encode;
$jsontext = encode "UTF-16BE", JSON::PP->new->encode ($object);
Example, decode UTF-32LE-encoded JSON:
use Encode;
$object = JSON::PP->new->decode (decode "UTF-32LE", $jsontext);
=head2 pretty
$json = $json->pretty([$enable])
This enables (or disables) all of the C<indent>, C<space_before> and
C<space_after> flags in one call to generate the most readable
(or most compact) form possible.
Equivalent to:
$json->indent->space_before->space_after
=head2 indent
$json = $json->indent([$enable])
$enabled = $json->get_indent
The default indent space length is three.
You can use C<indent_length> to change the length.
=head2 space_before
$json = $json->space_before([$enable])
$enabled = $json->get_space_before
If C<$enable> is true (or missing), then the C<encode> method will add an extra
optional space before the C<:> separating keys from values in JSON objects.
If C<$enable> is false, then the C<encode> method will not add any extra
space at those places.
This setting has no effect when decoding JSON texts.
Example, space_before enabled, space_after and indent disabled:
{"key" :"value"}
=head2 space_after
$json = $json->space_after([$enable])
$enabled = $json->get_space_after
If C<$enable> is true (or missing), then the C<encode> method will add an extra
optional space after the C<:> separating keys from values in JSON objects
and extra whitespace after the C<,> separating key-value pairs and array
members.
If C<$enable> is false, then the C<encode> method will not add any extra
space at those places.
This setting has no effect when decoding JSON texts.
Example, space_before and indent disabled, space_after enabled:
{"key": "value"}
=head2 relaxed
$json = $json->relaxed([$enable])
$enabled = $json->get_relaxed
If C<$enable> is true (or missing), then C<decode> will accept some
extensions to normal JSON syntax (see below). C<encode> will not be
affected in anyway. I<Be aware that this option makes you accept invalid
JSON texts as if they were valid!>. I suggest only to use this option to
parse application-specific files written by humans (configuration files,
resource files etc.)
If C<$enable> is false (the default), then C<decode> will only accept
valid JSON texts.
Currently accepted extensions are:
=over 4
=item * list items can have an end-comma
JSON I<separates> array elements and key-value pairs with commas. This
can be annoying if you write JSON texts manually and want to be able to
quickly append elements, so this extension accepts comma at the end of
such items not just between them:
[
1,
2, <- this comma not normally allowed
]
{
"k1": "v1",
"k2": "v2", <- this comma not normally allowed
}
=item * shell-style '#'-comments
Whenever JSON allows whitespace, shell-style comments are additionally
allowed. They are terminated by the first carriage-return or line-feed
character, after which more white-space and comments are allowed.
[
1, # this comment not allowed in JSON
# neither this one...
]
=back
=head2 canonical
$json = $json->canonical([$enable])
$enabled = $json->get_canonical
If C<$enable> is true (or missing), then the C<encode> method will output JSON objects
by sorting their keys. This is adding a comparatively high overhead.
If C<$enable> is false, then the C<encode> method will output key-value
pairs in the order Perl stores them (which will likely change between runs
of the same script).
This option is useful if you want the same data structure to be encoded as
the same JSON text (given the same overall settings). If it is disabled,
the same hash might be encoded differently even if contains the same data,
as key-value pairs have no inherent ordering in Perl.
This setting has no effect when decoding JSON texts.
If you want your own sorting routine, you can give a code referece
or a subroutine name to C<sort_by>. See to C<JSON::PP OWN METHODS>.
=head2 allow_nonref
$json = $json->allow_nonref([$enable])
$enabled = $json->get_allow_nonref
If C<$enable> is true (or missing), then the C<encode> method can convert a
non-reference into its corresponding string, number or null JSON value,
which is an extension to RFC4627. Likewise, C<decode> will accept those JSON
values instead of croaking.
If C<$enable> is false, then the C<encode> method will croak if it isn't
passed an arrayref or hashref, as JSON texts must either be an object
or array. Likewise, C<decode> will croak if given something that is not a
JSON object or array.
JSON::PP->new->allow_nonref->encode ("Hello, World!")
=> "Hello, World!"
=head2 allow_unknown
$json = $json->allow_unknown ([$enable])
$enabled = $json->get_allow_unknown
If $enable is true (or missing), then "encode" will *not* throw an
exception when it encounters values it cannot represent in JSON (for
example, filehandles) but instead will encode a JSON "null" value.
Note that blessed objects are not included here and are handled
separately by c<allow_nonref>.
If $enable is false (the default), then "encode" will throw an
exception when it encounters anything it cannot encode as JSON.
This option does not affect "decode" in any way, and it is
recommended to leave it off unless you know your communications
partner.
=head2 allow_blessed
$json = $json->allow_blessed([$enable])
$enabled = $json->get_allow_blessed
If C<$enable> is true (or missing), then the C<encode> method will not
barf when it encounters a blessed reference. Instead, the value of the
B<convert_blessed> option will decide whether C<null> (C<convert_blessed>
disabled or no C<TO_JSON> method found) or a representation of the
object (C<convert_blessed> enabled and C<TO_JSON> method found) is being
encoded. Has no effect on C<decode>.
If C<$enable> is false (the default), then C<encode> will throw an
exception when it encounters a blessed object.
=head2 convert_blessed
$json = $json->convert_blessed([$enable])
$enabled = $json->get_convert_blessed
If C<$enable> is true (or missing), then C<encode>, upon encountering a
blessed object, will check for the availability of the C<TO_JSON> method
on the object's class. If found, it will be called in scalar context
and the resulting scalar will be encoded instead of the object. If no
C<TO_JSON> method is found, the value of C<allow_blessed> will decide what
to do.
The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON>
returns other blessed objects, those will be handled in the same
way. C<TO_JSON> must take care of not causing an endless recursion cycle
(== crash) in this case. The name of C<TO_JSON> was chosen because other
methods called by the Perl core (== not by the user of the object) are
usually in upper case letters and to avoid collisions with the C<to_json>
function or method.
This setting does not yet influence C<decode> in any way.
If C<$enable> is false, then the C<allow_blessed> setting will decide what
to do when a blessed object is found.
=head2 filter_json_object
$json = $json->filter_json_object([$coderef])
When C<$coderef> is specified, it will be called from C<decode> each
time it decodes a JSON object. The only argument passed to the coderef
is a reference to the newly-created hash. If the code references returns
a single scalar (which need not be a reference), this value
(i.e. a copy of that scalar to avoid aliasing) is inserted into the
deserialised data structure. If it returns an empty list
(NOTE: I<not> C<undef>, which is a valid scalar), the original deserialised
hash will be inserted. This setting can slow down decoding considerably.
When C<$coderef> is omitted or undefined, any existing callback will
be removed and C<decode> will not change the deserialised hash in any
way.
Example, convert all JSON objects into the integer 5:
my $js = JSON::PP->new->filter_json_object (sub { 5 });
# returns [5]
$js->decode ('[{}]'); # the given subroutine takes a hash reference.
# throw an exception because allow_nonref is not enabled
# so a lone 5 is not allowed.
$js->decode ('{"a":1, "b":2}');
=head2 filter_json_single_key_object
$json = $json->filter_json_single_key_object($key [=> $coderef])
Works remotely similar to C<filter_json_object>, but is only called for
JSON objects having a single key named C<$key>.
This C<$coderef> is called before the one specified via
C<filter_json_object>, if any. It gets passed the single value in the JSON
object. If it returns a single value, it will be inserted into the data
structure. If it returns nothing (not even C<undef> but the empty list),
the callback from C<filter_json_object> will be called next, as if no
single-key callback were specified.
If C<$coderef> is omitted or undefined, the corresponding callback will be
disabled. There can only ever be one callback for a given key.
As this callback gets called less often then the C<filter_json_object>
one, decoding speed will not usually suffer as much. Therefore, single-key
objects make excellent targets to serialise Perl objects into, especially
as single-key JSON objects are as close to the type-tagged value concept
as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not
support this in any way, so you need to make sure your data never looks
like a serialised Perl hash.
Typical names for the single object key are C<__class_whatever__>, or
C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even
things like C<__class_md5sum(classname)__>, to reduce the risk of clashing
with real hashes.
Example, decode JSON objects of the form C<< { "__widget__" => <id> } >>
into the corresponding C<< $WIDGET{<id>} >> object:
# return whatever is in $WIDGET{5}:
JSON::PP
->new
->filter_json_single_key_object (__widget__ => sub {
$WIDGET{ $_[0] }
})
->decode ('{"__widget__": 5')
# this can be used with a TO_JSON method in some "widget" class
# for serialisation to json:
sub WidgetBase::TO_JSON {
my ($self) = @_;
unless ($self->{id}) {
$self->{id} = ..get..some..id..;
$WIDGET{$self->{id}} = $self;
}
{ __widget__ => $self->{id} }
}
=head2 shrink
$json = $json->shrink([$enable])
$enabled = $json->get_shrink
In JSON::XS, this flag resizes strings generated by either
C<encode> or C<decode> to their minimum size possible.
It will also try to downgrade any strings to octet-form if possible.
In JSON::PP, it is noop about resizing strings but tries
C<utf8::downgrade> to the returned string by C<encode>.
See to L<utf8>.
See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>
=head2 max_depth
$json = $json->max_depth([$maximum_nesting_depth])
$max_depth = $json->get_max_depth
Sets the maximum nesting level (default C<512>) accepted while encoding
or decoding. If a higher nesting level is detected in JSON text or a Perl
data structure, then the encoder and decoder will stop and croak at that
point.
Nesting level is defined by number of hash- or arrayrefs that the encoder
needs to traverse to reach a given point or the number of C<{> or C<[>
characters without their matching closing parenthesis crossed to reach a
given character in a string.
If no argument is given, the highest possible setting will be used, which
is rarely useful.
See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
When a large value (100 or more) was set and it de/encodes a deep nested object/text,
it may raise a warning 'Deep recursion on subroutin' at the perl runtime phase.
=head2 max_size
$json = $json->max_size([$maximum_string_size])
$max_size = $json->get_max_size
Set the maximum length a JSON text may have (in bytes) where decoding is
being attempted. The default is C<0>, meaning no limit. When C<decode>
is called on a string that is longer then this many bytes, it will not
attempt to decode the string but throw an exception. This setting has no
effect on C<encode> (yet).
If no argument is given, the limit check will be deactivated (same as when
C<0> is specified).
See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
=head2 encode
$json_text = $json->encode($perl_scalar)
Converts the given Perl data structure (a simple scalar or a reference
to a hash or array) to its JSON representation. Simple scalars will be
converted into JSON string or number sequences, while references to arrays
become JSON arrays and references to hashes become JSON objects. Undefined
Perl values (e.g. C<undef>) become JSON C<null> values.
References to the integers C<0> and C<1> are converted into C<true> and C<false>.
=head2 decode
$perl_scalar = $json->decode($json_text)
The opposite of C<encode>: expects a JSON text and tries to parse it,
returning the resulting simple scalar or reference. Croaks on error.
JSON numbers and strings become simple Perl scalars. JSON arrays become
Perl arrayrefs and JSON objects become Perl hashrefs. C<true> becomes
C<1> (C<JSON::true>), C<false> becomes C<0> (C<JSON::false>) and
C<null> becomes C<undef>.
=head2 decode_prefix
($perl_scalar, $characters) = $json->decode_prefix($json_text)
This works like the C<decode> method, but instead of raising an exception
when there is trailing garbage after the first JSON object, it will
silently stop parsing there and return the number of characters consumed
so far.
JSON->new->decode_prefix ("[1] the tail")
=> ([], 3)
=head1 INCREMENTAL PARSING
Most of this section are copied and modified from L<JSON::XS/INCREMENTAL PARSING>.
In some cases, there is the need for incremental parsing of JSON texts.
This module does allow you to parse a JSON stream incrementally.
It does so by accumulating text until it has a full JSON object, which
it then can decode. This process is similar to using C<decode_prefix>
to see if a full JSON object is available, but is much more efficient
(and can be implemented with a minimum of method calls).
This module will only attempt to parse the JSON text once it is sure it
has enough text to get a decisive result, using a very simple but
truly incremental parser. This means that it sometimes won't stop as
early as the full parser, for example, it doesn't detect parenthese
mismatches. The only thing it guarantees is that it starts decoding as
soon as a syntactically valid JSON text has been seen. This means you need
to set resource limits (e.g. C<max_size>) to ensure the parser will stop
parsing in the presence if syntax errors.
The following methods implement this incremental parser.
=head2 incr_parse
$json->incr_parse( [$string] ) # void context
$obj_or_undef = $json->incr_parse( [$string] ) # scalar context
@obj_or_empty = $json->incr_parse( [$string] ) # list context
This is the central parsing function. It can both append new text and
extract objects from the stream accumulated so far (both of these
functions are optional).
If C<$string> is given, then this string is appended to the already
existing JSON fragment stored in the C<$json> object.
After that, if the function is called in void context, it will simply
return without doing anything further. This can be used to add more text
in as many chunks as you want.
If the method is called in scalar context, then it will try to extract
exactly I<one> JSON object. If that is successful, it will return this
object, otherwise it will return C<undef>. If there is a parse error,
this method will croak just as C<decode> would do (one can then use
C<incr_skip> to skip the errornous part). This is the most common way of
using the method.
And finally, in list context, it will try to extract as many objects
from the stream as it can find and return them, or the empty list
otherwise. For this to work, there must be no separators between the JSON
objects or arrays, instead they must be concatenated back-to-back. If
an error occurs, an exception will be raised as in the scalar context
case. Note that in this case, any previously-parsed JSON texts will be
lost.
Example: Parse some JSON arrays/objects in a given string and return them.
my @objs = JSON->new->incr_parse ("[5][7][1,2]");
=head2 incr_text
$lvalue_string = $json->incr_text
This method returns the currently stored JSON fragment as an lvalue, that
is, you can manipulate it. This I<only> works when a preceding call to
C<incr_parse> in I<scalar context> successfully returned an object. Under
all other circumstances you must not call this function (I mean it.
although in simple tests it might actually work, it I<will> fail under
real world conditions). As a special exception, you can also call this
method before having parsed anything.
This function is useful in two cases: a) finding the trailing text after a
JSON object or b) parsing multiple JSON objects separated by non-JSON text
(such as commas).
$json->incr_text =~ s/\s*,\s*//;
In Perl 5.005, C<lvalue> attribute is not available.
You must write codes like the below:
$string = $json->incr_text;
$string =~ s/\s*,\s*//;
$json->incr_text( $string );
=head2 incr_skip
$json->incr_skip
This will reset the state of the incremental parser and will remove the
parsed text from the input buffer. This is useful after C<incr_parse>
died, in which case the input buffer and incremental parser state is left
unchanged, to skip the text parsed so far and to reset the parse state.
=head2 incr_reset
$json->incr_reset
This completely resets the incremental parser, that is, after this call,
it will be as if the parser had never parsed anything.
This is useful if you want ot repeatedly parse JSON objects and want to
ignore any trailing data, which means you have to reset the parser after
each successful decode.
See to L<JSON::XS/INCREMENTAL PARSING> for examples.
=head1 JSON::PP OWN METHODS
=head2 allow_singlequote
$json = $json->allow_singlequote([$enable])
If C<$enable> is true (or missing), then C<decode> will accept
JSON strings quoted by single quotations that are invalid JSON
format.
$json->allow_singlequote->decode({"foo":'bar'});
$json->allow_singlequote->decode({'foo':"bar"});
$json->allow_singlequote->decode({'foo':'bar'});
As same as the C<relaxed> option, this option may be used to parse
application-specific files written by humans.
=head2 allow_barekey
$json = $json->allow_barekey([$enable])
If C<$enable> is true (or missing), then C<decode> will accept
bare keys of JSON object that are invalid JSON format.
As same as the C<relaxed> option, this option may be used to parse
application-specific files written by humans.
$json->allow_barekey->decode('{foo:"bar"}');
=head2 allow_bignum
$json = $json->allow_bignum([$enable])
If C<$enable> is true (or missing), then C<decode> will convert
the big integer Perl cannot handle as integer into a L<Math::BigInt>
object and convert a floating number (any) into a L<Math::BigFloat>.
On the contary, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
objects into JSON numbers with C<allow_blessed> enable.
$json->allow_nonref->allow_blessed->allow_bignum;
$bigfloat = $json->decode('2.000000000000000000000000001');
print $json->encode($bigfloat);
# => 2.000000000000000000000000001
See to L<JSON::XS/MAPPING> aboout the normal conversion of JSON number.
=head2 loose
$json = $json->loose([$enable])
The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings
and the module doesn't allow to C<decode> to these (except for \x2f).
If C<$enable> is true (or missing), then C<decode> will accept these
unescaped strings.
$json->loose->decode(qq|["abc
def"]|);
See L<JSON::XS/SSECURITY CONSIDERATIONS>.
=head2 escape_slash
$json = $json->escape_slash([$enable])
According to JSON Grammar, I<slash> (U+002F) is escaped. But default
JSON::PP (as same as JSON::XS) encodes strings without escaping slash.
If C<$enable> is true (or missing), then C<encode> will escape slashes.
=head2 indent_length
$json = $json->indent_length($length)
JSON::XS indent space length is 3 and cannot be changed.
JSON::PP set the indent space length with the given $length.
The default is 3. The acceptable range is 0 to 15.
=head2 sort_by
$json = $json->sort_by($function_name)
$json = $json->sort_by($subroutine_ref)
If $function_name or $subroutine_ref are set, its sort routine are used
in encoding JSON objects.
$js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj);
# is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
$js = $pc->sort_by('own_sort')->encode($obj);
# is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b }
As the sorting routine runs in the JSON::PP scope, the given
subroutine name and the special variables C<$a>, C<$b> will begin
'JSON::PP::'.
If $integer is set, then the effect is same as C<canonical> on.
=head1 INTERNAL
For developers.
=over
=item PP_encode_box
Returns
{
depth => $depth,
indent_count => $indent_count,
}
=item PP_decode_box
Returns
{
text => $text,
at => $at,
ch => $ch,
len => $len,
depth => $depth,
encoding => $encoding,
is_valid_utf8 => $is_valid_utf8,
};
=back
=head1 MAPPING
This section is copied from JSON::XS and modified to C<JSON::PP>.
JSON::XS and JSON::PP mapping mechanisms are almost equivalent.
See to L<JSON::XS/MAPPING>.
=head2 JSON -> PERL
=over 4
=item object
A JSON object becomes a reference to a hash in Perl. No ordering of object
keys is preserved (JSON does not preserver object key ordering itself).
=item array
A JSON array becomes a reference to an array in Perl.
=item string
A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON
are represented by the same codepoints in the Perl string, so no manual
decoding is necessary.
=item number
A JSON number becomes either an integer, numeric (floating point) or
string scalar in perl, depending on its range and any fractional parts. On
the Perl level, there is no difference between those as Perl handles all
the conversion details, but an integer may take slightly less memory and
might represent more values exactly than floating point numbers.
If the number consists of digits only, C<JSON> will try to represent
it as an integer value. If that fails, it will try to represent it as
a numeric (floating point) value if that is possible without loss of
precision. Otherwise it will preserve the number as a string value (in
which case you lose roundtripping ability, as the JSON number will be
re-encoded toa JSON string).
Numbers containing a fractional or exponential part will always be
represented as numeric (floating point) values, possibly at a loss of
precision (in which case you might lose perfect roundtripping ability, but
the JSON number will still be re-encoded as a JSON number).
Note that precision is not accuracy - binary floating point values cannot
represent most decimal fractions exactly, and when converting from and to
floating point, C<JSON> only guarantees precision up to but not including
the leats significant bit.
When C<allow_bignum> is enable, the big integers
and the numeric can be optionally converted into L<Math::BigInt> and
L<Math::BigFloat> objects.
=item true, false
These JSON atoms become C<JSON::PP::true> and C<JSON::PP::false>,
respectively. They are overloaded to act almost exactly like the numbers
C<1> and C<0>. You can check wether a scalar is a JSON boolean by using
the C<JSON::is_bool> function.
print JSON::PP::true . "\n";
=> true
print JSON::PP::true + 1;
=> 1
ok(JSON::true eq '1');
ok(JSON::true == 1);
C<JSON> will install these missing overloading features to the backend modules.
=item null
A JSON null atom becomes C<undef> in Perl.
C<JSON::PP::null> returns C<unddef>.
=back
=head2 PERL -> JSON
The mapping from Perl to JSON is slightly more difficult, as Perl is a
truly typeless language, so we can only guess which JSON type is meant by
a Perl value.
=over 4
=item hash references
Perl hash references become JSON objects. As there is no inherent ordering
in hash keys (or JSON objects), they will usually be encoded in a
pseudo-random order that can change between runs of the same program but
stays generally the same within a single run of a program. C<JSON>
optionally sort the hash keys (determined by the I<canonical> flag), so
the same datastructure will serialise to the same JSON text (given same
settings and version of JSON::XS), but this incurs a runtime overhead
and is only rarely useful, e.g. when you want to compare some JSON text
against another for equality.
=item array references
Perl array references become JSON arrays.
=item other references
Other unblessed references are generally not allowed and will cause an
exception to be thrown, except for references to the integers C<0> and
C<1>, which get turned into C<false> and C<true> atoms in JSON. You can
also use C<JSON::false> and C<JSON::true> to improve readability.
to_json [\0,JSON::PP::true] # yields [false,true]
=item JSON::PP::true, JSON::PP::false, JSON::PP::null
These special values become JSON true and JSON false values,
respectively. You can also use C<\1> and C<\0> directly if you want.
JSON::PP::null returns C<undef>.
=item blessed objects
Blessed objects are not directly representable in JSON. See the
C<allow_blessed> and C<convert_blessed> methods on various options on
how to deal with this: basically, you can choose between throwing an
exception, encoding the reference as if it weren't blessed, or provide
your own serialiser method.
See to L<convert_blessed>.
=item simple scalars
Simple Perl scalars (any scalar that is not a reference) are the most
difficult objects to encode: JSON::XS and JSON::PP will encode undefined scalars as
JSON C<null> values, scalars that have last been used in a string context
before encoding as JSON strings, and anything else as number value:
# dump as number
encode_json [2] # yields [2]
encode_json [-3.0e17] # yields [-3e+17]
my $value = 5; encode_json [$value] # yields [5]
# used as string, so dump as string
print $value;
encode_json [$value] # yields ["5"]
# undef becomes null
encode_json [undef] # yields [null]
You can force the type to be a string by stringifying it:
my $x = 3.1; # some variable containing a number
"$x"; # stringified
$x .= ""; # another, more awkward way to stringify
print $x; # perl does it for you, too, quite often
You can force the type to be a number by numifying it:
my $x = "3"; # some variable containing a string
$x += 0; # numify it, ensuring it will be dumped as a number
$x *= 1; # same thing, the choise is yours.
You can not currently force the type in other, less obscure, ways.
Note that numerical precision has the same meaning as under Perl (so
binary to decimal conversion follows the same rules as in Perl, which
can differ to other languages). Also, your perl interpreter might expose
extensions to the floating point numbers of your platform, such as
infinities or NaN's - these cannot be represented in JSON, and it is an
error to pass those in.
=item Big Number
When C<allow_bignum> is enable,
C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
objects into JSON numbers.
=back
=head1 UNICODE HANDLING ON PERLS
If you do not know about Unicode on Perl well,
please check L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>.
=head2 Perl 5.8 and later
Perl can handle Unicode and the JSON::PP de/encode methods also work properly.
$json->allow_nonref->encode(chr hex 3042);
$json->allow_nonref->encode(chr hex 12345);
Reuturns C<"\u3042"> and C<"\ud808\udf45"> respectively.
$json->allow_nonref->decode('"\u3042"');
$json->allow_nonref->decode('"\ud808\udf45"');
Returns UTF-8 encoded strings with UTF8 flag, regarded as C<U+3042> and C<U+12345>.
Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C<join> was broken,
so JSON::PP wraps the C<join> with a subroutine. Thus JSON::PP works slow in the versions.
=head2 Perl 5.6
Perl can handle Unicode and the JSON::PP de/encode methods also work.
=head2 Perl 5.005
Perl 5.005 is a byte sementics world -- all strings are sequences of bytes.
That means the unicode handling is not available.
In encoding,
$json->allow_nonref->encode(chr hex 3042); # hex 3042 is 12354.
$json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565.
Returns C<B> and C<E>, as C<chr> takes a value more than 255, it treats
as C<$value % 256>, so the above codes are equivalent to :
$json->allow_nonref->encode(chr 66);
$json->allow_nonref->encode(chr 69);
In decoding,
$json->decode('"\u00e3\u0081\u0082"');
The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded
japanese character (C<HIRAGANA LETTER A>).
And if it is represented in Unicode code point, C<U+3042>.
Next,
$json->decode('"\u3042"');
We ordinary expect the returned value is a Unicode character C<U+3042>.
But here is 5.005 world. This is C<0xE3 0x81 0x82>.
$json->decode('"\ud808\udf45"');
This is not a character C<U+12345> but bytes - C<0xf0 0x92 0x8d 0x85>.
=head1 TODO
=over
=item speed
=item memory saving
=back
=head1 SEE ALSO
Most of the document are copied and modified from JSON::XS doc.
L<JSON::XS>
RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>)
=head1 AUTHOR
Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright 2007-2013 by Makamaka Hannyaharamitu
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
JSON_PP
$fatpacked{"JSON/PP/Boolean.pm"} = <<'JSON_PP_BOOLEAN';
=head1 NAME
JSON::PP::Boolean - dummy module providing JSON::PP::Boolean
=head1 SYNOPSIS
# do not "use" yourself
=head1 DESCRIPTION
This module exists only to provide overload resolution for Storable and similar modules. See
L<JSON::PP> for more info about this class.
=cut
use JSON::PP ();
use strict;
1;
=head1 AUTHOR
This idea is from L<JSON::XS::Boolean> written by Marc Lehmann <schmorp[at]schmorp.de>
=cut
JSON_PP_BOOLEAN
$fatpacked{"Module/CPANfile.pm"} = <<'MODULE_CPANFILE';
package Module::CPANfile;
use strict;
use warnings;
use Cwd;
use Carp ();
use Module::CPANfile::Environment;
use Module::CPANfile::Result;
our $VERSION = '0.9036';
sub new {
my($class, $file) = @_;
bless {}, $class;
}
sub load {
my($proto, $file) = @_;
my $self = ref $proto ? $proto : $proto->new;
$self->parse($file || Cwd::abs_path('cpanfile'));
$self;
}
sub save {
my($self, $path) = @_;
open my $out, ">", $path or die "$path: $!";
print {$out} $self->to_string;
}
sub parse {
my($self, $file) = @_;
my $code = do {
open my $fh, "<", $file or die "$file: $!";
join '', <$fh>;
};
my $env = Module::CPANfile::Environment->new($file);
$self->{result} = $env->parse($code) or die $@;
}
sub from_prereqs {
my($proto, $prereqs) = @_;
my $self = $proto->new;
$self->{result} = Module::CPANfile::Result->from_prereqs($prereqs);
$self;
}
sub features {
my $self = shift;
map $self->feature($_), keys %{$self->{result}{features}};
}
sub feature {
my($self, $identifier) = @_;
my $data = $self->{result}{features}{$identifier}
or Carp::croak("Unknown feature '$identifier'");
require CPAN::Meta::Feature;
CPAN::Meta::Feature->new($data->{identifier}, {
description => $data->{description},
prereqs => $data->{spec},
});
}
sub prereq { shift->prereqs }
sub prereqs {
my $self = shift;
require CPAN::Meta::Prereqs;
CPAN::Meta::Prereqs->new($self->prereq_specs);
}
sub effective_prereqs {
my($self, $features) = @_;
$self->prereqs_with(@{$features || []});
}
sub prereqs_with {
my($self, @feature_identifiers) = @_;
my $prereqs = $self->prereqs;
my @others = map { $self->feature($_)->prereqs } @feature_identifiers;
$prereqs->with_merged_prereqs(\@others);
}
sub prereq_specs {
my $self = shift;
$self->{result}{spec};
}
sub merge_meta {
my($self, $file, $version) = @_;
require CPAN::Meta;
$version ||= $file =~ /\.yml$/ ? '1.4' : '2';
my $prereq = $self->prereqs;
my $meta = CPAN::Meta->load_file($file);
my $prereqs_hash = $prereq->with_merged_prereqs($meta->effective_prereqs)->as_string_hash;
my $struct = { %{$meta->as_struct}, prereqs => $prereqs_hash };
CPAN::Meta->new($struct)->save($file, { version => $version });
}
sub _dump {
my $str = shift;
require Data::Dumper;
chomp(my $value = Data::Dumper->new([$str])->Terse(1)->Dump);
$value;
}
sub to_string {
my($self, $include_empty) = @_;
my $prereqs = $self->{result}{spec};
my $code = '';
$code .= $self->_dump_prereqs($self->{result}{spec}, $include_empty);
for my $feature (values %{$self->{result}{features}}) {
$code .= sprintf "feature %s, %s => sub {\n", _dump($feature->{identifier}), _dump($feature->{description});
$code .= $self->_dump_prereqs($feature->{spec}, $include_empty, 4);
$code .= "}\n\n";
}
$code =~ s/\n+$/\n/s;
$code;
}
sub _dump_prereqs {
my($self, $prereqs, $include_empty, $base_indent) = @_;
my $code = '';
for my $phase (qw(runtime configure build test develop)) {
my $indent = $phase eq 'runtime' ? '' : ' ';
$indent = (' ' x ($base_indent || 0)) . $indent;
my($phase_code, $requirements);
$phase_code .= "on $phase => sub {\n" unless $phase eq 'runtime';
for my $type (qw(requires recommends suggests conflicts)) {
for my $mod (sort keys %{$prereqs->{$phase}{$type}}) {
my $ver = $prereqs->{$phase}{$type}{$mod};
$phase_code .= $ver eq '0'
? "${indent}$type '$mod';\n"
: "${indent}$type '$mod', '$ver';\n";
$requirements++;
}
}
$phase_code .= "\n" unless $requirements;
$phase_code .= "};\n" unless $phase eq 'runtime';
$code .= $phase_code . "\n" if $requirements or $include_empty;
}
$code =~ s/\n+$/\n/s;
$code;
}
1;
__END__
=head1 NAME
Module::CPANfile - Parse cpanfile
=head1 SYNOPSIS
use Module::CPANfile;
my $file = Module::CPANfile->load("cpanfile");
my $prereqs = $file->prereqs; # CPAN::Meta::Prereqs object
my @features = $file->features; # CPAN::Meta::Feature objects
my $merged_prereqs = $file->prereqs_with(@identifiers); # CPAN::Meta::Prereqs
$file->merge_meta('MYMETA.json');
=head1 DESCRIPTION
Module::CPANfile is a tool to handle L<cpanfile> format to load application
specific dependencies, not just for CPAN distributions.
=head1 METHODS
=over 4
=item load
$file = Module::CPANfile->load;
$file = Module::CPANfile->load('cpanfile');
Load and parse a cpanfile. By default it tries to load C<cpanfile> in
the current directory, unless you pass the path to its argument.
=item from_prereqs
$file = Module::CPANfile->from_prereqs({
runtime => { requires => { DBI => '1.000' } },
});
Creates a new Module::CPANfile object from prereqs hash you can get
via L<CPAN::Meta>'s C<prereqs>, or L<CPAN::Meta::Prereqs>'
C<as_string_hash>.
# read MYMETA, then feed the prereqs to create Module::CPANfile
my $meta = CPAN::Meta->load_file('MYMETA.json');
my $file = Module::CPANfile->from_prereqs($meta->prereqs);
# load cpanfile, then recreate it with round-trip
my $file = Module::CPANfile->load('cpanfile');
$file = Module::CPANfile->from_prereqs($file->prereq_specs);
# or $file->prereqs->as_string_hash
=item prereqs
Returns L<CPAN::Meta::Prereqs> object out of the parsed cpanfile.
=item prereq_specs
Returns a hash reference that should be passed to C<< CPAN::Meta::Prereqs->new >>.
=item features
Returns a list of features available in the cpanfile as L<CPAN::Meta::Feature>.
=item prereqs_with(@identifiers), effective_prereqs(\@identifiers)
Returns L<CPAN::Meta::Prereqs> object, with merged prereqs for
features identified with the C<@identifiers>.
=item to_string($include_empty)
$file->to_string;
$file->to_string(1);
Returns a canonical string (code) representation for cpanfile. Useful
if you want to convert L<CPAN::Meta::Prereqs> to a new cpanfile.
# read MYMETA's prereqs and print cpanfile representation of it
my $meta = CPAN::Meta->load_file('MYMETA.json');
my $file = Module::CPANfile->from_prereqs($meta->prereqs);
print $file->to_sring;
By default, it omits the phase where there're no modules
registered. If you pass the argument of a true value, it will print
them as well.
=item save
$file->save('cpanfile');
Saves the currently loaded prereqs as a new C<cpanfile> by calling
C<to_string>. Beware B<this method will overwrite the existing
cpanfile without any warning or backup>. Taking a backup or giving
warnings to users is a caller's responsibility.
# Read MYMETA.json and creates a new cpanfile
my $meta = CPAN::Meta->load_file('MYMETA.json');
my $file = Module::CPANfile->from_prereqs($meta->prereqs);
$file->save('cpanfile');
=item merge_meta
$file->merge_meta('META.yml');
$file->merge_meta('MYMETA.json', '2.0');
Merge the effective prereqs with Meta specification loaded from the
given META file, using CPAN::Meta. You can specify the META spec
version in the second argument, which defaults to 1.4 in case the
given file is YAML, and 2 if it is JSON.
=back
=head1 AUTHOR
Tatsuhiko Miyagawa
=head1 SEE ALSO
L<cpanfile>, L<CPAN::Meta>, L<CPAN::Meta::Spec>
=cut
MODULE_CPANFILE
$fatpacked{"Module/CPANfile/Environment.pm"} = <<'MODULE_CPANFILE_ENVIRONMENT';
package Module::CPANfile::Environment;
use strict;
use warnings;
use Module::CPANfile::Result;
use Carp ();
my @bindings = qw(
on requires recommends suggests conflicts
feature
osname
configure_requires build_requires test_requires author_requires
);
my $file_id = 1;
sub new {
my($class, $file) = @_;
bless {
file => $file,
}, $class;
}
sub bind {
my $class = shift;
my $pkg = caller;
my $result = Module::CPANfile::Result->new;
for my $binding (@bindings) {
no strict 'refs';
*{"$pkg\::$binding"} = sub { $result->$binding(@_) };
}
return $result;
}
sub parse {
my($self, $code) = @_;
my($res, $err);
{
local $@;
$file_id++;
$res = eval <<EVAL;
package Module::CPANfile::Sandbox$file_id;
no warnings;
my \$_result;
BEGIN { \$_result = Module::CPANfile::Environment->bind }
# line 1 "$self->{file}"
$code;
\$_result;
EVAL
$err = $@;
}
if ($err) { die "Parsing $self->{file} failed: $err" };
return $res;
}
1;
MODULE_CPANFILE_ENVIRONMENT
$fatpacked{"Module/CPANfile/Result.pm"} = <<'MODULE_CPANFILE_RESULT';
package Module::CPANfile::Result;
use strict;
sub from_prereqs {
my($class, $spec) = @_;
bless {
phase => 'runtime',
spec => $spec,
}, $class;
}
sub new {
bless {
phase => 'runtime', # default phase
features => {},
feature => undef,
spec => {},
}, shift;
}
sub on {
my($self, $phase, $code) = @_;
local $self->{phase} = $phase;
$code->()
}
sub feature {
my($self, $identifier, $description, $code) = @_;
# shortcut: feature identifier => sub { ... }
if (@_ == 3 && ref($description) eq 'CODE') {
$code = $description;
$description = $identifier;
}
unless (ref $description eq '' && ref $code eq 'CODE') {
Carp::croak("Usage: feature 'identifier', 'Description' => sub { ... }");
}
local $self->{feature} = $self->{features}{$identifier}
= { identifier => $identifier, description => $description, spec => {} };
$code->();
}
sub osname { die "TODO" }
sub requires {
my($self, $module, $requirement) = @_;
($self->{feature} ? $self->{feature}{spec} : $self->{spec})
->{$self->{phase}}{requires}{$module} = $requirement || 0;
}
sub recommends {
my($self, $module, $requirement) = @_;
($self->{feature} ? $self->{feature}{spec} : $self->{spec})
->{$self->{phase}}{recommends}{$module} = $requirement || 0;
}
sub suggests {
my($self, $module, $requirement) = @_;
($self->{feature} ? $self->{feature}{spec} : $self->{spec})
->{$self->{phase}}{suggests}{$module} = $requirement || 0;
}
sub conflicts {
my($self, $module, $requirement) = @_;
($self->{feature} ? $self->{feature}{spec} : $self->{spec})
->{$self->{phase}}{conflicts}{$module} = $requirement || 0;
}
# Module::Install compatible shortcuts
sub configure_requires {
my($self, @args) = @_;
$self->on(configure => sub { $self->requires(@args) });
}
sub build_requires {
my($self, @args) = @_;
$self->on(build => sub { $self->requires(@args) });
}
sub test_requires {
my($self, @args) = @_;
$self->on(test => sub { $self->requires(@args) });
}
sub author_requires {
my($self, @args) = @_;
$self->on(develop => sub { $self->requires(@args) });
}
1;
MODULE_CPANFILE_RESULT
$fatpacked{"Module/Metadata.pm"} = <<'MODULE_METADATA';
# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
# vim:ts=8:sw=2:et:sta:sts=2
package Module::Metadata;
# Adapted from Perl-licensed code originally distributed with
# Module-Build by Ken Williams
# This module provides routines to gather information about
# perl modules (assuming this may be expanded in the distant
# parrot future to look at other types of modules).
use strict;
use vars qw($VERSION);
$VERSION = '1.000014';
$VERSION = eval $VERSION;
use Carp qw/croak/;
use File::Spec;
use IO::File;
use version 0.87;
BEGIN {
if ($INC{'Log/Contextual.pm'}) {
Log::Contextual->import('log_info');
} else {
*log_info = sub (&) { warn $_[0]->() };
}
}
use File::Find qw(find);
my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal
my $PKG_FIRST_WORD_REGEXP = qr{ # the FIRST word in a package name
[a-zA-Z_] # the first word CANNOT start with a digit
(?:
[\w']? # can contain letters, digits, _, or ticks
\w # But, NO multi-ticks or trailing ticks
)*
}x;
my $PKG_ADDL_WORD_REGEXP = qr{ # the 2nd+ word in a package name
\w # the 2nd+ word CAN start with digits
(?:
[\w']? # and can contain letters or ticks
\w # But, NO multi-ticks or trailing ticks
)*
}x;
my $PKG_NAME_REGEXP = qr{ # match a package name
(?: :: )? # a pkg name can start with aristotle
$PKG_FIRST_WORD_REGEXP # a package word
(?:
(?: :: )+ ### aristotle (allow one or many times)
$PKG_ADDL_WORD_REGEXP ### a package word
)* # ^ zero, one or many times
(?:
:: # allow trailing aristotle
)?
}x;
my $PKG_REGEXP = qr{ # match a package declaration
^[\s\{;]* # intro chars on a line
package # the word 'package'
\s+ # whitespace
($PKG_NAME_REGEXP) # a package name
\s* # optional whitespace
($V_NUM_REGEXP)? # optional version number
\s* # optional whitesapce
[;\{] # semicolon line terminator or block start (since 5.16)
}x;
my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
([\$*]) # sigil - $ or *
(
( # optional leading package name
(?:::|\')? # possibly starting like just :: (Ì la $::VERSION)
(?:\w+(?:::|\'))* # Foo::Bar:: ...
)?
VERSION
)\b
}x;
my $VERS_REGEXP = qr{ # match a VERSION definition
(?:
\(\s*$VARNAME_REGEXP\s*\) # with parens
|
$VARNAME_REGEXP # without parens
)
\s*
=[^=~] # = but not ==, nor =~
}x;
sub new_from_file {
my $class = shift;
my $filename = File::Spec->rel2abs( shift );
return undef unless defined( $filename ) && -f $filename;
return $class->_init(undef, $filename, @_);
}
sub new_from_handle {
my $class = shift;
my $handle = shift;
my $filename = shift;
return undef unless defined($handle) && defined($filename);
$filename = File::Spec->rel2abs( $filename );
return $class->_init(undef, $filename, @_, handle => $handle);
}
sub new_from_module {
my $class = shift;
my $module = shift;
my %props = @_;
$props{inc} ||= \@INC;
my $filename = $class->find_module_by_name( $module, $props{inc} );
return undef unless defined( $filename ) && -f $filename;
return $class->_init($module, $filename, %props);
}
{
my $compare_versions = sub {
my ($v1, $op, $v2) = @_;
$v1 = version->new($v1)
unless UNIVERSAL::isa($v1,'version');
my $eval_str = "\$v1 $op \$v2";
my $result = eval $eval_str;
log_info { "error comparing versions: '$eval_str' $@" } if $@;
return $result;
};
my $normalize_version = sub {
my ($version) = @_;
if ( $version =~ /[=<>!,]/ ) { # logic, not just version
# take as is without modification
}
elsif ( ref $version eq 'version' ) { # version objects
$version = $version->is_qv ? $version->normal : $version->stringify;
}
elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
# normalize string tuples without "v": "1.2.3" -> "v1.2.3"
$version = "v$version";
}
else {
# leave alone
}
return $version;
};
# separate out some of the conflict resolution logic
my $resolve_module_versions = sub {
my $packages = shift;
my( $file, $version );
my $err = '';
foreach my $p ( @$packages ) {
if ( defined( $p->{version} ) ) {
if ( defined( $version ) ) {
if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
$err .= " $p->{file} ($p->{version})\n";
} else {
# same version declared multiple times, ignore
}
} else {
$file = $p->{file};
$version = $p->{version};
}
}
$file ||= $p->{file} if defined( $p->{file} );
}
if ( $err ) {
$err = " $file ($version)\n" . $err;
}
my %result = (
file => $file,
version => $version,
err => $err
);
return \%result;
};
sub provides {
my $class = shift;
croak "provides() requires key/value pairs \n" if @_ % 2;
my %args = @_;
croak "provides() takes only one of 'dir' or 'files'\n"
if $args{dir} && $args{files};
croak "provides() requires a 'version' argument"
unless defined $args{version};
croak "provides() does not support version '$args{version}' metadata"
unless grep { $args{version} eq $_ } qw/1.4 2/;
$args{prefix} = 'lib' unless defined $args{prefix};
my $p;
if ( $args{dir} ) {
$p = $class->package_versions_from_directory($args{dir});
}
else {
croak "provides() requires 'files' to be an array reference\n"
unless ref $args{files} eq 'ARRAY';
$p = $class->package_versions_from_directory($args{files});
}
# Now, fix up files with prefix
if ( length $args{prefix} ) { # check in case disabled with q{}
$args{prefix} =~ s{/$}{};
for my $v ( values %$p ) {
$v->{file} = "$args{prefix}/$v->{file}";
}
}
return $p
}
sub package_versions_from_directory {
my ( $class, $dir, $files ) = @_;
my @files;
if ( $files ) {
@files = @$files;
} else {
find( {
wanted => sub {
push @files, $_ if -f $_ && /\.pm$/;
},
no_chdir => 1,
}, $dir );
}
# First, we enumerate all packages & versions,
# separating into primary & alternative candidates
my( %prime, %alt );
foreach my $file (@files) {
my $mapped_filename = File::Spec::Unix->abs2rel( $file, $dir );
my @path = split( /\//, $mapped_filename );
(my $prime_package = join( '::', @path )) =~ s/\.pm$//;
my $pm_info = $class->new_from_file( $file );
foreach my $package ( $pm_info->packages_inside ) {
next if $package eq 'main'; # main can appear numerous times, ignore
next if $package eq 'DB'; # special debugging package, ignore
next if grep /^_/, split( /::/, $package ); # private package, ignore
my $version = $pm_info->version( $package );
$prime_package = $package if lc($prime_package) eq lc($package);
if ( $package eq $prime_package ) {
if ( exists( $prime{$package} ) ) {
croak "Unexpected conflict in '$package'; multiple versions found.\n";
} else {
$mapped_filename = "$package.pm" if lc("$package.pm") eq lc($mapped_filename);
$prime{$package}{file} = $mapped_filename;
$prime{$package}{version} = $version if defined( $version );
}
} else {
push( @{$alt{$package}}, {
file => $mapped_filename,
version => $version,
} );
}
}
}
# Then we iterate over all the packages found above, identifying conflicts
# and selecting the "best" candidate for recording the file & version
# for each package.
foreach my $package ( keys( %alt ) ) {
my $result = $resolve_module_versions->( $alt{$package} );
if ( exists( $prime{$package} ) ) { # primary package selected
if ( $result->{err} ) {
# Use the selected primary package, but there are conflicting
# errors among multiple alternative packages that need to be
# reported
log_info {
"Found conflicting versions for package '$package'\n" .
" $prime{$package}{file} ($prime{$package}{version})\n" .
$result->{err}
};
} elsif ( defined( $result->{version} ) ) {
# There is a primary package selected, and exactly one
# alternative package
if ( exists( $prime{$package}{version} ) &&
defined( $prime{$package}{version} ) ) {
# Unless the version of the primary package agrees with the
# version of the alternative package, report a conflict
if ( $compare_versions->(
$prime{$package}{version}, '!=', $result->{version}
)
) {
log_info {
"Found conflicting versions for package '$package'\n" .
" $prime{$package}{file} ($prime{$package}{version})\n" .
" $result->{file} ($result->{version})\n"
};
}
} else {
# The prime package selected has no version so, we choose to
# use any alternative package that does have a version
$prime{$package}{file} = $result->{file};
$prime{$package}{version} = $result->{version};
}
} else {
# no alt package found with a version, but we have a prime
# package so we use it whether it has a version or not
}
} else { # No primary package was selected, use the best alternative
if ( $result->{err} ) {
log_info {
"Found conflicting versions for package '$package'\n" .
$result->{err}
};
}
# Despite possible conflicting versions, we choose to record
# something rather than nothing
$prime{$package}{file} = $result->{file};
$prime{$package}{version} = $result->{version}
if defined( $result->{version} );
}
}
# Normalize versions. Can't use exists() here because of bug in YAML::Node.
# XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18
for (grep defined $_->{version}, values %prime) {
$_->{version} = $normalize_version->( $_->{version} );
}
return \%prime;
}
}
sub _init {
my $class = shift;
my $module = shift;
my $filename = shift;
my %props = @_;
my $handle = delete $props{handle};
my( %valid_props, @valid_props );
@valid_props = qw( collect_pod inc );
@valid_props{@valid_props} = delete( @props{@valid_props} );
warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
my %data = (
module => $module,
filename => $filename,
version => undef,
packages => [],
versions => {},
pod => {},
pod_headings => [],
collect_pod => 0,
%valid_props,
);
my $self = bless(\%data, $class);
if ( $handle ) {
$self->_parse_fh($handle);
}
else {
$self->_parse_file();
}
unless($self->{module} and length($self->{module})) {
my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
if($f =~ /\.pm$/) {
$f =~ s/\..+$//;
my @candidates = grep /$f$/, @{$self->{packages}};
$self->{module} = shift(@candidates); # punt
}
else {
if(grep /main/, @{$self->{packages}}) {
$self->{module} = 'main';
}
else {
$self->{module} = $self->{packages}[0] || '';
}
}
}
$self->{version} = $self->{versions}{$self->{module}}
if defined( $self->{module} );
return $self;
}
# class method
sub _do_find_module {
my $class = shift;
my $module = shift || croak 'find_module_by_name() requires a package name';
my $dirs = shift || \@INC;
my $file = File::Spec->catfile(split( /::/, $module));
foreach my $dir ( @$dirs ) {
my $testfile = File::Spec->catfile($dir, $file);
return [ File::Spec->rel2abs( $testfile ), $dir ]
if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
if -e "$testfile.pm";
}
return;
}
# class method
sub find_module_by_name {
my $found = shift()->_do_find_module(@_) or return;
return $found->[0];
}
# class method
sub find_module_dir_by_name {
my $found = shift()->_do_find_module(@_) or return;
return $found->[1];
}
# given a line of perl code, attempt to parse it if it looks like a
# $VERSION assignment, returning sigil, full name, & package name
sub _parse_version_expression {
my $self = shift;
my $line = shift;
my( $sig, $var, $pkg );
if ( $line =~ /$VERS_REGEXP/o ) {
( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
if ( $pkg ) {
$pkg = ($pkg eq '::') ? 'main' : $pkg;
$pkg =~ s/::$//;
}
}
return ( $sig, $var, $pkg );
}
sub _parse_file {
my $self = shift;
my $filename = $self->{filename};
my $fh = IO::File->new( $filename )
or croak( "Can't open '$filename': $!" );
$self->_handle_bom($fh, $filename);
$self->_parse_fh($fh);
}
# Look for a UTF-8/UTF-16BE/UTF-16LE BOM at the beginning of the stream.
# If there's one, then skip it and set the :encoding layer appropriately.
sub _handle_bom {
my ($self, $fh, $filename) = @_;
my $pos = $fh->getpos;
return unless defined $pos;
my $buf = ' ' x 2;
my $count = $fh->read( $buf, length $buf );
return unless defined $count and $count >= 2;
my $encoding;
if ( $buf eq "\x{FE}\x{FF}" ) {
$encoding = 'UTF-16BE';
} elsif ( $buf eq "\x{FF}\x{FE}" ) {
$encoding = 'UTF-16LE';
} elsif ( $buf eq "\x{EF}\x{BB}" ) {
$buf = ' ';
$count = $fh->read( $buf, length $buf );
if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) {
$encoding = 'UTF-8';
}
}
if ( defined $encoding ) {
if ( "$]" >= 5.008 ) {
# $fh->binmode requires perl 5.10
binmode( $fh, ":encoding($encoding)" );
}
} else {
$fh->setpos($pos)
or croak( sprintf "Can't reset position to the top of '$filename'" );
}
return $encoding;
}
sub _parse_fh {
my ($self, $fh) = @_;
my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
my( @pkgs, %vers, %pod, @pod );
my $pkg = 'main';
my $pod_sect = '';
my $pod_data = '';
my $in_end = 0;
while (defined( my $line = <$fh> )) {
my $line_num = $.;
chomp( $line );
# From toke.c : any line that begins by "=X", where X is an alphabetic
# character, introduces a POD segment.
my $is_cut;
if ( $line =~ /^=([a-zA-Z].*)/ ) {
my $cmd = $1;
# Then it goes back to Perl code for "=cutX" where X is a non-alphabetic
# character (which includes the newline, but here we chomped it away).
$is_cut = $cmd =~ /^cut(?:[^a-zA-Z]|$)/;
$in_pod = !$is_cut;
}
if ( $in_pod ) {
if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) {
push( @pod, $1 );
if ( $self->{collect_pod} && length( $pod_data ) ) {
$pod{$pod_sect} = $pod_data;
$pod_data = '';
}
$pod_sect = $1;
} elsif ( $self->{collect_pod} ) {
$pod_data .= "$line\n";
}
} elsif ( $is_cut ) {
if ( $self->{collect_pod} && length( $pod_data ) ) {
$pod{$pod_sect} = $pod_data;
$pod_data = '';
}
$pod_sect = '';
} else {
# Skip after __END__
next if $in_end;
# Skip comments in code
next if $line =~ /^\s*#/;
# Would be nice if we could also check $in_string or something too
if ($line eq '__END__') {
$in_end++;
next;
}
last if $line eq '__DATA__';
# parse $line to see if it's a $VERSION declaration
my( $vers_sig, $vers_fullname, $vers_pkg ) =
($line =~ /VERSION/)
? $self->_parse_version_expression( $line )
: ();
if ( $line =~ /$PKG_REGEXP/o ) {
$pkg = $1;
push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
$vers{$pkg} = $2 unless exists( $vers{$pkg} );
$need_vers = defined $2 ? 0 : 1;
# VERSION defined with full package spec, i.e. $Module::VERSION
} elsif ( $vers_fullname && $vers_pkg ) {
push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
$need_vers = 0 if $vers_pkg eq $pkg;
unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
$vers{$vers_pkg} =
$self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
}
# first non-comment line in undeclared package main is VERSION
} elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
$need_vers = 0;
my $v =
$self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
$vers{$pkg} = $v;
push( @pkgs, 'main' );
# first non-comment line in undeclared package defines package main
} elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
$need_vers = 1;
$vers{main} = '';
push( @pkgs, 'main' );
# only keep if this is the first $VERSION seen
} elsif ( $vers_fullname && $need_vers ) {
$need_vers = 0;
my $v =
$self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
$vers{$pkg} = $v;
}
}
}
}
if ( $self->{collect_pod} && length($pod_data) ) {
$pod{$pod_sect} = $pod_data;
}
$self->{versions} = \%vers;
$self->{packages} = \@pkgs;
$self->{pod} = \%pod;
$self->{pod_headings} = \@pod;
}
{
my $pn = 0;
sub _evaluate_version_line {
my $self = shift;
my( $sigil, $var, $line ) = @_;
# Some of this code came from the ExtUtils:: hierarchy.
# We compile into $vsub because 'use version' would cause
# compiletime/runtime issues with local()
my $vsub;
$pn++; # everybody gets their own package
my $eval = qq{BEGIN { q# Hide from _packages_inside()
#; package Module::Metadata::_version::p$pn;
use version;
no strict;
\$vsub = sub {
local $sigil$var;
\$$var=undef;
$line;
\$$var
};
}};
local $^W;
# Try to get the $VERSION
eval $eval;
# some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
# installed, so we need to hunt in ./lib for it
if ( $@ =~ /Can't locate/ && -d 'lib' ) {
local @INC = ('lib',@INC);
eval $eval;
}
warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
if $@;
(ref($vsub) eq 'CODE') or
croak "failed to build version sub for $self->{filename}";
my $result = eval { $vsub->() };
croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
if $@;
# Upgrade it into a version object
my $version = eval { _dwim_version($result) };
croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
unless defined $version; # "0" is OK!
return $version;
}
}
# Try to DWIM when things fail the lax version test in obvious ways
{
my @version_prep = (
# Best case, it just works
sub { return shift },
# If we still don't have a version, try stripping any
# trailing junk that is prohibited by lax rules
sub {
my $v = shift;
$v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
return $v;
},
# Activestate apparently creates custom versions like '1.23_45_01', which
# cause version.pm to think it's an invalid alpha. So check for that
# and strip them
sub {
my $v = shift;
my $num_dots = () = $v =~ m{(\.)}g;
my $num_unders = () = $v =~ m{(_)}g;
my $leading_v = substr($v,0,1) eq 'v';
if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
$v =~ s{_}{}g;
$num_unders = () = $v =~ m{(_)}g;
}
return $v;
},
# Worst case, try numifying it like we would have before version objects
sub {
my $v = shift;
no warnings 'numeric';
return 0 + $v;
},
);
sub _dwim_version {
my ($result) = shift;
return $result if ref($result) eq 'version';
my ($version, $error);
for my $f (@version_prep) {
$result = $f->($result);
$version = eval { version->new($result) };
$error ||= $@ if $@; # capture first failure
last if defined $version;
}
croak $error unless defined $version;
return $version;
}
}
############################################################
# accessors
sub name { $_[0]->{module} }
sub filename { $_[0]->{filename} }
sub packages_inside { @{$_[0]->{packages}} }
sub pod_inside { @{$_[0]->{pod_headings}} }
sub contains_pod { 0+@{$_[0]->{pod_headings}} }
sub version {
my $self = shift;
my $mod = shift || $self->{module};
my $vers;
if ( defined( $mod ) && length( $mod ) &&
exists( $self->{versions}{$mod} ) ) {
return $self->{versions}{$mod};
} else {
return undef;
}
}
sub pod {
my $self = shift;
my $sect = shift;
if ( defined( $sect ) && length( $sect ) &&
exists( $self->{pod}{$sect} ) ) {
return $self->{pod}{$sect};
} else {
return undef;
}
}
1;
=head1 NAME
Module::Metadata - Gather package and POD information from perl module files
=head1 SYNOPSIS
use Module::Metadata;
# information about a .pm file
my $info = Module::Metadata->new_from_file( $file );
my $version = $info->version;
# CPAN META 'provides' field for .pm files in a directory
my $provides = Module::Metadata->provides(
dir => 'lib', version => 2
);
=head1 DESCRIPTION
This module provides a standard way to gather metadata about a .pm file
without executing unsafe code.
=head1 USAGE
=head2 Class methods
=over 4
=item C<< new_from_file($filename, collect_pod => 1) >>
Constructs a C<Module::Metadata> object given the path to a file. Returns
undef if the filename does not exist.
C<collect_pod> is a optional boolean argument that determines whether POD
data is collected and stored for reference. POD data is not collected by
default. POD headings are always collected.
If the file begins by an UTF-8, UTF-16BE or UTF-16LE byte-order mark, then
it is skipped before processing, and the content of the file is also decoded
appropriately starting from perl 5.8.
=item C<< new_from_handle($handle, $filename, collect_pod => 1) >>
This works just like C<new_from_file>, except that a handle can be provided
as the first argument.
Note that there is no validation to confirm that the handle is a handle or
something that can act like one. Passing something that isn't a handle will
cause a exception when trying to read from it. The C<filename> argument is
mandatory or undef will be returned.
You are responsible for setting the decoding layers on C<$handle> if
required.
=item C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >>
Constructs a C<Module::Metadata> object given a module or package name.
Returns undef if the module cannot be found.
In addition to accepting the C<collect_pod> argument as described above,
this method accepts a C<inc> argument which is a reference to an array of
directories to search for the module. If none are given, the default is
@INC.
If the file that contains the module begins by an UTF-8, UTF-16BE or
UTF-16LE byte-order mark, then it is skipped before processing, and the
content of the file is also decoded appropriately starting from perl 5.8.
=item C<< find_module_by_name($module, \@dirs) >>
Returns the path to a module given the module or package name. A list
of directories can be passed in as an optional parameter, otherwise
@INC is searched.
Can be called as either an object or a class method.
=item C<< find_module_dir_by_name($module, \@dirs) >>
Returns the entry in C<@dirs> (or C<@INC> by default) that contains
the module C<$module>. A list of directories can be passed in as an
optional parameter, otherwise @INC is searched.
Can be called as either an object or a class method.
=item C<< provides( %options ) >>
This is a convenience wrapper around C<package_versions_from_directory>
to generate a CPAN META C<provides> data structure. It takes key/value
pairs. Valid option keys include:
=over
=item version B<(required)>
Specifies which version of the L<CPAN::Meta::Spec> should be used as
the format of the C<provides> output. Currently only '1.4' and '2'
are supported (and their format is identical). This may change in
the future as the definition of C<provides> changes.
The C<version> option is required. If it is omitted or if
an unsupported version is given, then C<provides> will throw an error.
=item dir
Directory to search recursively for F<.pm> files. May not be specified with
C<files>.
=item files
Array reference of files to examine. May not be specified with C<dir>.
=item prefix
String to prepend to the C<file> field of the resulting output. This defaults
to F<lib>, which is the common case for most CPAN distributions with their
F<.pm> files in F<lib>. This option ensures the META information has the
correct relative path even when the C<dir> or C<files> arguments are
absolute or have relative paths from a location other than the distribution
root.
=back
For example, given C<dir> of 'lib' and C<prefix> of 'lib', the return value
is a hashref of the form:
{
'Package::Name' => {
version => '0.123',
file => 'lib/Package/Name.pm'
},
'OtherPackage::Name' => ...
}
=item C<< package_versions_from_directory($dir, \@files?) >>
Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
for those files in C<$dir> - and reads each file for packages and versions,
returning a hashref of the form:
{
'Package::Name' => {
version => '0.123',
file => 'Package/Name.pm'
},
'OtherPackage::Name' => ...
}
The C<DB> and C<main> packages are always omitted, as are any "private"
packages that have leading underscores in the namespace (e.g.
C<Foo::_private>)
Note that the file path is relative to C<$dir> if that is specified.
This B<must not> be used directly for CPAN META C<provides>. See
the C<provides> method instead.
=item C<< log_info (internal) >>
Used internally to perform logging; imported from Log::Contextual if
Log::Contextual has already been loaded, otherwise simply calls warn.
=back
=head2 Object methods
=over 4
=item C<< name() >>
Returns the name of the package represented by this module. If there
are more than one packages, it makes a best guess based on the
filename. If it's a script (i.e. not a *.pm) the package name is
'main'.
=item C<< version($package) >>
Returns the version as defined by the $VERSION variable for the
package as returned by the C<name> method if no arguments are
given. If given the name of a package it will attempt to return the
version of that package if it is specified in the file.
=item C<< filename() >>
Returns the absolute path to the file.
=item C<< packages_inside() >>
Returns a list of packages. Note: this is a raw list of packages
discovered (or assumed, in the case of C<main>). It is not
filtered for C<DB>, C<main> or private packages the way the
C<provides> method does. Invalid package names are not returned,
for example "Foo:Bar". Strange but valid package names are
returned, for example "Foo::Bar::", and are left up to the caller
on how to handle.
=item C<< pod_inside() >>
Returns a list of POD sections.
=item C<< contains_pod() >>
Returns true if there is any POD in the file.
=item C<< pod($section) >>
Returns the POD data in the given section.
=back
=head1 AUTHOR
Original code from Module::Build::ModuleInfo by Ken Williams
<kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
assistance from David Golden (xdg) <dagolden@cpan.org>.
=head1 COPYRIGHT & LICENSE
Original code Copyright (c) 2001-2011 Ken Williams.
Additional code Copyright (c) 2010-2011 Matt Trout and David Golden.
All rights reserved.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
MODULE_METADATA
$fatpacked{"Parse/CPAN/Meta.pm"} = <<'PARSE_CPAN_META';
use strict;
package Parse::CPAN::Meta;
# ABSTRACT: Parse META.yml and META.json CPAN metadata files
our $VERSION = '1.4405'; # VERSION
use Carp 'croak';
# UTF Support?
sub HAVE_UTF8 () { $] >= 5.007003 }
sub IO_LAYER () { $] >= 5.008001 ? ":utf8" : "" }
BEGIN {
if ( HAVE_UTF8 ) {
# The string eval helps hide this from Test::MinimumVersion
eval "require utf8;";
die "Failed to load UTF-8 support" if $@;
}
# Class structure
require 5.004;
require Exporter;
@Parse::CPAN::Meta::ISA = qw{ Exporter };
@Parse::CPAN::Meta::EXPORT_OK = qw{ Load LoadFile };
}
sub load_file {
my ($class, $filename) = @_;
if ($filename =~ /\.ya?ml$/) {
return $class->load_yaml_string(_slurp($filename));
}
if ($filename =~ /\.json$/) {
return $class->load_json_string(_slurp($filename));
}
croak("file type cannot be determined by filename");
}
sub load_yaml_string {
my ($class, $string) = @_;
my $backend = $class->yaml_backend();
my $data = eval { no strict 'refs'; &{"$backend\::Load"}($string) };
if ( $@ ) {
croak $backend->can('errstr') ? $backend->errstr : $@
}
return $data || {}; # in case document was valid but empty
}
sub load_json_string {
my ($class, $string) = @_;
return $class->json_backend()->new->decode($string);
}
sub yaml_backend {
local $Module::Load::Conditional::CHECK_INC_HASH = 1;
if (! defined $ENV{PERL_YAML_BACKEND} ) {
_can_load( 'CPAN::Meta::YAML', 0.002 )
or croak "CPAN::Meta::YAML 0.002 is not available\n";
return "CPAN::Meta::YAML";
}
else {
my $backend = $ENV{PERL_YAML_BACKEND};
_can_load( $backend )
or croak "Could not load PERL_YAML_BACKEND '$backend'\n";
$backend->can("Load")
or croak "PERL_YAML_BACKEND '$backend' does not implement Load()\n";
return $backend;
}
}
sub json_backend {
local $Module::Load::Conditional::CHECK_INC_HASH = 1;
if (! $ENV{PERL_JSON_BACKEND} or $ENV{PERL_JSON_BACKEND} eq 'JSON::PP') {
_can_load( 'JSON::PP' => 2.27103 )
or croak "JSON::PP 2.27103 is not available\n";
return 'JSON::PP';
}
else {
_can_load( 'JSON' => 2.5 )
or croak "JSON 2.5 is required for " .
"\$ENV{PERL_JSON_BACKEND} = '$ENV{PERL_JSON_BACKEND}'\n";
return "JSON";
}
}
sub _slurp {
open my $fh, "<" . IO_LAYER, "$_[0]"
or die "can't open $_[0] for reading: $!";
return do { local $/; <$fh> };
}
sub _can_load {
my ($module, $version) = @_;
(my $file = $module) =~ s{::}{/}g;
$file .= ".pm";
return 1 if $INC{$file};
return 0 if exists $INC{$file}; # prior load failed
eval { require $file; 1 }
or return 0;
if ( defined $version ) {
eval { $module->VERSION($version); 1 }
or return 0;
}
return 1;
}
# Kept for backwards compatibility only
# Create an object from a file
sub LoadFile ($) {
require CPAN::Meta::YAML;
my $object = CPAN::Meta::YAML::LoadFile(shift)
or die CPAN::Meta::YAML->errstr;
return $object;
}
# Parse a document from a string.
sub Load ($) {
require CPAN::Meta::YAML;
my $object = CPAN::Meta::YAML::Load(shift)
or die CPAN::Meta::YAML->errstr;
return $object;
}
1;
__END__
=pod
=encoding utf-8
=head1 NAME
Parse::CPAN::Meta - Parse META.yml and META.json CPAN metadata files
=head1 VERSION
version 1.4405
=head1 SYNOPSIS
#############################################
# In your file
---
name: My-Distribution
version: 1.23
resources:
homepage: "http://example.com/dist/My-Distribution"
#############################################
# In your program
use Parse::CPAN::Meta;
my $distmeta = Parse::CPAN::Meta->load_file('META.yml');
# Reading properties
my $name = $distmeta->{name};
my $version = $distmeta->{version};
my $homepage = $distmeta->{resources}{homepage};
=head1 DESCRIPTION
B<Parse::CPAN::Meta> is a parser for F<META.json> and F<META.yml> files, using
L<JSON::PP> and/or L<CPAN::Meta::YAML>.
B<Parse::CPAN::Meta> provides three methods: C<load_file>, C<load_json_string>,
and C<load_yaml_string>. These will read and deserialize CPAN metafiles, and
are described below in detail.
B<Parse::CPAN::Meta> provides a legacy API of only two functions,
based on the YAML functions of the same name. Wherever possible,
identical calling semantics are used. These may only be used with YAML sources.
All error reporting is done with exceptions (die'ing).
Note that META files are expected to be in UTF-8 encoding, only. When
converted string data, it must first be decoded from UTF-8.
=for Pod::Coverage HAVE_UTF8 IO_LAYER
=head1 METHODS
=head2 load_file
my $metadata_structure = Parse::CPAN::Meta->load_file('META.json');
my $metadata_structure = Parse::CPAN::Meta->load_file('META.yml');
This method will read the named file and deserialize it to a data structure,
determining whether it should be JSON or YAML based on the filename. On
Perl 5.8.1 or later, the file will be read using the ":utf8" IO layer.
=head2 load_yaml_string
my $metadata_structure = Parse::CPAN::Meta->load_yaml_string($yaml_string);
This method deserializes the given string of YAML and returns the first
document in it. (CPAN metadata files should always have only one document.)
If the source was UTF-8 encoded, the string must be decoded before calling
C<load_yaml_string>.
=head2 load_json_string
my $metadata_structure = Parse::CPAN::Meta->load_json_string($json_string);
This method deserializes the given string of JSON and the result.
If the source was UTF-8 encoded, the string must be decoded before calling
C<load_json_string>.
=head2 yaml_backend
my $backend = Parse::CPAN::Meta->yaml_backend;
Returns the module name of the YAML serializer. See L</ENVIRONMENT>
for details.
=head2 json_backend
my $backend = Parse::CPAN::Meta->json_backend;
Returns the module name of the JSON serializer. This will either
be L<JSON::PP> or L<JSON>. Even if C<PERL_JSON_BACKEND> is set,
this will return L<JSON> as further delegation is handled by
the L<JSON> module. See L</ENVIRONMENT> for details.
=head1 FUNCTIONS
For maintenance clarity, no functions are exported. These functions are
available for backwards compatibility only and are best avoided in favor of
C<load_file>.
=head2 Load
my @yaml = Parse::CPAN::Meta::Load( $string );
Parses a string containing a valid YAML stream into a list of Perl data
structures.
=head2 LoadFile
my @yaml = Parse::CPAN::Meta::LoadFile( 'META.yml' );
Reads the YAML stream from a file instead of a string.
=head1 ENVIRONMENT
=head2 PERL_JSON_BACKEND
By default, L<JSON::PP> will be used for deserializing JSON data. If the
C<PERL_JSON_BACKEND> environment variable exists, is true and is not
"JSON::PP", then the L<JSON> module (version 2.5 or greater) will be loaded and
used to interpret C<PERL_JSON_BACKEND>. If L<JSON> is not installed or is too
old, an exception will be thrown.
=head2 PERL_YAML_BACKEND
By default, L<CPAN::Meta::YAML> will be used for deserializing YAML data. If
the C<PERL_YAML_BACKEND> environment variable is defined, then it is interpreted
as a module to use for deserialization. The given module must be installed,
must load correctly and must implement the C<Load()> function or an exception
will be thrown.
=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
=head1 SUPPORT
=head2 Bugs / Feature Requests
Please report any bugs or feature requests through the issue tracker
at L<https://rt.cpan.org/Public/Dist/Display.html?Name=Parse-CPAN-Meta>.
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<http://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta>
git clone git://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta.git
=head1 AUTHOR
Adam Kennedy <adamk@cpan.org>
=head1 CONTRIBUTORS
=over 4
=item *
David Golden <dagolden@cpan.org>
=item *
Joshua ben Jore <jjore@cpan.org>
=item *
Ricardo SIGNES <rjbs@cpan.org>
=item *
Steffen Müller <smueller@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2013 by 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
PARSE_CPAN_META
$fatpacked{"String/ShellQuote.pm"} = <<'STRING_SHELLQUOTE';
# $Id: ShellQuote.pm,v 1.11 2010-06-11 20:08:57 roderick Exp $
#
# Copyright (c) 1997 Roderick Schertler. All rights reserved. This
# program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
=head1 NAME
String::ShellQuote - quote strings for passing through the shell
=head1 SYNOPSIS
$string = shell_quote @list;
$string = shell_quote_best_effort @list;
$string = shell_comment_quote $string;
=head1 DESCRIPTION
This module contains some functions which are useful for quoting strings
which are going to pass through the shell or a shell-like object.
=over
=cut
package String::ShellQuote;
use strict;
use vars qw($VERSION @ISA @EXPORT);
require Exporter;
$VERSION = '1.04';
@ISA = qw(Exporter);
@EXPORT = qw(shell_quote shell_quote_best_effort shell_comment_quote);
sub croak {
require Carp;
goto &Carp::croak;
}
sub _shell_quote_backend {
my @in = @_;
my @err = ();
if (0) {
require RS::Handy;
print RS::Handy::data_dump(\@in);
}
return \@err, '' unless @in;
my $ret = '';
my $saw_non_equal = 0;
foreach (@in) {
if (!defined $_ or $_ eq '') {
$_ = "''";
next;
}
if (s/\x00//g) {
push @err, "No way to quote string containing null (\\000) bytes";
}
my $escape = 0;
# = needs quoting when it's the first element (or part of a
# series of such elements), as in command position it's a
# program-local environment setting
if (/=/) {
if (!$saw_non_equal) {
$escape = 1;
}
}
else {
$saw_non_equal = 1;
}
if (m|[^\w!%+,\-./:=@^]|) {
$escape = 1;
}
if ($escape
|| (!$saw_non_equal && /=/)) {
# ' -> '\''
s/'/'\\''/g;
# make multiple ' in a row look simpler
# '\'''\'''\'' -> '"'''"'
s|((?:'\\''){2,})|q{'"} . (q{'} x (length($1) / 4)) . q{"'}|ge;
$_ = "'$_'";
s/^''//;
s/''$//;
}
}
continue {
$ret .= "$_ ";
}
chop $ret;
return \@err, $ret;
}
=item B<shell_quote> [I<string>]...
B<shell_quote> quotes strings so they can be passed through the shell.
Each I<string> is quoted so that the shell will pass it along as a
single argument and without further interpretation. If no I<string>s
are given an empty string is returned.
If any I<string> can't be safely quoted B<shell_quote> will B<croak>.
=cut
sub shell_quote {
my ($rerr, $s) = _shell_quote_backend @_;
if (@$rerr) {
my %seen;
@$rerr = grep { !$seen{$_}++ } @$rerr;
my $s = join '', map { "shell_quote(): $_\n" } @$rerr;
chomp $s;
croak $s;
}
return $s;
}
=item B<shell_quote_best_effort> [I<string>]...
This is like B<shell_quote>, excpet if the string can't be safely quoted
it does the best it can and returns the result, instead of dying.
=cut
sub shell_quote_best_effort {
my ($rerr, $s) = _shell_quote_backend @_;
return $s;
}
=item B<shell_comment_quote> [I<string>]
B<shell_comment_quote> quotes the I<string> so that it can safely be
included in a shell-style comment (the current algorithm is that a sharp
character is placed after any newlines in the string).
This routine might be changed to accept multiple I<string> arguments
in the future. I haven't done this yet because I'm not sure if the
I<string>s should be joined with blanks ($") or nothing ($,). Cast
your vote today! Be sure to justify your answer.
=cut
sub shell_comment_quote {
return '' unless @_;
unless (@_ == 1) {
croak "Too many arguments to shell_comment_quote "
. "(got " . @_ . " expected 1)";
}
local $_ = shift;
s/\n/\n#/g;
return $_;
}
1;
__END__
=back
=head1 EXAMPLES
$cmd = 'fuser 2>/dev/null ' . shell_quote @files;
@pids = split ' ', `$cmd`;
print CFG "# Configured by: ",
shell_comment_quote($ENV{LOGNAME}), "\n";
=head1 BUGS
Only Bourne shell quoting is supported. I'd like to add other shells
(particularly cmd.exe), but I'm not familiar with them. It would be a
big help if somebody supplied the details.
=head1 AUTHOR
Roderick Schertler <F<roderick@argon.org>>
=head1 SEE ALSO
perl(1).
=cut
STRING_SHELLQUOTE
$fatpacked{"aliased.pm"} = <<'ALIASED';
package aliased;
our $VERSION = '0.31';
$VERSION = eval $VERSION;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(alias prefix);
use strict;
sub _croak {
require Carp;
Carp::croak(@_);
}
sub import {
my ( $class, $package, $alias, @import ) = @_;
if ( @_ <= 1 ) {
$class->export_to_level(1);
return;
}
my $callpack = caller(0);
_load_alias( $package, $callpack, @import );
_make_alias( $package, $callpack, $alias );
}
sub _get_alias {
my $package = shift;
$package =~ s/.*(?:::|')//;
return $package;
}
sub _make_alias {
my ( $package, $callpack, $alias ) = @_;
$alias ||= _get_alias($package);
my $destination = $alias =~ /::/
? $alias
: "$callpack\::$alias";
no strict 'refs';
*{ $destination } = sub () { $package };
}
sub _load_alias {
my ( $package, $callpack, @import ) = @_;
# We don't localize $SIG{__DIE__} here because we need to be careful about
# restoring its value if there is a failure. Very, very tricky.
my $sigdie = $SIG{__DIE__};
{
my $code =
@import == 0
? "package $callpack; use $package;"
: "package $callpack; use $package (\@import)";
eval $code;
if ( my $error = $@ ) {
$SIG{__DIE__} = $sigdie;
_croak($error);
}
$sigdie = $SIG{__DIE__}
if defined $SIG{__DIE__};
}
# Make sure a global $SIG{__DIE__} makes it out of the localization.
$SIG{__DIE__} = $sigdie if defined $sigdie;
return $package;
}
sub alias {
my ( $package, @import ) = @_;
my $callpack = scalar caller(0);
return _load_alias( $package, $callpack, @import );
}
sub prefix {
my ($class) = @_;
return sub {
my ($name) = @_;
my $callpack = caller(0);
if ( not @_ ) {
return _load_alias( $class, $callpack );
}
elsif ( @_ == 1 && defined $name ) {
return _load_alias( "${class}::$name", $callpack );
}
else {
_croak("Too many arguments to prefix('$class')");
}
};
}
1;
__END__
=head1 NAME
aliased - Use shorter versions of class names.
=head1 VERSION
0.31
=head1 SYNOPSIS
# Class name interface
use aliased 'My::Company::Namespace::Customer';
my $cust = Customer->new;
use aliased 'My::Company::Namespace::Preferred::Customer' => 'Preferred';
my $pref = Preferred->new;
# Variable interface
use aliased;
my $Customer = alias "My::Other::Namespace::Customer";
my $cust = $Customer->new;
my $Preferred = alias "My::Other::Namespace::Preferred::Customer";
my $pref = $Preferred->new;
=head1 DESCRIPTION
C<aliased> is simple in concept but is a rather handy module. It loads the
class you specify and exports into your namespace a subroutine that returns
the class name. You can explicitly alias the class to another name or, if you
prefer, you can do so implicitly. In the latter case, the name of the
subroutine is the last part of the class name. Thus, it does something
similar to the following:
#use aliased 'Some::Annoyingly::Long::Module::Name::Customer';
use Some::Annoyingly::Long::Module::Name::Customer;
sub Customer {
return 'Some::Annoyingly::Long::Module::Name::Customer';
}
my $cust = Customer->new;
This module is useful if you prefer a shorter name for a class. It's also
handy if a class has been renamed.
(Some may object to the term "aliasing" because we're not aliasing one
namespace to another, but it's a handy term. Just keep in mind that this is
done with a subroutine and not with typeglobs and weird namespace munging.)
Note that this is B<only> for C<use>ing OO modules. You cannot use this to
load procedural modules. See the L<Why OO Only?|Why OO Only?> section. Also,
don't let the version number fool you. This code is ridiculously simple and
is just fine for most use.
=head2 Implicit Aliasing
The most common use of this module is:
use aliased 'Some::Module::name';
C<aliased> will allow you to reference the class by the last part of the
class name. Thus, C<Really::Long::Name> becomes C<Name>. It does this by
exporting a subroutine into your namespace with the same name as the aliased
name. This subroutine returns the original class name.
For example:
use aliased "Acme::Company::Customer";
my $cust = Customer->find($id);
Note that any class method can be called on the shorter version of the class
name, not just the constructor.
=head2 Explicit Aliasing
Sometimes two class names can cause a conflict (they both end with C<Customer>
for example), or you already have a subroutine with the same name as the
aliased name. In that case, you can make an explicit alias by stating the
name you wish to alias to:
use aliased 'Original::Module::Name' => 'NewName';
Here's how we use C<aliased> to avoid conflicts:
use aliased "Really::Long::Name";
use aliased "Another::Really::Long::Name" => "Aname";
my $name = Name->new;
my $aname = Aname->new;
You can even alias to a different package:
use aliased "Another::Really::Long::Name" => "Another::Name";
my $aname = Another::Name->new;
Messing around with different namespaces is a really bad idea and you probably
don't want to do this. However, it might prove handy if the module you are
using has been renamed. If the interface has not changed, this allows you to
use the new module by only changing one line of code.
use aliased "New::Module::Name" => "Old::Module::Name";
my $thing = Old::Module::Name->new;
=head2 Import Lists
Sometimes, even with an OO module, you need to specify extra arguments when
using the module. When this happens, simply use L<Explicit Aliasing> followed
by the import list:
Snippet 1:
use Some::Module::Name qw/foo bar/;
my $o = Some::Module::Name->some_class_method;
Snippet 2 (equivalent to snippet 1):
use aliased 'Some::Module::Name' => 'Name', qw/foo bar/;
my $o = Name->some_class_method;
B<Note>: remember, you cannot use import lists with L<Implicit Aliasing>. As
a result, you may simply prefer to only use L<Explicit Aliasing> as a matter
of style.
=head2 alias()
This function is only exported if you specify C<use aliased> with no import
list.
use aliased;
my $alias = alias($class);
my $alias = alias($class, @imports);
alias() is an alternative to C<use aliased ...> which uses less magic and
avoids some of the ambiguities.
Like C<use aliased> it C<use>s the $class (pass in @imports, if given) but
instead of providing an C<Alias> constant it simply returns a scalar set to
the $class name.
my $thing = alias("Some::Thing::With::A::Long::Name");
# Just like Some::Thing::With::A::Long::Name->method
$thing->method;
The use of a scalar instead of a constant avoids any possible ambiguity
when aliasing two similar names:
# No ambiguity despite the fact that they both end with "Name"
my $thing = alias("Some::Thing::With::A::Long::Name");
my $other = alias("Some::Other::Thing::With::A::Long::Name");
and there is no magic constant exported into your namespace.
The only caveat is loading of the $class happens at run time. If $class
exports anything you might want to ensure it is loaded at compile time with:
my $thing;
BEGIN { $thing = alias("Some::Thing"); }
However, since OO classes rarely export this should not be necessary.
=head2 prefix() (experimental)
This function is only exported if you specify C<use aliased> with no import
list.
use aliased;
Sometimes you find you have a ton of packages in the same top-level namespace
and you want to alias them, but only use them on demand. For example:
# instead of:
MailVerwaltung::Client::Exception::REST::Response->throw()
my $error = prefix('MailVerwaltung::Client::Exception');
$error->('REST::Response')->throw(); # same as above
$error->()->throw; # same as MailVerwaltung::Client::Exception->throw
=head2 Why OO Only?
Some people have asked why this code only support object-oriented modules
(OO). If I were to support normal subroutines, I would have to allow the
following syntax:
use aliased 'Some::Really::Long::Module::Name';
my $data = Name::data();
That causes a serious problem. The only (reasonable) way it can be done is to
handle the aliasing via typeglobs. Thus, instead of a subroutine that
provides the class name, we alias one package to another (as the
L<namespace|namespace> module does.) However, we really don't want to simply
alias one package to another and wipe out namespaces willy-nilly. By merely
exporting a single subroutine to a namespace, we minimize the issue.
Fortunately, this doesn't seem to be that much of a problem. Non-OO modules
generally support exporting of the functions you need and this eliminates the
need for a module such as this.
=head1 EXPORT
This modules exports a subroutine with the same name as the "aliased" name.
=head1 BUGS
There are no known bugs in this module, but feel free to email me reports.
=head1 SEE ALSO
The L<namespace> module.
=head1 THANKS
Many thanks to Rentrak, Inc. (http://www.rentrak.com/) for graciously allowing
me to replicate the functionality of some of their internal code.
=head1 AUTHOR
Curtis Poe, C<< ovid [at] cpan [dot] org >>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2005 by Curtis "Ovid" Poe
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.5 or,
at your option, any later version of Perl 5 you may have available.
=cut
ALIASED
$fatpacked{"lib/core/only.pm"} = <<'LIB_CORE_ONLY';
package lib::core::only;
use strict;
use warnings FATAL => 'all';
use Config;
sub import {
@INC = @Config{qw(privlibexp archlibexp)};
return
}
=head1 NAME
lib::core::only - Remove all non-core paths from @INC to avoid site/vendor dirs
=head1 SYNOPSIS
use lib::core::only; # now @INC contains only the two core directories
To get only the core directories plus the ones for the local::lib in scope:
$ perl -Mlib::core::only -Mlocal::lib=~/perl5 myscript.pl
To attempt to do a self-contained build (but note this will not reliably
propagate into subprocesses, see the CAVEATS below):
$ PERL5OPT='-Mlib::core::only -Mlocal::lib=~/perl5' cpan
=head1 DESCRIPTION
lib::core::only is simply a shortcut to say "please reduce my @INC to only
the core lib and archlib (architecture-specific lib) directories of this perl".
You might want to do this to ensure a local::lib contains only the code you
need, or to test an L<App::FatPacker|App::FatPacker> tree, or to avoid known
bad vendor packages.
You might want to use this to try and install a self-contained tree of perl
modules. Be warned that that probably won't work (see L</CAVEATS>).
This module was extracted from L<local::lib|local::lib>'s --self-contained
feature, and contains the only part that ever worked. I apologise to anybody
who thought anything else did.
=head1 CAVEATS
This does B<not> propagate properly across perl invocations like local::lib's
stuff does. It can't. It's only a module import, so it B<only affects the
specific perl VM instance in which you load and import() it>.
If you want to cascade it across invocations, you can set the PERL5OPT
environment variable to '-Mlib::core::only' and it'll sort of work. But be
aware that taint mode ignores this, so some modules' build and test code
probably will as well.
You also need to be aware that perl's command line options are not processed
in order - -I options take effect before -M options, so
perl -Mlib::core::only -Ilib
is unlike to do what you want - it's exactly equivalent to:
perl -Mlib::core::only
If you want to combine a core-only @INC with additional paths, you need to
add the additional paths using -M options and the L<lib|lib> module:
perl -Mlib::core::only -Mlib=lib
# or if you're trying to test compiled code:
perl -Mlib::core::only -Mblib
For more information on the impossibility of sanely propagating this across
module builds without help from the build program, see
L<http://www.shadowcat.co.uk/blog/matt-s-trout/tainted-love> - and for ways
to achieve the old --self-contained feature's results, look at
L<App::FatPacker|App::FatPacker>'s tree function, and at
L<App::cpanminus|cpanm>'s --local-lib-contained feature.
=head1 AUTHOR
Matt S. Trout <mst@shadowcat.co.uk>
=head1 LICENSE
This library is free software under the same terms as perl itself.
=head1 COPYRIGHT
(c) 2010 the lib::core::only L</AUTHOR> as specified above.
=cut
1;
LIB_CORE_ONLY
$fatpacked{"local/lib.pm"} = <<'LOCAL_LIB';
use strict;
use warnings;
package local::lib;
use 5.008001; # probably works with earlier versions but I'm not supporting them
# (patches would, of course, be welcome)
use File::Spec ();
use File::Path ();
use Config;
our $VERSION = '1.008010'; # 1.8.10
our @KNOWN_FLAGS = qw(--self-contained --deactivate --deactivate-all);
sub DEACTIVATE_ONE () { 1 }
sub DEACTIVATE_ALL () { 2 }
sub INTERPOLATE_ENV () { 1 }
sub LITERAL_ENV () { 0 }
sub import {
my ($class, @args) = @_;
# Remember what PERL5LIB was when we started
my $perl5lib = $ENV{PERL5LIB} || '';
my %arg_store;
for my $arg (@args) {
# check for lethal dash first to stop processing before causing problems
if ($arg =~ /−/) {
die <<'DEATH';
WHOA THERE! It looks like you've got some fancy dashes in your commandline!
These are *not* the traditional -- dashes that software recognizes. You
probably got these by copy-pasting from the perldoc for this module as
rendered by a UTF8-capable formatter. This most typically happens on an OS X
terminal, but can happen elsewhere too. Please try again after replacing the
dashes with normal minus signs.
DEATH
}
elsif(grep { $arg eq $_ } @KNOWN_FLAGS) {
(my $flag = $arg) =~ s/--//;
$arg_store{$flag} = 1;
}
elsif($arg =~ /^--/) {
die "Unknown import argument: $arg";
}
else {
# assume that what's left is a path
$arg_store{path} = $arg;
}
}
if($arg_store{'self-contained'}) {
die "FATAL: The local::lib --self-contained flag has never worked reliably and the original author, Mark Stosberg, was unable or unwilling to maintain it. As such, this flag has been removed from the local::lib codebase in order to prevent misunderstandings and potentially broken builds. The local::lib authors recommend that you look at the lib::core::only module shipped with this distribution in order to create a more robust environment that is equivalent to what --self-contained provided (although quite possibly not what you originally thought it provided due to the poor quality of the documentation, for which we apologise).\n";
}
my $deactivating = 0;
if ($arg_store{deactivate}) {
$deactivating = DEACTIVATE_ONE;
}
if ($arg_store{'deactivate-all'}) {
$deactivating = DEACTIVATE_ALL;
}
$arg_store{path} = $class->resolve_path($arg_store{path});
$class->setup_local_lib_for($arg_store{path}, $deactivating);
for (@INC) { # Untaint @INC
next if ref; # Skip entry if it is an ARRAY, CODE, blessed, etc.
m/(.*)/ and $_ = $1;
}
}
sub pipeline;
sub pipeline {
my @methods = @_;
my $last = pop(@methods);
if (@methods) {
\sub {
my ($obj, @args) = @_;
$obj->${pipeline @methods}(
$obj->$last(@args)
);
};
} else {
\sub {
shift->$last(@_);
};
}
}
=begin testing
#:: test pipeline
package local::lib;
{ package Foo; sub foo { -$_[1] } sub bar { $_[1]+2 } sub baz { $_[1]+3 } }
my $foo = bless({}, 'Foo');
Test::More::ok($foo->${pipeline qw(foo bar baz)}(10) == -15);
=end testing
=cut
sub _uniq {
my %seen;
grep { ! $seen{$_}++ } @_;
}
sub resolve_path {
my ($class, $path) = @_;
$class->${pipeline qw(
resolve_relative_path
resolve_home_path
resolve_empty_path
)}($path);
}
sub resolve_empty_path {
my ($class, $path) = @_;
if (defined $path) {
$path;
} else {
'~/perl5';
}
}
=begin testing
#:: test classmethod setup
my $c = 'local::lib';
=end testing
=begin testing
#:: test classmethod
is($c->resolve_empty_path, '~/perl5');
is($c->resolve_empty_path('foo'), 'foo');
=end testing
=cut
sub resolve_home_path {
my ($class, $path) = @_;
return $path unless ($path =~ /^~/);
my ($user) = ($path =~ /^~([^\/]+)/); # can assume ^~ so undef for 'us'
my $tried_file_homedir;
my $homedir = do {
if (eval { require File::HomeDir } && $File::HomeDir::VERSION >= 0.65) {
$tried_file_homedir = 1;
if (defined $user) {
File::HomeDir->users_home($user);
} else {
File::HomeDir->my_home;
}
} else {
if (defined $user) {
(getpwnam $user)[7];
} else {
if (defined $ENV{HOME}) {
$ENV{HOME};
} else {
(getpwuid $<)[7];
}
}
}
};
unless (defined $homedir) {
require Carp;
Carp::croak(
"Couldn't resolve homedir for "
.(defined $user ? $user : 'current user')
.($tried_file_homedir ? '' : ' - consider installing File::HomeDir')
);
}
$path =~ s/^~[^\/]*/$homedir/;
$path;
}
sub resolve_relative_path {
my ($class, $path) = @_;
$path = File::Spec->rel2abs($path);
}
=begin testing
#:: test classmethod
local *File::Spec::rel2abs = sub { shift; 'FOO'.shift; };
is($c->resolve_relative_path('bar'),'FOObar');
=end testing
=cut
sub setup_local_lib_for {
my ($class, $path, $deactivating) = @_;
my $interpolate = LITERAL_ENV;
my @active_lls = $class->active_paths;
$class->ensure_dir_structure_for($path);
# On Win32 directories often contain spaces. But some parts of the CPAN
# toolchain don't like that. To avoid this, GetShortPathName() gives us
# an alternate representation that has none.
# This only works if the directory already exists.
$path = Win32::GetShortPathName($path) if $^O eq 'MSWin32';
if (! $deactivating) {
if (@active_lls && $active_lls[-1] eq $path) {
exit 0 if $0 eq '-';
return; # Asked to add what's already at the top of the stack
} elsif (grep { $_ eq $path} @active_lls) {
# Asked to add a dir that's lower in the stack -- so we remove it from
# where it is, and then add it back at the top.
$class->setup_env_hash_for($path, DEACTIVATE_ONE);
# Which means we can no longer output "PERL5LIB=...:$PERL5LIB" stuff
# anymore because we're taking something *out*.
$interpolate = INTERPOLATE_ENV;
}
}
if ($0 eq '-') {
$class->print_environment_vars_for($path, $deactivating, $interpolate);
exit 0;
} else {
$class->setup_env_hash_for($path, $deactivating);
my $arch_dir = $Config{archname};
@INC = _uniq(
(
# Inject $path/$archname for each path in PERL5LIB
map { ( File::Spec->catdir($_, $arch_dir), $_ ) }
split($Config{path_sep}, $ENV{PERL5LIB})
),
@INC
);
}
}
sub install_base_bin_path {
my ($class, $path) = @_;
File::Spec->catdir($path, 'bin');
}
sub install_base_perl_path {
my ($class, $path) = @_;
File::Spec->catdir($path, 'lib', 'perl5');
}
sub install_base_arch_path {
my ($class, $path) = @_;
File::Spec->catdir($class->install_base_perl_path($path), $Config{archname});
}
sub ensure_dir_structure_for {
my ($class, $path) = @_;
unless (-d $path) {
warn "Attempting to create directory ${path}\n";
}
File::Path::mkpath($path);
return
}
sub guess_shelltype {
my $shellbin = 'sh';
if(defined $ENV{'SHELL'}) {
my @shell_bin_path_parts = File::Spec->splitpath($ENV{'SHELL'});
$shellbin = $shell_bin_path_parts[-1];
}
my $shelltype = do {
local $_ = $shellbin;
if(/csh/) {
'csh'
} else {
'bourne'
}
};
# Both Win32 and Cygwin have $ENV{COMSPEC} set.
if (defined $ENV{'COMSPEC'} && $^O ne 'cygwin') {
my @shell_bin_path_parts = File::Spec->splitpath($ENV{'COMSPEC'});
$shellbin = $shell_bin_path_parts[-1];
$shelltype = do {
local $_ = $shellbin;
if(/command\.com/) {
'win32'
} elsif(/cmd\.exe/) {
'win32'
} elsif(/4nt\.exe/) {
'win32'
} else {
$shelltype
}
};
}
return $shelltype;
}
sub print_environment_vars_for {
my ($class, $path, $deactivating, $interpolate) = @_;
print $class->environment_vars_string_for($path, $deactivating, $interpolate);
}
sub environment_vars_string_for {
my ($class, $path, $deactivating, $interpolate) = @_;
my @envs = $class->build_environment_vars_for($path, $deactivating, $interpolate);
my $out = '';
# rather basic csh detection, goes on the assumption that something won't
# call itself csh unless it really is. also, default to bourne in the
# pathological situation where a user doesn't have $ENV{SHELL} defined.
# note also that shells with funny names, like zoid, are assumed to be
# bourne.
my $shelltype = $class->guess_shelltype;
while (@envs) {
my ($name, $value) = (shift(@envs), shift(@envs));
$value =~ s/(\\")/\\$1/g if defined $value;
$out .= $class->${\"build_${shelltype}_env_declaration"}($name, $value);
}
return $out;
}
# simple routines that take two arguments: an %ENV key and a value. return
# strings that are suitable for passing directly to the relevant shell to set
# said key to said value.
sub build_bourne_env_declaration {
my $class = shift;
my($name, $value) = @_;
return defined($value) ? qq{export ${name}="${value}";\n} : qq{unset ${name};\n};
}
sub build_csh_env_declaration {
my $class = shift;
my($name, $value) = @_;
return defined($value) ? qq{setenv ${name} "${value}"\n} : qq{unsetenv ${name}\n};
}
sub build_win32_env_declaration {
my $class = shift;
my($name, $value) = @_;
return defined($value) ? qq{set ${name}=${value}\n} : qq{set ${name}=\n};
}
sub setup_env_hash_for {
my ($class, $path, $deactivating) = @_;
my %envs = $class->build_environment_vars_for($path, $deactivating, INTERPOLATE_ENV);
@ENV{keys %envs} = values %envs;
}
sub build_environment_vars_for {
my ($class, $path, $deactivating, $interpolate) = @_;
if ($deactivating == DEACTIVATE_ONE) {
return $class->build_deactivate_environment_vars_for($path, $interpolate);
} elsif ($deactivating == DEACTIVATE_ALL) {
return $class->build_deact_all_environment_vars_for($path, $interpolate);
} else {
return $class->build_activate_environment_vars_for($path, $interpolate);
}
}
# Build an environment value for a variable like PATH from a list of paths.
# References to existing variables are given as references to the variable name.
# Duplicates are removed.
#
# options:
# - interpolate: INTERPOLATE_ENV/LITERAL_ENV
# - exists: paths are included only if they exist (default: interpolate == INTERPOLATE_ENV)
# - filter: function to apply to each path do decide if it must be included
# - empty: the value to return in the case of empty value
my %ENV_LIST_VALUE_DEFAULTS = (
interpolate => INTERPOLATE_ENV,
exists => undef,
filter => sub { 1 },
empty => undef,
);
sub _env_list_value {
my $options = shift;
die(sprintf "unknown option '$_' at %s line %u\n", (caller)[1..2])
for grep { !exists $ENV_LIST_VALUE_DEFAULTS{$_} } keys %$options;
my %options = (%ENV_LIST_VALUE_DEFAULTS, %{ $options });
$options{exists} = $options{interpolate} == INTERPOLATE_ENV
unless defined $options{exists};
my %seen;
my $value = join($Config{path_sep}, map {
ref $_ ? ($^O eq 'MSWin32' ? "%${$_}%" : "\$${$_}") : $_
} grep {
ref $_ || (defined $_
&& length($_) > 0
&& !$seen{$_}++
&& $options{filter}->($_)
&& (!$options{exists} || -e $_))
} map {
if (ref $_ eq 'SCALAR' && $options{interpolate} == INTERPOLATE_ENV) {
defined $ENV{${$_}} ? (split /\Q$Config{path_sep}/, $ENV{${$_}}) : ()
} else {
$_
}
} @_);
return length($value) ? $value : $options{empty};
}
sub build_activate_environment_vars_for {
my ($class, $path, $interpolate) = @_;
return (
PERL_LOCAL_LIB_ROOT =>
_env_list_value(
{ interpolate => $interpolate, exists => 0, empty => '' },
\'PERL_LOCAL_LIB_ROOT',
$path,
),
PERL_MB_OPT => "--install_base ${path}",
PERL_MM_OPT => "INSTALL_BASE=${path}",
PERL5LIB =>
_env_list_value(
{ interpolate => $interpolate, exists => 0, empty => '' },
$class->install_base_perl_path($path),
\'PERL5LIB',
),
PATH => _env_list_value(
{ interpolate => $interpolate, exists => 0, empty => '' },
$class->install_base_bin_path($path),
\'PATH',
),
)
}
sub active_paths {
my ($class) = @_;
return () unless defined $ENV{PERL_LOCAL_LIB_ROOT};
return grep { $_ ne '' } split /\Q$Config{path_sep}/, $ENV{PERL_LOCAL_LIB_ROOT};
}
sub build_deactivate_environment_vars_for {
my ($class, $path, $interpolate) = @_;
my @active_lls = $class->active_paths;
if (!grep { $_ eq $path } @active_lls) {
warn "Tried to deactivate inactive local::lib '$path'\n";
return ();
}
my $perl_path = $class->install_base_perl_path($path);
my $arch_path = $class->install_base_arch_path($path);
my $bin_path = $class->install_base_bin_path($path);
my %env = (
PERL_LOCAL_LIB_ROOT => _env_list_value(
{
exists => 0,
},
grep { $_ ne $path } @active_lls
),
PERL5LIB => _env_list_value(
{
exists => 0,
filter => sub {
$_ ne $perl_path && $_ ne $arch_path
},
},
\'PERL5LIB',
),
PATH => _env_list_value(
{
exists => 0,
filter => sub { $_ ne $bin_path },
},
\'PATH',
),
);
# If removing ourselves from the "top of the stack", set install paths to
# correspond with the new top of stack.
if ($active_lls[-1] eq $path) {
my $new_top = $active_lls[-2];
$env{PERL_MB_OPT} = defined($new_top) ? "--install_base ${new_top}" : undef;
$env{PERL_MM_OPT} = defined($new_top) ? "INSTALL_BASE=${new_top}" : undef;
}
return %env;
}
sub build_deact_all_environment_vars_for {
my ($class, $path, $interpolate) = @_;
my @active_lls = $class->active_paths;
my %perl_paths = map { (
$class->install_base_perl_path($_) => 1,
$class->install_base_arch_path($_) => 1
) } @active_lls;
my %bin_paths = map { (
$class->install_base_bin_path($_) => 1,
) } @active_lls;
my %env = (
PERL_LOCAL_LIB_ROOT => undef,
PERL_MM_OPT => undef,
PERL_MB_OPT => undef,
PERL5LIB => _env_list_value(
{
exists => 0,
filter => sub {
! scalar grep { exists $perl_paths{$_} } $_[0]
},
},
\'PERL5LIB'
),
PATH => _env_list_value(
{
exists => 0,
filter => sub {
! scalar grep { exists $bin_paths{$_} } $_[0]
},
},
\'PATH'
),
);
return %env;
}
=begin testing
#:: test classmethod
File::Path::rmtree('t/var/splat');
$c->ensure_dir_structure_for('t/var/splat');
ok(-d 't/var/splat');
=end testing
=encoding utf8
=head1 NAME
local::lib - create and use a local lib/ for perl modules with PERL5LIB
=head1 SYNOPSIS
In code -
use local::lib; # sets up a local lib at ~/perl5
use local::lib '~/foo'; # same, but ~/foo
# Or...
use FindBin;
use local::lib "$FindBin::Bin/../support"; # app-local support library
From the shell -
# Install LWP and its missing dependencies to the '~/perl5' directory
perl -MCPAN -Mlocal::lib -e 'CPAN::install(LWP)'
# Just print out useful shell commands
$ perl -Mlocal::lib
export PERL_MB_OPT='--install_base /home/username/perl5'
export PERL_MM_OPT='INSTALL_BASE=/home/username/perl5'
export PERL5LIB='/home/username/perl5/lib/perl5/i386-linux:/home/username/perl5/lib/perl5'
export PATH="/home/username/perl5/bin:$PATH"
=head2 The bootstrapping technique
A typical way to install local::lib is using what is known as the
"bootstrapping" technique. You would do this if your system administrator
hasn't already installed local::lib. In this case, you'll need to install
local::lib in your home directory.
If you do have administrative privileges, you will still want to set up your
environment variables, as discussed in step 4. Without this, you would still
install the modules into the system CPAN installation and also your Perl scripts
will not use the lib/ path you bootstrapped with local::lib.
By default local::lib installs itself and the CPAN modules into ~/perl5.
Windows users must also see L</Differences when using this module under Win32>.
1. Download and unpack the local::lib tarball from CPAN (search for "Download"
on the CPAN page about local::lib). Do this as an ordinary user, not as root
or administrator. Unpack the file in your home directory or in any other
convenient location.
2. Run this:
perl Makefile.PL --bootstrap
If the system asks you whether it should automatically configure as much
as possible, you would typically answer yes.
In order to install local::lib into a directory other than the default, you need
to specify the name of the directory when you call bootstrap, as follows:
perl Makefile.PL --bootstrap=~/foo
3. Run this: (local::lib assumes you have make installed on your system)
make test && make install
4. Now we need to setup the appropriate environment variables, so that Perl
starts using our newly generated lib/ directory. If you are using bash or
any other Bourne shells, you can add this to your shell startup script this
way:
echo 'eval $(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)' >>~/.bashrc
If you are using C shell, you can do this as follows:
/bin/csh
echo $SHELL
/bin/csh
perl -I$HOME/perl5/lib/perl5 -Mlocal::lib >> ~/.cshrc
If you passed to bootstrap a directory other than default, you also need to give that as
import parameter to the call of the local::lib module like this way:
echo 'eval $(perl -I$HOME/foo/lib/perl5 -Mlocal::lib=$HOME/foo)' >>~/.bashrc
After writing your shell configuration file, be sure to re-read it to get the
changed settings into your current shell's environment. Bourne shells use
C<. ~/.bashrc> for this, whereas C shells use C<source ~/.cshrc>.
If you're on a slower machine, or are operating under draconian disk space
limitations, you can disable the automatic generation of manpages from POD when
installing modules by using the C<--no-manpages> argument when bootstrapping:
perl Makefile.PL --bootstrap --no-manpages
To avoid doing several bootstrap for several Perl module environments on the
same account, for example if you use it for several different deployed
applications independently, you can use one bootstrapped local::lib
installation to install modules in different directories directly this way:
cd ~/mydir1
perl -Mlocal::lib=./
eval $(perl -Mlocal::lib=./) ### To set the environment for this shell alone
printenv ### You will see that ~/mydir1 is in the PERL5LIB
perl -MCPAN -e install ... ### whatever modules you want
cd ../mydir2
... REPEAT ...
If you are working with several C<local::lib> environments, you may want to
remove some of them from the current environment without disturbing the others.
You can deactivate one environment like this (using bourne sh):
eval $(perl -Mlocal::lib=--deactivate,~/path)
which will generate and run the commands needed to remove C<~/path> from your
various search paths. Whichever environment was B<activated most recently> will
remain the target for module installations. That is, if you activate
C<~/path_A> and then you activate C<~/path_B>, new modules you install will go
in C<~/path_B>. If you deactivate C<~/path_B> then modules will be installed
into C<~/pathA> -- but if you deactivate C<~/path_A> then they will still be
installed in C<~/pathB> because pathB was activated later.
You can also ask C<local::lib> to clean itself completely out of the current
shell's environment with the C<--deactivate-all> option.
For multiple environments for multiple apps you may need to include a modified
version of the C<< use FindBin >> instructions in the "In code" sample above.
If you did something like the above, you have a set of Perl modules at C<<
~/mydir1/lib >>. If you have a script at C<< ~/mydir1/scripts/myscript.pl >>,
you need to tell it where to find the modules you installed for it at C<<
~/mydir1/lib >>.
In C<< ~/mydir1/scripts/myscript.pl >>:
use strict;
use warnings;
use local::lib "$FindBin::Bin/.."; ### points to ~/mydir1 and local::lib finds lib
use lib "$FindBin::Bin/../lib"; ### points to ~/mydir1/lib
Put this before any BEGIN { ... } blocks that require the modules you installed.
=head2 Differences when using this module under Win32
To set up the proper environment variables for your current session of
C<CMD.exe>, you can use this:
C:\>perl -Mlocal::lib
set PERL_MB_OPT=--install_base C:\DOCUME~1\ADMINI~1\perl5
set PERL_MM_OPT=INSTALL_BASE=C:\DOCUME~1\ADMINI~1\perl5
set PERL5LIB=C:\DOCUME~1\ADMINI~1\perl5\lib\perl5;C:\DOCUME~1\ADMINI~1\perl5\lib\perl5\MSWin32-x86-multi-thread
set PATH=C:\DOCUME~1\ADMINI~1\perl5\bin;%PATH%
### To set the environment for this shell alone
C:\>perl -Mlocal::lib > %TEMP%\tmp.bat && %TEMP%\tmp.bat && del %TEMP%\tmp.bat
### instead of $(perl -Mlocal::lib=./)
If you want the environment entries to persist, you'll need to add then to the
Control Panel's System applet yourself or use L<App::local::lib::Win32Helper>.
The "~" is translated to the user's profile directory (the directory named for
the user under "Documents and Settings" (Windows XP or earlier) or "Users"
(Windows Vista or later)) unless $ENV{HOME} exists. After that, the home
directory is translated to a short name (which means the directory must exist)
and the subdirectories are created.
=head1 RATIONALE
The version of a Perl package on your machine is not always the version you
need. Obviously, the best thing to do would be to update to the version you
need. However, you might be in a situation where you're prevented from doing
this. Perhaps you don't have system administrator privileges; or perhaps you
are using a package management system such as Debian, and nobody has yet gotten
around to packaging up the version you need.
local::lib solves this problem by allowing you to create your own directory of
Perl packages downloaded from CPAN (in a multi-user system, this would typically
be within your own home directory). The existing system Perl installation is
not affected; you simply invoke Perl with special options so that Perl uses the
packages in your own local package directory rather than the system packages.
local::lib arranges things so that your locally installed version of the Perl
packages takes precedence over the system installation.
If you are using a package management system (such as Debian), you don't need to
worry about Debian and CPAN stepping on each other's toes. Your local version
of the packages will be written to an entirely separate directory from those
installed by Debian.
=head1 DESCRIPTION
This module provides a quick, convenient way of bootstrapping a user-local Perl
module library located within the user's home directory. It also constructs and
prints out for the user the list of environment variables using the syntax
appropriate for the user's current shell (as specified by the C<SHELL>
environment variable), suitable for directly adding to one's shell
configuration file.
More generally, local::lib allows for the bootstrapping and usage of a
directory containing Perl modules outside of Perl's C<@INC>. This makes it
easier to ship an application with an app-specific copy of a Perl module, or
collection of modules. Useful in cases like when an upstream maintainer hasn't
applied a patch to a module of theirs that you need for your application.
On import, local::lib sets the following environment variables to appropriate
values:
=over 4
=item PERL_MB_OPT
=item PERL_MM_OPT
=item PERL5LIB
=item PATH
PATH is appended to, rather than clobbered.
=back
These values are then available for reference by any code after import.
=head1 CREATING A SELF-CONTAINED SET OF MODULES
See L<lib::core::only> for one way to do this - but note that
there are a number of caveats, and the best approach is always to perform a
build against a clean perl (i.e. site and vendor as close to empty as possible).
=head1 OPTIONS
Options are values that can be passed to the C<local::lib> import besides the
directory to use. They are specified as C<use local::lib '--option'[, path];>
or C<perl -Mlocal::lib=--option[,path]>.
=head2 --deactivate
Remove the chosen path (or the default path) from the module search paths if it
was added by C<local::lib>, instead of adding it.
=head2 --deactivate-all
Remove all directories that were added to search paths by C<local::lib> from the
search paths.
=head1 METHODS
=head2 ensure_dir_structure_for
=over 4
=item Arguments: $path
=item Return value: None
=back
Attempts to create the given path, and all required parent directories. Throws
an exception on failure.
=head2 print_environment_vars_for
=over 4
=item Arguments: $path
=item Return value: None
=back
Prints to standard output the variables listed above, properly set to use the
given path as the base directory.
=head2 build_environment_vars_for
=over 4
=item Arguments: $path, $interpolate
=item Return value: \%environment_vars
=back
Returns a hash with the variables listed above, properly set to use the
given path as the base directory.
=head2 setup_env_hash_for
=over 4
=item Arguments: $path
=item Return value: None
=back
Constructs the C<%ENV> keys for the given path, by calling
L</build_environment_vars_for>.
=head2 active_paths
=over 4
=item Arguments: None
=item Return value: @paths
=back
Returns a list of active C<local::lib> paths, according to the
C<PERL_LOCAL_LIB_ROOT> environment variable.
=head2 install_base_perl_path
=over 4
=item Arguments: $path
=item Return value: $install_base_perl_path
=back
Returns a path describing where to install the Perl modules for this local
library installation. Appends the directories C<lib> and C<perl5> to the given
path.
=head2 install_base_arch_path
=over 4
=item Arguments: $path
=item Return value: $install_base_arch_path
=back
Returns a path describing where to install the architecture-specific Perl
modules for this local library installation. Based on the
L</install_base_perl_path> method's return value, and appends the value of
C<$Config{archname}>.
=head2 install_base_bin_path
=over 4
=item Arguments: $path
=item Return value: $install_base_bin_path
=back
Returns a path describing where to install the executable programs for this
local library installation. Based on the L</install_base_perl_path> method's
return value, and appends the directory C<bin>.
=head2 resolve_empty_path
=over 4
=item Arguments: $path
=item Return value: $base_path
=back
Builds and returns the base path into which to set up the local module
installation. Defaults to C<~/perl5>.
=head2 resolve_home_path
=over 4
=item Arguments: $path
=item Return value: $home_path
=back
Attempts to find the user's home directory. If installed, uses C<File::HomeDir>
for this purpose. If no definite answer is available, throws an exception.
=head2 resolve_relative_path
=over 4
=item Arguments: $path
=item Return value: $absolute_path
=back
Translates the given path into an absolute path.
=head2 resolve_path
=over 4
=item Arguments: $path
=item Return value: $absolute_path
=back
Calls the following in a pipeline, passing the result from the previous to the
next, in an attempt to find where to configure the environment for a local
library installation: L</resolve_empty_path>, L</resolve_home_path>,
L</resolve_relative_path>. Passes the given path argument to
L</resolve_empty_path> which then returns a result that is passed to
L</resolve_home_path>, which then has its result passed to
L</resolve_relative_path>. The result of this final call is returned from
L</resolve_path>.
=head1 A WARNING ABOUT UNINST=1
Be careful about using local::lib in combination with "make install UNINST=1".
The idea of this feature is that will uninstall an old version of a module
before installing a new one. However it lacks a safety check that the old
version and the new version will go in the same directory. Used in combination
with local::lib, you can potentially delete a globally accessible version of a
module while installing the new version in a local place. Only combine "make
install UNINST=1" and local::lib if you understand these possible consequences.
=head1 LIMITATIONS
The perl toolchain is unable to handle directory names with spaces in it,
so you cant put your local::lib bootstrap into a directory with spaces. What
you can do is moving your local::lib to a directory with spaces B<after> you
installed all modules inside your local::lib bootstrap. But be aware that you
cant update or install CPAN modules after the move.
Rather basic shell detection. Right now anything with csh in its name is
assumed to be a C shell or something compatible, and everything else is assumed
to be Bourne, except on Win32 systems. If the C<SHELL> environment variable is
not set, a Bourne-compatible shell is assumed.
Bootstrap is a hack and will use CPAN.pm for ExtUtils::MakeMaker even if you
have CPANPLUS installed.
Kills any existing PERL5LIB, PERL_MM_OPT or PERL_MB_OPT.
Should probably auto-fixup CPAN config if not already done.
Patches very much welcome for any of the above.
On Win32 systems, does not have a way to write the created environment variables
to the registry, so that they can persist through a reboot.
=head1 TROUBLESHOOTING
If you've configured local::lib to install CPAN modules somewhere in to your
home directory, and at some point later you try to install a module with C<cpan
-i Foo::Bar>, but it fails with an error like: C<Warning: You do not have
permissions to install into /usr/lib64/perl5/site_perl/5.8.8/x86_64-linux at
/usr/lib64/perl5/5.8.8/Foo/Bar.pm> and buried within the install log is an
error saying C<'INSTALL_BASE' is not a known MakeMaker parameter name>, then
you've somehow lost your updated ExtUtils::MakeMaker module.
To remedy this situation, rerun the bootstrapping procedure documented above.
Then, run C<rm -r ~/.cpan/build/Foo-Bar*>
Finally, re-run C<cpan -i Foo::Bar> and it should install without problems.
=head1 ENVIRONMENT
=over 4
=item SHELL
=item COMSPEC
local::lib looks at the user's C<SHELL> environment variable when printing out
commands to add to the shell configuration file.
On Win32 systems, C<COMSPEC> is also examined.
=back
=head1 SUPPORT
IRC:
Join #local-lib on irc.perl.org.
=head1 AUTHOR
Matt S Trout <mst@shadowcat.co.uk> http://www.shadowcat.co.uk/
auto_install fixes kindly sponsored by http://www.takkle.com/
=head1 CONTRIBUTORS
Patches to correctly output commands for csh style shells, as well as some
documentation additions, contributed by Christopher Nehren <apeiron@cpan.org>.
Doc patches for a custom local::lib directory, more cleanups in the english
documentation and a L<german documentation|POD2::DE::local::lib> contributed by Torsten Raudssus
<torsten@raudssus.de>.
Hans Dieter Pearcey <hdp@cpan.org> sent in some additional tests for ensuring
things will install properly, submitted a fix for the bug causing problems with
writing Makefiles during bootstrapping, contributed an example program, and
submitted yet another fix to ensure that local::lib can install and bootstrap
properly. Many, many thanks!
pattern of Freenode IRC contributed the beginnings of the Troubleshooting
section. Many thanks!
Patch to add Win32 support contributed by Curtis Jewell <csjewell@cpan.org>.
Warnings for missing PATH/PERL5LIB (as when not running interactively) silenced
by a patch from Marco Emilio Poleggi.
Mark Stosberg <mark@summersault.com> provided the code for the now deleted
'--self-contained' option.
Documentation patches to make win32 usage clearer by
David Mertens <dcmertens.perl@gmail.com> (run4flat).
Brazilian L<portuguese translation|POD2::PT_BR::local::lib> and minor doc patches contributed by Breno
G. de Oliveira <garu@cpan.org>.
Improvements to stacking multiple local::lib dirs and removing them from the
environment later on contributed by Andrew Rodland <arodland@cpan.org>.
Patch for Carp version mismatch contributed by Hakim Cassimally <osfameron@cpan.org>.
=head1 COPYRIGHT
Copyright (c) 2007 - 2010 the local::lib L</AUTHOR> and L</CONTRIBUTORS> as
listed above.
=head1 LICENSE
This library is free software and may be distributed under the same terms
as perl itself.
=cut
1;
LOCAL_LIB
$fatpacked{"version.pm"} = <<'VERSION';
#!perl -w
package version;
use 5.005_04;
use strict;
use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
$VERSION = 0.9902;
$CLASS = 'version';
#--------------------------------------------------------------------------#
# Version regexp components
#--------------------------------------------------------------------------#
# Fraction part of a decimal version number. This is a common part of
# both strict and lax decimal versions
my $FRACTION_PART = qr/\.[0-9]+/;
# First part of either decimal or dotted-decimal strict version number.
# Unsigned integer with no leading zeroes (except for zero itself) to
# avoid confusion with octal.
my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/;
# First part of either decimal or dotted-decimal lax version number.
# Unsigned integer, but allowing leading zeros. Always interpreted
# as decimal. However, some forms of the resulting syntax give odd
# results if used as ordinary Perl expressions, due to how perl treats
# octals. E.g.
# version->new("010" ) == 10
# version->new( 010 ) == 8
# version->new( 010.2) == 82 # "8" . "2"
my $LAX_INTEGER_PART = qr/[0-9]+/;
# Second and subsequent part of a strict dotted-decimal version number.
# Leading zeroes are permitted, and the number is always decimal.
# Limited to three digits to avoid overflow when converting to decimal
# form and also avoid problematic style with excessive leading zeroes.
my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/;
# Second and subsequent part of a lax dotted-decimal version number.
# Leading zeroes are permitted, and the number is always decimal. No
# limit on the numerical value or number of digits, so there is the
# possibility of overflow when converting to decimal form.
my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/;
# Alpha suffix part of lax version number syntax. Acts like a
# dotted-decimal part.
my $LAX_ALPHA_PART = qr/_[0-9]+/;
#--------------------------------------------------------------------------#
# Strict version regexp definitions
#--------------------------------------------------------------------------#
# Strict decimal version number.
my $STRICT_DECIMAL_VERSION =
qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x;
# Strict dotted-decimal version number. Must have both leading "v" and
# at least three parts, to avoid confusion with decimal syntax.
my $STRICT_DOTTED_DECIMAL_VERSION =
qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x;
# Complete strict version number syntax -- should generally be used
# anchored: qr/ \A $STRICT \z /x
$STRICT =
qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x;
#--------------------------------------------------------------------------#
# Lax version regexp definitions
#--------------------------------------------------------------------------#
# Lax decimal version number. Just like the strict one except for
# allowing an alpha suffix or allowing a leading or trailing
# decimal-point
my $LAX_DECIMAL_VERSION =
qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )?
|
$FRACTION_PART $LAX_ALPHA_PART?
/x;
# Lax dotted-decimal version number. Distinguished by having either
# leading "v" or at least three non-alpha parts. Alpha part is only
# permitted if there are at least two non-alpha parts. Strangely
# enough, without the leading "v", Perl takes .1.2 to mean v0.1.2,
# so when there is no "v", the leading part is optional
my $LAX_DOTTED_DECIMAL_VERSION =
qr/
v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )?
|
$LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART?
/x;
# Complete lax version number syntax -- should generally be used
# anchored: qr/ \A $LAX \z /x
#
# The string 'undef' is a special case to make for easier handling
# of return values from ExtUtils::MM->parse_version
$LAX =
qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x;
#--------------------------------------------------------------------------#
{
local $SIG{'__DIE__'};
eval "use version::vxs $VERSION";
if ( $@ ) { # don't have the XS version installed
eval "use version::vpp $VERSION"; # don't tempt fate
die "$@" if ( $@ );
push @ISA, "version::vpp";
local $^W;
*version::qv = \&version::vpp::qv;
*version::declare = \&version::vpp::declare;
*version::_VERSION = \&version::vpp::_VERSION;
*version::vcmp = \&version::vpp::vcmp;
*version::new = \&version::vpp::new;
if ($] >= 5.009000) {
no strict 'refs';
*version::stringify = \&version::vpp::stringify;
*{'version::(""'} = \&version::vpp::stringify;
*{'version::(<=>'} = \&version::vpp::vcmp;
*version::parse = \&version::vpp::parse;
}
}
else { # use XS module
push @ISA, "version::vxs";
local $^W;
*version::declare = \&version::vxs::declare;
*version::qv = \&version::vxs::qv;
*version::_VERSION = \&version::vxs::_VERSION;
*version::vcmp = \&version::vxs::VCMP;
*version::new = \&version::vxs::new;
if ($] >= 5.009000) {
no strict 'refs';
*version::stringify = \&version::vxs::stringify;
*{'version::(""'} = \&version::vxs::stringify;
*{'version::(<=>'} = \&version::vxs::VCMP;
*version::parse = \&version::vxs::parse;
}
}
}
# Preloaded methods go here.
sub import {
no strict 'refs';
my ($class) = shift;
# Set up any derived class
unless ($class eq 'version') {
local $^W;
*{$class.'::declare'} = \&version::declare;
*{$class.'::qv'} = \&version::qv;
}
my %args;
if (@_) { # any remaining terms are arguments
map { $args{$_} = 1 } @_
}
else { # no parameters at all on use line
%args =
(
qv => 1,
'UNIVERSAL::VERSION' => 1,
);
}
my $callpkg = caller();
if (exists($args{declare})) {
*{$callpkg.'::declare'} =
sub {return $class->declare(shift) }
unless defined(&{$callpkg.'::declare'});
}
if (exists($args{qv})) {
*{$callpkg.'::qv'} =
sub {return $class->qv(shift) }
unless defined(&{$callpkg.'::qv'});
}
if (exists($args{'UNIVERSAL::VERSION'})) {
local $^W;
*UNIVERSAL::VERSION
= \&version::_VERSION;
}
if (exists($args{'VERSION'})) {
*{$callpkg.'::VERSION'} = \&version::_VERSION;
}
if (exists($args{'is_strict'})) {
*{$callpkg.'::is_strict'} = \&version::is_strict
unless defined(&{$callpkg.'::is_strict'});
}
if (exists($args{'is_lax'})) {
*{$callpkg.'::is_lax'} = \&version::is_lax
unless defined(&{$callpkg.'::is_lax'});
}
}
sub is_strict { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x }
sub is_lax { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x }
1;
VERSION
$fatpacked{"version/vpp.pm"} = <<'VERSION_VPP';
package charstar;
# a little helper class to emulate C char* semantics in Perl
# so that prescan_version can use the same code as in C
use overload (
'""' => \&thischar,
'0+' => \&thischar,
'++' => \&increment,
'--' => \&decrement,
'+' => \&plus,
'-' => \&minus,
'*' => \&multiply,
'cmp' => \&cmp,
'<=>' => \&spaceship,
'bool' => \&thischar,
'=' => \&clone,
);
sub new {
my ($self, $string) = @_;
my $class = ref($self) || $self;
my $obj = {
string => [split(//,$string)],
current => 0,
};
return bless $obj, $class;
}
sub thischar {
my ($self) = @_;
my $last = $#{$self->{string}};
my $curr = $self->{current};
if ($curr >= 0 && $curr <= $last) {
return $self->{string}->[$curr];
}
else {
return '';
}
}
sub increment {
my ($self) = @_;
$self->{current}++;
}
sub decrement {
my ($self) = @_;
$self->{current}--;
}
sub plus {
my ($self, $offset) = @_;
my $rself = $self->clone;
$rself->{current} += $offset;
return $rself;
}
sub minus {
my ($self, $offset) = @_;
my $rself = $self->clone;
$rself->{current} -= $offset;
return $rself;
}
sub multiply {
my ($left, $right, $swapped) = @_;
my $char = $left->thischar();
return $char * $right;
}
sub spaceship {
my ($left, $right, $swapped) = @_;
unless (ref($right)) { # not an object already
$right = $left->new($right);
}
return $left->{current} <=> $right->{current};
}
sub cmp {
my ($left, $right, $swapped) = @_;
unless (ref($right)) { # not an object already
if (length($right) == 1) { # comparing single character only
return $left->thischar cmp $right;
}
$right = $left->new($right);
}
return $left->currstr cmp $right->currstr;
}
sub bool {
my ($self) = @_;
my $char = $self->thischar;
return ($char ne '');
}
sub clone {
my ($left, $right, $swapped) = @_;
$right = {
string => [@{$left->{string}}],
current => $left->{current},
};
return bless $right, ref($left);
}
sub currstr {
my ($self, $s) = @_;
my $curr = $self->{current};
my $last = $#{$self->{string}};
if (defined($s) && $s->{current} < $last) {
$last = $s->{current};
}
my $string = join('', @{$self->{string}}[$curr..$last]);
return $string;
}
package version::vpp;
use strict;
use POSIX qw/locale_h/;
use locale;
use vars qw ($VERSION @ISA @REGEXS);
$VERSION = 0.9902;
use overload (
'""' => \&stringify,
'0+' => \&numify,
'cmp' => \&vcmp,
'<=>' => \&vcmp,
'bool' => \&vbool,
'+' => \&vnoop,
'-' => \&vnoop,
'*' => \&vnoop,
'/' => \&vnoop,
'+=' => \&vnoop,
'-=' => \&vnoop,
'*=' => \&vnoop,
'/=' => \&vnoop,
'abs' => \&vnoop,
);
eval "use warnings";
if ($@) {
eval '
package
warnings;
sub enabled {return $^W;}
1;
';
}
my $VERSION_MAX = 0x7FFFFFFF;
# implement prescan_version as closely to the C version as possible
use constant TRUE => 1;
use constant FALSE => 0;
sub isDIGIT {
my ($char) = shift->thischar();
return ($char =~ /\d/);
}
sub isALPHA {
my ($char) = shift->thischar();
return ($char =~ /[a-zA-Z]/);
}
sub isSPACE {
my ($char) = shift->thischar();
return ($char =~ /\s/);
}
sub BADVERSION {
my ($s, $errstr, $error) = @_;
if ($errstr) {
$$errstr = $error;
}
return $s;
}
sub prescan_version {
my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_;
my $qv = defined $sqv ? $$sqv : FALSE;
my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0;
my $width = defined $swidth ? $$swidth : 3;
my $alpha = defined $salpha ? $$salpha : FALSE;
my $d = $s;
if ($qv && isDIGIT($d)) {
goto dotted_decimal_version;
}
if ($d eq 'v') { # explicit v-string
$d++;
if (isDIGIT($d)) {
$qv = TRUE;
}
else { # degenerate v-string
# requires v1.2.3
return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
}
dotted_decimal_version:
if ($strict && $d eq '0' && isDIGIT($d+1)) {
# no leading zeros allowed
return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
}
while (isDIGIT($d)) { # integer part
$d++;
}
if ($d eq '.')
{
$saw_decimal++;
$d++; # decimal point
}
else
{
if ($strict) {
# require v1.2.3
return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
}
else {
goto version_prescan_finish;
}
}
{
my $i = 0;
my $j = 0;
while (isDIGIT($d)) { # just keep reading
$i++;
while (isDIGIT($d)) {
$d++; $j++;
# maximum 3 digits between decimal
if ($strict && $j > 3) {
return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)");
}
}
if ($d eq '_') {
if ($strict) {
return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
}
if ( $alpha ) {
return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
}
$d++;
$alpha = TRUE;
}
elsif ($d eq '.') {
if ($alpha) {
return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
}
$saw_decimal++;
$d++;
}
elsif (!isDIGIT($d)) {
last;
}
$j = 0;
}
if ($strict && $i < 2) {
# requires v1.2.3
return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
}
}
} # end if dotted-decimal
else
{ # decimal versions
my $j = 0;
# special $strict case for leading '.' or '0'
if ($strict) {
if ($d eq '.') {
return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)");
}
if ($d eq '0' && isDIGIT($d+1)) {
return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
}
}
# and we never support negative version numbers
if ($d eq '-') {
return BADVERSION($s,$errstr,"Invalid version format (negative version number)");
}
# consume all of the integer part
while (isDIGIT($d)) {
$d++;
}
# look for a fractional part
if ($d eq '.') {
# we found it, so consume it
$saw_decimal++;
$d++;
}
elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') {
if ( $d == $s ) {
# found nothing
return BADVERSION($s,$errstr,"Invalid version format (version required)");
}
# found just an integer
goto version_prescan_finish;
}
elsif ( $d == $s ) {
# didn't find either integer or period
return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
}
elsif ($d eq '_') {
# underscore can't come after integer part
if ($strict) {
return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
}
elsif (isDIGIT($d+1)) {
return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)");
}
else {
return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
}
}
elsif ($d) {
# anything else after integer part is just invalid data
return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
}
# scan the fractional part after the decimal point
if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) {
# $strict or lax-but-not-the-end
return BADVERSION($s,$errstr,"Invalid version format (fractional part required)");
}
while (isDIGIT($d)) {
$d++; $j++;
if ($d eq '.' && isDIGIT($d-1)) {
if ($alpha) {
return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
}
if ($strict) {
return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
}
$d = $s; # start all over again
$qv = TRUE;
goto dotted_decimal_version;
}
if ($d eq '_') {
if ($strict) {
return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
}
if ( $alpha ) {
return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
}
if ( ! isDIGIT($d+1) ) {
return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
}
$width = $j;
$d++;
$alpha = TRUE;
}
}
}
version_prescan_finish:
while (isSPACE($d)) {
$d++;
}
if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) {
# trailing non-numeric data
return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
}
if (defined $sqv) {
$$sqv = $qv;
}
if (defined $swidth) {
$$swidth = $width;
}
if (defined $ssaw_decimal) {
$$ssaw_decimal = $saw_decimal;
}
if (defined $salpha) {
$$salpha = $alpha;
}
return $d;
}
sub scan_version {
my ($s, $rv, $qv) = @_;
my $start;
my $pos;
my $last;
my $errstr;
my $saw_decimal = 0;
my $width = 3;
my $alpha = FALSE;
my $vinf = FALSE;
my @av;
$s = new charstar $s;
while (isSPACE($s)) { # leading whitespace is OK
$s++;
}
$last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal,
\$width, \$alpha);
if ($errstr) {
# 'undef' is a special case and not an error
if ( $s ne 'undef') {
use Carp;
Carp::croak($errstr);
}
}
$start = $s;
if ($s eq 'v') {
$s++;
}
$pos = $s;
if ( $qv ) {
$$rv->{qv} = $qv;
}
if ( $alpha ) {
$$rv->{alpha} = $alpha;
}
if ( !$qv && $width < 3 ) {
$$rv->{width} = $width;
}
while (isDIGIT($pos)) {
$pos++;
}
if (!isALPHA($pos)) {
my $rev;
for (;;) {
$rev = 0;
{
# this is atoi() that delimits on underscores
my $end = $pos;
my $mult = 1;
my $orev;
# the following if() will only be true after the decimal
# point of a version originally created with a bare
# floating point number, i.e. not quoted in any way
#
if ( !$qv && $s > $start && $saw_decimal == 1 ) {
$mult *= 100;
while ( $s < $end ) {
$orev = $rev;
$rev += $s * $mult;
$mult /= 10;
if ( (abs($orev) > abs($rev))
|| (abs($rev) > $VERSION_MAX )) {
warn("Integer overflow in version %d",
$VERSION_MAX);
$s = $end - 1;
$rev = $VERSION_MAX;
$vinf = 1;
}
$s++;
if ( $s eq '_' ) {
$s++;
}
}
}
else {
while (--$end >= $s) {
$orev = $rev;
$rev += $end * $mult;
$mult *= 10;
if ( (abs($orev) > abs($rev))
|| (abs($rev) > $VERSION_MAX )) {
warn("Integer overflow in version");
$end = $s - 1;
$rev = $VERSION_MAX;
$vinf = 1;
}
}
}
}
# Append revision
push @av, $rev;
if ( $vinf ) {
$s = $last;
last;
}
elsif ( $pos eq '.' ) {
$s = ++$pos;
}
elsif ( $pos eq '_' && isDIGIT($pos+1) ) {
$s = ++$pos;
}
elsif ( $pos eq ',' && isDIGIT($pos+1) ) {
$s = ++$pos;
}
elsif ( isDIGIT($pos) ) {
$s = $pos;
}
else {
$s = $pos;
last;
}
if ( $qv ) {
while ( isDIGIT($pos) ) {
$pos++;
}
}
else {
my $digits = 0;
while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) {
if ( $pos ne '_' ) {
$digits++;
}
$pos++;
}
}
}
}
if ( $qv ) { # quoted versions always get at least three terms
my $len = $#av;
# This for loop appears to trigger a compiler bug on OS X, as it
# loops infinitely. Yes, len is negative. No, it makes no sense.
# Compiler in question is:
# gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
# for ( len = 2 - len; len > 0; len-- )
# av_push(MUTABLE_AV(sv), newSViv(0));
#
$len = 2 - $len;
while ($len-- > 0) {
push @av, 0;
}
}
# need to save off the current version string for later
if ( $vinf ) {
$$rv->{original} = "v.Inf";
$$rv->{vinf} = 1;
}
elsif ( $s > $start ) {
$$rv->{original} = $start->currstr($s);
if ( $qv && $saw_decimal == 1 && $start ne 'v' ) {
# need to insert a v to be consistent
$$rv->{original} = 'v' . $$rv->{original};
}
}
else {
$$rv->{original} = '0';
push(@av, 0);
}
# And finally, store the AV in the hash
$$rv->{version} = \@av;
# fix RT#19517 - special case 'undef' as string
if ($s eq 'undef') {
$s += 5;
}
return $s;
}
sub new
{
my ($class, $value) = @_;
unless (defined $class) {
require Carp;
Carp::croak('Usage: version::new(class, version)');
}
my $self = bless ({}, ref ($class) || $class);
my $qv = FALSE;
if ( ref($value) && eval('$value->isa("version")') ) {
# Can copy the elements directly
$self->{version} = [ @{$value->{version} } ];
$self->{qv} = 1 if $value->{qv};
$self->{alpha} = 1 if $value->{alpha};
$self->{original} = ''.$value->{original};
return $self;
}
my $currlocale = setlocale(LC_ALL);
# if the current locale uses commas for decimal points, we
# just replace commas with decimal places, rather than changing
# locales
if ( localeconv()->{decimal_point} eq ',' ) {
$value =~ tr/,/./;
}
if ( not defined $value or $value =~ /^undef$/ ) {
# RT #19517 - special case for undef comparison
# or someone forgot to pass a value
push @{$self->{version}}, 0;
$self->{original} = "0";
return ($self);
}
if ( $#_ == 2 ) { # must be CVS-style
$value = $_[2];
$qv = TRUE;
}
$value = _un_vstring($value);
# exponential notation
if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) {
$value = sprintf("%.9f",$value);
$value =~ s/(0+)$//; # trim trailing zeros
}
my $s = scan_version($value, \$self, $qv);
if ($s) { # must be something left over
warn("Version string '%s' contains invalid data; "
."ignoring: '%s'", $value, $s);
}
return ($self);
}
*parse = \&new;
sub numify
{
my ($self) = @_;
unless (_verify($self)) {
require Carp;
Carp::croak("Invalid version object");
}
my $width = $self->{width} || 3;
my $alpha = $self->{alpha} || "";
my $len = $#{$self->{version}};
my $digit = $self->{version}[0];
my $string = sprintf("%d.", $digit );
for ( my $i = 1 ; $i < $len ; $i++ ) {
$digit = $self->{version}[$i];
if ( $width < 3 ) {
my $denom = 10**(3-$width);
my $quot = int($digit/$denom);
my $rem = $digit - ($quot * $denom);
$string .= sprintf("%0".$width."d_%d", $quot, $rem);
}
else {
$string .= sprintf("%03d", $digit);
}
}
if ( $len > 0 ) {
$digit = $self->{version}[$len];
if ( $alpha && $width == 3 ) {
$string .= "_";
}
$string .= sprintf("%0".$width."d", $digit);
}
else # $len = 0
{
$string .= sprintf("000");
}
return $string;
}
sub normal
{
my ($self) = @_;
unless (_verify($self)) {
require Carp;
Carp::croak("Invalid version object");
}
my $alpha = $self->{alpha} || "";
my $len = $#{$self->{version}};
my $digit = $self->{version}[0];
my $string = sprintf("v%d", $digit );
for ( my $i = 1 ; $i < $len ; $i++ ) {
$digit = $self->{version}[$i];
$string .= sprintf(".%d", $digit);
}
if ( $len > 0 ) {
$digit = $self->{version}[$len];
if ( $alpha ) {
$string .= sprintf("_%0d", $digit);
}
else {
$string .= sprintf(".%0d", $digit);
}
}
if ( $len <= 2 ) {
for ( $len = 2 - $len; $len != 0; $len-- ) {
$string .= sprintf(".%0d", 0);
}
}
return $string;
}
sub stringify
{
my ($self) = @_;
unless (_verify($self)) {
require Carp;
Carp::croak("Invalid version object");
}
return exists $self->{original}
? $self->{original}
: exists $self->{qv}
? $self->normal
: $self->numify;
}
sub vcmp
{
require UNIVERSAL;
my ($left,$right,$swap) = @_;
my $class = ref($left);
unless ( UNIVERSAL::isa($right, $class) ) {
$right = $class->new($right);
}
if ( $swap ) {
($left, $right) = ($right, $left);
}
unless (_verify($left)) {
require Carp;
Carp::croak("Invalid version object");
}
unless (_verify($right)) {
require Carp;
Carp::croak("Invalid version format");
}
my $l = $#{$left->{version}};
my $r = $#{$right->{version}};
my $m = $l < $r ? $l : $r;
my $lalpha = $left->is_alpha;
my $ralpha = $right->is_alpha;
my $retval = 0;
my $i = 0;
while ( $i <= $m && $retval == 0 ) {
$retval = $left->{version}[$i] <=> $right->{version}[$i];
$i++;
}
# tiebreaker for alpha with identical terms
if ( $retval == 0
&& $l == $r
&& $left->{version}[$m] == $right->{version}[$m]
&& ( $lalpha || $ralpha ) ) {
if ( $lalpha && !$ralpha ) {
$retval = -1;
}
elsif ( $ralpha && !$lalpha) {
$retval = +1;
}
}
# possible match except for trailing 0's
if ( $retval == 0 && $l != $r ) {
if ( $l < $r ) {
while ( $i <= $r && $retval == 0 ) {
if ( $right->{version}[$i] != 0 ) {
$retval = -1; # not a match after all
}
$i++;
}
}
else {
while ( $i <= $l && $retval == 0 ) {
if ( $left->{version}[$i] != 0 ) {
$retval = +1; # not a match after all
}
$i++;
}
}
}
return $retval;
}
sub vbool {
my ($self) = @_;
return vcmp($self,$self->new("0"),1);
}
sub vnoop {
require Carp;
Carp::croak("operation not supported with version object");
}
sub is_alpha {
my ($self) = @_;
return (exists $self->{alpha});
}
sub qv {
my $value = shift;
my $class = 'version';
if (@_) {
$class = ref($value) || $value;
$value = shift;
}
$value = _un_vstring($value);
$value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/;
my $obj = version->new($value);
return bless $obj, $class;
}
*declare = \&qv;
sub is_qv {
my ($self) = @_;
return (exists $self->{qv});
}
sub _verify {
my ($self) = @_;
if ( ref($self)
&& eval { exists $self->{version} }
&& ref($self->{version}) eq 'ARRAY'
) {
return 1;
}
else {
return 0;
}
}
sub _is_non_alphanumeric {
my $s = shift;
$s = new charstar $s;
while ($s) {
return 0 if isSPACE($s); # early out
return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/);
$s++;
}
return 0;
}
sub _un_vstring {
my $value = shift;
# may be a v-string
if ( length($value) >= 3 && $value !~ /[._]/
&& _is_non_alphanumeric($value)) {
my $tvalue;
if ( $] ge 5.008_001 ) {
$tvalue = _find_magic_vstring($value);
$value = $tvalue if length $tvalue;
}
elsif ( $] ge 5.006_000 ) {
$tvalue = sprintf("v%vd",$value);
if ( $tvalue =~ /^v\d+(\.\d+){2,}$/ ) {
# must be a v-string
$value = $tvalue;
}
}
}
return $value;
}
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;
}
sub _VERSION {
my ($obj, $req) = @_;
my $class = ref($obj) || $obj;
no strict 'refs';
if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) {
# file but no package
require Carp;
Carp::croak( "$class defines neither package nor VERSION"
."--version check failed");
}
my $version = eval "\$$class\::VERSION";
if ( defined $version ) {
local $^W if $] <= 5.008;
$version = version::vpp->new($version);
}
if ( defined $req ) {
unless ( defined $version ) {
require Carp;
my $msg = $] < 5.006
? "$class version $req required--this is only version "
: "$class does not define \$$class\::VERSION"
."--version check failed";
if ( $ENV{VERSION_DEBUG} ) {
Carp::confess($msg);
}
else {
Carp::croak($msg);
}
}
$req = version::vpp->new($req);
if ( $req > $version ) {
require Carp;
if ( $req->is_qv ) {
Carp::croak(
sprintf ("%s version %s required--".
"this is only version %s", $class,
$req->normal, $version->normal)
);
}
else {
Carp::croak(
sprintf ("%s version %s required--".
"this is only version %s", $class,
$req->stringify, $version->stringify)
);
}
}
}
return defined $version ? $version->stringify : undef;
}
1; #this line is important and will help the module return a true value
VERSION_VPP
s/^ //mg for values %fatpacked;
unshift @INC, sub {
if (my $fat = $fatpacked{$_[1]}) {
if ($] < 5.008) {
return sub {
return 0 unless length $fat;
$fat =~ s/^([^\n]*\n?)//;
$_ = $1;
return 1;
};
}
open my $fh, '<', \$fat
or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
return $fh;
}
return
};
} # END OF FATPACK CODE
use strict;
use App::cpanminus::script;
unless (caller) {
my $app = App::cpanminus::script->new;
$app->parse_options(@ARGV);
exit $app->doit;
}
__END__
=head1 NAME
cpanm - get, unpack build and install modules from CPAN
=head1 SYNOPSIS
cpanm Test::More # install Test::More
cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution path
cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz # install from URL
cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz # install from a local file
cpanm --interactive Task::Kensho # Configure interactively
cpanm . # install from local directory
cpanm --installdeps . # install all the deps for the current directory
cpanm -L extlib Plack # install Plack and all non-core deps into extlib
cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror
=head1 COMMANDS
=over 4
=item (arguments)
Command line arguments can be either a module name, distribution file,
local file path, HTTP URL or git repository URL. Following commands
will all work as you expect.
cpanm Plack
cpanm Plack/Request.pm
cpanm MIYAGAWA/Plack-1.0000.tar.gz
cpanm /path/to/Plack-1.0000.tar.gz
cpanm http://cpan.metacpan.org/authors/id/M/MI/MIYAGAWA/Plack-0.9990.tar.gz
cpanm git://github.com/plack/Plack.git
Additionally, you can use the notation using C<~> and C<@> to specify
version for a given module. C<~> specifies the version requirement in
the L<CPAN::Meta::Spec> format, while C<@> pins the exact version, and
is a shortcut for C<~"== VERSION">.
cpanm Plack~1.0000 # 1.0000 or later
cpanm Plack~">= 1.0000, < 2.0000" # latest of 1.xxxx
cpanm Plack@0.9990 # specific version. same as Plack~"== 0.9990"
The version query including specific version or range will be sent to
L<MetaCPAN> to search for previous releases. The query will search for
BackPAN archives by default, unless you specify C<--dev> option, in
which case, archived versions will be filtered out.
For a git repository, you can specify a branch, tag, or commit SHA to
build. The default is C<master>
cpanm git://github.com/plack/Plack.git@1.0000 # tag
cpanm git://github.com/plack/Plack.git@devel # branch
=item -i, --install
Installs the modules. This is a default behavior and this is just a
compatibility option to make it work like L<cpan> or L<cpanp>.
=item --self-upgrade
Upgrades itself. It's just an alias for:
cpanm App::cpanminus
=item --info
Displays the distribution information in
C<AUTHOR/Dist-Name-ver.tar.gz> format in the standard out.
=item --installdeps
Installs the dependencies of the target distribution but won't build
itself. Handy if you want to try the application from a version
controlled repository such as git.
cpanm --installdeps .
=item --look
Download and unpack the distribution and then open the directory with
your shell. Handy to poke around the source code or do manual
testing.
=item -U, --uninstall
B<EXPERIMENTAL>: Uninstalls the modules. Will remove the distribution
files from your library path using the C<.packlist> file.
When used with C<-l> or C<-L>, only the files under the local::lib
directory will be removed.
B<NOTE>: If you have the "dual-life" module in multiple locations
(i.e. C<site_perl> and C<perl> library path, with perl 5.12 or later),
only the files in C<site_perl> will be deleted.
If the distribution has bin scripts and man, they will be kept in case
the core installation still references that, although there's no
guarantee that the script will continue working as expected with the
older version of .pm files.
=item -h, --help
Displays the help message.
=item -V, --version
Displays the version number.
=back
=head1 OPTIONS
You can specify the default options in C<PERL_CPANM_OPT> environment variable.
=over 4
=item -f, --force
Force install modules even when testing failed.
=item -n, --notest
Skip the testing of modules. Use this only when you just want to save
time for installing hundreds of distributions to the same perl and
architecture you've already tested to make sure it builds fine.
Defaults to false, and you can say C<--no-notest> to override when it
is set in the default options in C<PERL_CPANM_OPT>.
=item --test-only
Run the tests only, and do not install the specified module or
distributions. Handy if you want to verify the new (or even old)
releases pass its unit tests without installing the module.
Note that if you specify this option with a module or distribution
that has dependencies, these dependencies will be installed if you
don't currently have them.
=item -S, --sudo
Switch to the root user with C<sudo> when installing modules. Use this
if you want to install modules to the system perl include path.
Defaults to false, and you can say C<--no-sudo> to override when it is
set in the default options in C<PERL_CPANM_OPT>.
=item -v, --verbose
Makes the output verbose. It also enables the interactive
configuration. (See --interactive)
=item -q, --quiet
Makes the output even more quiet than the default. It only shows the
successful/failed dependencies to the output.
=item -l, --local-lib
Sets the L<local::lib> compatible path to install modules to. You
don't need to set this if you already configure the shell environment
variables using L<local::lib>, but this can be used to override that
as well.
=item -L, --local-lib-contained
Same with C<--local-lib> but with L<--self-contained> set. All
non-core dependencies will be installed even if they're already
installed.
For instance,
cpanm -L extlib Plack
would install Plack and all of its non-core dependencies into the
directory C<extlib>, which can be loaded from your application with:
use local::lib '/path/to/extlib';
=item --self-contained
When examining the dependencies, assume no non-core modules are
installed on the system. Handy if you want to bundle application
dependencies in one directory so you can distribute to other machines.
=item --mirror
Specifies the base URL for the CPAN mirror to use, such as
C<http://cpan.cpantesters.org/> (you can omit the trailing slash). You
can specify multiple mirror URLs by repeating the command line option.
You can use a local directory that has a CPAN mirror structure
(created by tools such as L<OrePAN> or L<Pinto>) by using a special
URL scheme C<file://>. If the given URL begins with `/` (without any
scheme), it is considered as a file scheme as well.
cpanm --mirror file:///path/to/mirror
cpanm --mirror ~/minicpan # Because shell expands ~ to /home/user
Defaults to C<http://www.cpan.org/>.
=item --mirror-only
Download the mirror's 02packages.details.txt.gz index file instead of
querying the CPAN Meta DB. This will also effectively opt out sending
your local perl versions to backend database servers such as CPAN Meta
DB and MetaCPAN.
Select this option if you are using a local mirror of CPAN, such as
minicpan when you're offline, or your own CPAN index (a.k.a darkpan).
B<Tip:> It might be useful if you name these mirror options with your
shell aliases, like:
alias minicpanm='cpanm --mirror ~/minicpan --mirror-only'
alias darkpan='cpanm --mirror http://mycompany.example.com/DPAN --mirror-only'
=item --mirror-index
B<EXPERIMENTAL>: Specifies the file path to C<02packages.details.txt>
for module search index.
=item --cpanmetadb
B<EXPERIMENTAL>: Specifies an alternate URI for CPAN MetaDB index lookups.
=item --cpanfile
B<EXPERIMENTAL>: Specified an alternate path for cpanfile to search for,
when C<--installdeps> command is in use. Defaults to C<cpanfile>.
=item --prompt
Prompts when a test fails so that you can skip, force install, retry
or look in the shell to see what's going wrong. It also prompts when
one of the dependency failed if you want to proceed the installation.
Defaults to false, and you can say C<--no-prompt> to override if it's
set in the default options in C<PERL_CPANM_OPT>.
=item --dev
B<EXPERIMENTAL>: search for a newer developer release as well. Defaults to false.
=item --reinstall
cpanm, when given a module name in the command line (i.e. C<cpanm
Plack>), checks the locally installed version first and skips if it is
already installed. This option makes it skip the check, so:
cpanm --reinstall Plack
would reinstall L<Plack> even if your locally installed version is
latest, or even newer (which would happen if you install a developer
release from version control repositories).
Defaults to false.
=item --interactive
Makes the configuration (such as C<Makefile.PL> and C<Build.PL>)
interactive, so you can answer questions in the distribution that
requires custom configuration or Task:: distributions.
Defaults to false, and you can say C<--no-interactive> to override
when it's set in the default options in C<PERL_CPANM_OPT>.
=item --pp, --pureperl
Prefer Pure perl build of modules by setting C<PUREPERL_ONLY=1> for
MakeMaker and C<--pureperl-only> for Build.PL based
distributions. Note that not all of the CPAN modules support this
convention yet.
=item --with-recommends, --with-suggests
B<EXPERIMENTAL>: Installs dependencies declared as C<recommends> and
C<suggests> respectively, per META spec. When these dependencies fail
to install, cpanm continues the installation, since they're just
recommendation/suggestion.
Enabling this could potentially make a circular dependency for a few
modules on CPAN, when C<recommends> adds a module that C<recommends>
back the module in return.
There's also C<--without-recommend> and C<--without-suggests> to
override the default decision made earlier in C<PERL_CPANM_OPT>.
Defaults to false for both.
=item --with-develop
B<EXPERIMENTAL>: Installs develop phase dependencies in META files or
C<cpanfile> when used with C<--installdeps>. Defaults to false.
=item --with-feature, --without-feature, --with-all-features
B<EXPERIMENTAL>: Specifies the feature to enable, if a module supports
optional features per META spec 2.0.
cpanm --with-feature=opt_csv Spreadsheet::Read
the features can also be interactively chosen when C<--interactive>
option is enabled.
C<--with-all-features> enables all the optional features, and
C<--without-feature> can select a feature to disable.
=item --configure-timeout, --build-timeout, --test-timeout
Specify the timeout length (in seconds) to wait for the configure,
build and test process. Current default values are: 60 for configure,
3600 for build and 1800 for test.
=item --configure-args, --build-args, --test-args, --install-args
B<EXPERIMENTAL>: Pass arguments for configure/build/test/install
commands respectively, for a given module to install.
cpanm DBD::mysql --configure-args="--cflags=... --libs=..."
The argument is only enabled for the module passed as a command line
argument, not dependencies.
=item --scandeps
B<DEPRECATED>: Scans the depencencies of given modules and output the
tree in a text format. (See C<--format> below for more options)
Because this command doesn't actually install any distributions, it
will be useful that by typing:
cpanm --scandeps Catalyst::Runtime
you can make sure what modules will be installed.
This command takes into account which modules you already have
installed in your system. If you want to see what modules will be
installed against a vanilla perl installation, you might want to
combine it with C<-L> option.
=item --format
B<DEPRECATED>: Determines what format to display the scanned
dependency tree. Available options are C<tree>, C<json>, C<yaml> and
C<dists>.
=over 8
=item tree
Displays the tree in a plain text format. This is the default value.
=item json, yaml
Outputs the tree in a JSON or YAML format. L<JSON> and L<YAML> modules
need to be installed respectively. The output tree is represented as a
recursive tuple of:
[ distribution, dependencies ]
and the container is an array containing the root elements. Note that
there may be multiple root nodes, since you can give multiple modules
to the C<--scandeps> command.
=item dists
C<dists> is a special output format, where it prints the distribution
filename in the I<depth first order> after the dependency resolution,
like:
GAAS/MIME-Base64-3.13.tar.gz
GAAS/URI-1.58.tar.gz
PETDANCE/HTML-Tagset-3.20.tar.gz
GAAS/HTML-Parser-3.68.tar.gz
GAAS/libwww-perl-5.837.tar.gz
which means you can install these distributions in this order without
extra dependencies. When combined with C<-L> option, it will be useful
to replay installations on other machines.
=back
=item --save-dists
Specifies the optional directory path to copy downloaded tarballs in
the CPAN mirror compatible directory structure
i.e. I<authors/id/A/AU/AUTHORS/Foo-Bar-version.tar.gz>
If the distro tarball did not come from CPAN, for example from a local
file or from GitHub, then it will be saved under
I<vendor/Foo-Bar-version.tar.gz>.
=item --uninst-shadows
Uninstalls the shadow files of the distribution that you're
installing. This eliminates the confusion if you're trying to install
core (dual-life) modules from CPAN against perl 5.10 or older, or
modules that used to be XS-based but switched to pure perl at some
version.
If you run cpanm as root and use C<INSTALL_BASE> or equivalent to
specify custom installation path, you SHOULD disable this option so
you won't accidentally uninstall dual-life modules from the core
include path.
Defaults to true if your perl version is smaller than 5.12, and you
can disable that with C<--no-uninst-shadows>.
B<NOTE>: Since version 1.3000 this flag is turned off by default for
perl newer than 5.12, since with 5.12 @INC contains site_perl directory
I<before> the perl core library path, and uninstalling shadows is not
necessary anymore and does more harm by deleting files from the core
library path.
=item --uninstall, -U
Uninstalls a module from the library path. It finds a packlist for
given modules, and removes all the files included in the same
distribution.
If you enable local::lib, it only removes files from the local::lib
directory.
If you try to uninstall a module in C<perl> directory (i.e. core
module), an error will be thrown.
A dialog wil be prompted to confirm the files to be deleted. If you pass
C<-f> option as well, the dialog will be skipped and uninstallation
will be forced.
=item --cascade-search
B<EXPERIMENTAL>: Specifies whether to cascade search when you specify
multiple mirrors and a mirror doesn't have a module or has a lower
version of the module than requested. Defaults to false.
=item --skip-installed
Specifies whether a module given in the command line is skipped if its latest
version is already installed. Defaults to true.
B<NOTE>: The C<PERL5LIB> environment variable have to be correctly set
for this to work with modules installed using L<local::lib>, unless
you always use the C<-l> option.
=item --skip-satisfied
B<EXPERIMENTAL>: Specifies whether a module (and version) given in the
command line is skipped if it's already installed.
If you run:
cpanm --skip-satisfied CGI DBI~1.2
cpanm won't install them if you already have CGI (for whatever
versions) or have DBI with version higher than 1.2. It is similar to
C<--skip-installed> but while C<--skip-installed> checks if the
I<latest> version of CPAN is installed, C<--skip-satisfied> checks if
a requested version (or not, which means any version) is installed.
Defaults to false.
=item --verify
Verify the integrity of distribution files retrieved from PAUSE using
CHECKSUMS and SIGNATURES (if found). Defaults to false.
=item --report-perl-version
Whether it report the locally installed perl version to the various
web server as part of User-Agent. Defaults to true, and you can disable
it by using C<--no-report-perl-version>.
=item --auto-cleanup
Specifies the number of days in which cpanm's work directories
expire. Defaults to 7, which means old work directories will be
cleaned up in one week.
You can set the value to C<0> to make cpan never cleanup those
directories.
=item --man-pages
Generates man pages for executables (man1) and libraries (man3).
Defaults to true (man pages generated) unless C<-L|--local-lib-contained>
option is supplied in which case it's set to false. You can disable
it with C<--no-man-pages>.
=item --lwp
Uses L<LWP> module to download stuff over HTTP. Defaults to true, and
you can say C<--no-lwp> to disable using LWP, when you want to upgrade
LWP from CPAN on some broken perl systems.
=item --wget
Uses GNU Wget (if available) to download stuff. Defaults to true, and
you can say C<--no-wget> to disable using Wget (versions of Wget older
than 1.9 don't support the C<--retry-connrefused> option used by cpanm).
=item --curl
Uses cURL (if available) to download stuff. Defaults to true, and
you can say C<--no-curl> to disable using cURL.
Normally with C<--lwp>, C<--wget> and C<--curl> options set to true
(which is the default) cpanm tries L<LWP>, Wget, cURL and L<HTTP::Tiny>
(in that order) and uses the first one available.
=back
=head1 SEE ALSO
L<App::cpanminus>
=head1 COPYRIGHT
Copyright 2010 Tatsuhiko Miyagawa.
=head1 AUTHOR
Tatsuhiko Miyagawa
=cut