Google Git
Sign in
chromium / chromium / deps / perl / 2693003f205ef0f4429a426cc8f6d19a9596e67d / . / perl / bin / cpanm
blob: e48fb392f8df9a7b7f33a0dad77ac1c14d962974 [file] [log] [blame]
#!perl
#
# 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 - --self-upgrade
#
# 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
#
# 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.5013";
=head1 NAME
App::cpanminus - get, unpack, build and install modules from CPAN
=head1 SYNOPSIS
cpanm Module
Run C<cpanm -h> 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 rcommended) 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 running on Google AppEngine at
L<http://cpanmetadb.plackperl.org/>. The site is updated every hour to reflect
the latest changes from fast syncing mirrors. The script then also falls back
to scrape the site L<http://search.cpan.org/>.
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 *
Bundle:: module dependencies
=item *
CPAN testers reporting
=item *
Building RPM packages from CPAN modules
=item *
Listing the outdated modules that needs upgrading. See L<App::cpanoutdated>
=item *
Uninstalling modules. See L<pm-uninstall>.
=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> Copyright (c) 2010 by David Golden and Ricardo Signes
=item L<Try::Tiny> Copyright (c) 2009 Yuval Kogman
=item L<parent> Copyright (c) 2007-10 Max Maischein
=item L<Version::Requirements> copyright (c) 2010 by Ricardo Signes
=item L<CPAN::Meta::YAML> copyright (c) 2010 by Adam Kennedy
=back
=head1 LICENSE
Same 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/script.pm"} = <<'APP_CPANMINUS_SCRIPT';
package App::cpanminus::script;
use strict;
use Config;
use Cwd ();
use File::Basename ();
use File::Find ();
use File::Path ();
use File::Spec ();
use File::Copy ();
use Getopt::Long ();
use Parse::CPAN::Meta;
use Symbol ();
use constant WIN32 => $^O eq 'MSWin32';
use constant SUNOS => $^O eq 'solaris';
our $VERSION = "1.5013";
my $quote = WIN32 ? q/"/ : q/'/;
sub new {
my $class = shift;
bless {
home => (eval {require File::HomeDir} ? File::HomeDir->my_home : $ENV{HOME}) . "/.cpanm",
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,
perl => $^X,
argv => [],
local_lib => undef,
self_contained => undef,
prompt_timeout => 0,
prompt => undef,
configure_timeout => 60,
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,
showdeps => 0,
scandeps => 0,
scandeps_tree => [],
format => 'tree',
save_dists => undef,
skip_configure => 0,
@_,
}, $class;
}
sub env {
my($self, $key) = @_;
$ENV{"PERL_CPANM_" . $key};
}
sub parse_options {
my $self = shift;
local @ARGV = @{$self->{argv}};
push @ARGV, 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 },
'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;
},
'mirror=s@' => $self->{mirrors},
'mirror-only!' => \$self->{mirror_only},
'mirror-index=s' => sub { $self->{mirror_index} = $_[1]; $self->{mirror_only} = 1 },
'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 },
'self-upgrade' => sub { $self->{cmd} = 'install'; $self->{skip_installed} = 1; push @ARGV, 'App::cpanminus' },
'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},
'metacpan' => \$self->{metacpan},
);
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_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 doit {
my $self = shift;
$self->setup_home;
$self->init_tools;
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) = split /\~/, $module, 2 if $module =~ /\~[v\d\._]+$/;
if ($self->{skip_satisfied} or defined $version) {
$self->check_libs;
my($ok, $local) = $self->check_module($module, $version || 0);
if ($ok) {
$self->diag("You have $module (" . ($local || 'undef') . ")\n", 1);
next;
}
}
$self->chdir($cwd);
$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();
}
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);
my $link = "$self->{home}/latest-build";
eval { unlink $link; symlink $self->{base}, $link };
$self->{log} = File::Spec->catfile($self->{home}, "build.log"); # because we use shell redirect
{
my $log = $self->{log}; my $base = $self->{base};
$self->{at_exit} = sub {
my $self = shift;
File::Copy::copy($self->{log}, "$self->{base}/build.log");
};
}
{ open my $out, ">$self->{log}" or die "$self->{log}: $!" }
$self->chat("cpanm (App::cpanminus) $VERSION on perl $] built for $Config{archname}\n" .
"Work directory is $self->{base}\n");
}
sub fetch_meta_sco {
my($self, $dist) = @_;
return if $self->{mirror_only};
my $meta_yml = $self->get("http://search.cpan.org/meta/$dist->{distvname}/META.yml");
return $self->parse_meta_string($meta_yml);
}
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+(.*)!m) {
$found = $self->cpan_module($module, $2, $1);
last;
}
}
return $found unless $self->{cascade_search};
if ($found) {
if (!$version or
version->new($found->{version} || 0) >= version->new($version)) {
return $found;
} else {
$self->chat("Found $module version $found->{version} < $version.\n");
}
}
return;
}
sub search_module {
my($self, $module, $version) = @_;
if ($self->{mirror_index}) {
$self->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->diag_fail("Finding $module ($version) on mirror index $self->{mirror_index} failed.");
return;
}
}
unless ($self->{mirror_only}) {
if ($self->{metacpan}) {
require JSON::PP;
$self->chat("Searching $module on metacpan ...\n");
my $module_uri = "http://api.metacpan.org/module/$module";
my $module_json = $self->get($module_uri);
my $module_meta = eval { JSON::PP::decode_json($module_json) };
if ($module_meta && $module_meta->{distribution}) {
my $dist_uri = "http://api.metacpan.org/release/$module_meta->{distribution}";
my $dist_json = $self->get($dist_uri);
my $dist_meta = eval { JSON::PP::decode_json($dist_json) };
if ($dist_meta && $dist_meta->{download_url}) {
(my $distfile = $dist_meta->{download_url}) =~ s!.+/authors/id/!!;
local $self->{mirrors} = $self->{mirrors};
if ($dist_meta->{stat}->{mtime} > time()-24*60*60) {
$self->{mirrors} = ['http://cpan.metacpan.org'];
}
return $self->cpan_module($module, $distfile, $dist_meta->{version});
}
}
$self->diag_fail("Finding $module on metacpan failed.");
}
$self->chat("Searching $module on cpanmetadb ...\n");
my $uri = "http://cpanmetadb.plackperl.org/v1.0/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.");
$self->chat("Searching $module on search.cpan.org ...\n");
my $uri = "http://search.cpan.org/perldoc?$module";
my $html = $self->get($uri);
$html =~ m!<a href="/CPAN/authors/id/(.*?\.(?:tar\.gz|tgz|tar\.bz2|zip))">!
and return $self->cpan_module($module, $1);
$self->diag_fail("Finding $module on search.cpan.org failed.");
}
MIRROR: for my $mirror (@{ $self->{mirrors} }) {
$self->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->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->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 {
print "cpanm (App::cpanminus) version $VERSION\n";
return 1;
}
sub show_help {
my $self = shift;
if ($_[0]) {
die <<USAGE;
Usage: cpanm [options] Module [...]
Try `cpanm --help` or `man cpanm` for more options.
USAGE
}
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
--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
-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) = @_;
return $lib if $lib eq '_'; # special case: gh-113
$lib =~ /^[~\/]/ ? $lib : File::Spec->canonpath(Cwd::cwd . "/$lib");
}
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});
}
# 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);
}
sub setup_local_lib {
my($self, $base) = @_;
$base = undef if $base eq '_';
require local::lib;
{
local $0 = 'cpanm'; # so curl/wget | perl works
$base ||= "~/perl5";
if ($self->{self_contained}) {
my @inc = $self->_core_only_inc($base);
$self->{search_inc} = [ @inc ];
} else {
$self->{search_inc} = [
local::lib->resolve_path(local::lib->install_base_arch_path($base)),
local::lib->resolve_path(local::lib->install_base_perl_path($base)),
@INC,
];
}
$self->_setup_local_lib_env($base);
}
$self->bootstrap_local_lib_deps;
}
sub bootstrap_local_lib_deps {
my $self = shift;
push @{$self->{bootstrap_deps}},
'ExtUtils::MakeMaker' => 6.31,
'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);
$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) = @_;
print STDERR $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 log {
my $self = shift;
open my $out, ">>$self->{log}";
print $out @_;
}
sub run {
my($self, $cmd) = @_;
if (WIN32 && ref $cmd eq 'ARRAY') {
$cmd = join q{ }, map { $self->shell_quote($_) } @$cmd;
}
if (ref $cmd eq 'ARRAY') {
my $pid = fork;
if ($pid) {
waitpid $pid, 0;
return !$?;
} else {
$self->run_exec($cmd);
}
} else {
unless ($self->{verbose}) {
$cmd .= " >> " . $self->shell_quote($self->{log}) . " 2>&1";
}
!system $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 configure {
my($self, $cmd) = @_;
# 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";
}
local $self->{verbose} = $self->{verbose} || $self->{interactive};
$self->run_timeout($cmd, $self->{configure_timeout});
}
sub build {
my($self, $cmd, $distname) = @_;
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) if $ans eq 'r';
$self->show_build_log if $ans eq 'e';
$self->look if $ans eq 'l';
}
}
sub test {
my($self, $cmd, $distname) = @_;
return 1 if $self->{notest};
# https://rt.cpan.org/Ticket/Display.html?id=48965#txn-1013385
local $ENV{PERL_MM_USE_DEFAULT} = 1;
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) 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;
}
$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->{argv} = [ 'App::cpanminus' ];
return; # continue
}
sub install_module {
my($self, $module, $depth, $version) = @_;
if ($self->{seen}{$module}++) {
$self->chat("Already tried $module. Skipping.\n");
return 1;
}
my $dist = $self->resolve_name($module, $version);
unless ($dist) {
$self->diag_fail("Couldn't find module or a distribution $module ($version)", 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;
}
$self->check_libs;
$self->setup_module_build_patch unless $self->{pod2man};
if ($dist->{module}) {
my($ok, $local) = $self->check_module($dist->{module}, $dist->{module_version} || 0);
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 format_dist {
my($self, $dist) = @_;
# TODO support --dist-format?
return "$dist->{cpanid}/$dist->{filename}";
}
sub fetch_module {
my($self, $dist) = @_;
$self->chdir($self->{base});
for my $uri (@{$dist->{uris}}) {
$self->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->chat("$@") 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);
next unless $dir; # unpack failed
if (my $save = $self->{save_dists}) {
my $path = "$save/authors/id/$dist->{pathname}";
$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) = @_;
$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 resolve_name {
my($self, $module, $version) = @_;
# URL
if ($module =~ /^(ftp|https?|file):/) {
if ($module =~ m!authors/id/!) {
return $self->cpan_dist($module, $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) ],
};
}
# cpan URI
if ($module =~ s!^cpan:///distfile/!!) {
return $self->cpan_dist($module);
}
# PAUSEID/foo
if ($module =~ m!([A-Z]{3,})/!) {
return $self->cpan_dist($module);
}
# 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]{3})!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 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 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)) {
require Module::CoreList;
unless (exists $Module::CoreList::version{$]+0}{$mod}) {
return 0, undef;
}
$version = $Module::CoreList::version{$]+0}{$mod};
}
$self->{local_versions}{$mod} = $version;
if ($self->is_deprecated($meta)){
return 0, $version;
} elsif (!$want_ver or $version >= version->new($want_ver)) {
return 1, ($version || 'undef');
} else {
return 0, $version;
}
}
sub is_deprecated {
my($self, $meta) = @_;
my $deprecated = eval {
require Module::CoreList;
Module::CoreList::is_deprecated($meta->{module});
};
return unless $deprecated;
return $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 ($local < $ver)\n") }
else { $self->chat("No\n") }
return $mod unless $ok;
return;
}
sub install_deps {
my($self, $dir, $depth, @deps) = @_;
my(@install, %seen);
while (my($mod, $ver) = splice @deps, 0, 2) {
next if $seen{$mod} or $mod eq 'perl' or $mod eq 'Config';
if ($self->should_install($mod, $ver)) {
push @install, [ $mod, $ver ];
$seen{$mod} = 1;
}
}
if (@install) {
$self->diag("==> Found dependencies: " . join(", ", map $_->[0], @install) . "\n");
}
my @fail;
for my $mod (@install) {
$self->install_module($mod->[0], $depth + 1, $mod->[1])
or push @fail, $mod->[0];
}
$self->chdir($self->{base});
$self->chdir($dir) if $dir;
return @fail;
}
sub install_deps_bailout {
my($self, $target, $dir, $depth, @deps) = @_;
my @fail = $self->install_deps($dir, $depth, @deps);
if (@fail) {
unless ($self->prompt_bool("Installing the following dependencies failed:\n==> " .
join(", ", @fail) . "\nDo you want to continue building $target anyway?", "n")) {
$self->diag_fail("Bailing out the installation for $target. Retry with --prompt or --force.", 1);
return;
}
}
return 1;
}
sub build_stuff {
my($self, $stuff, $dist, $depth) = @_;
my @config_deps;
if (!%{$dist->{meta} || {}} && -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 not found or unparsable. Fetching META.yml from search.cpan.org\n");
$dist->{meta} = $self->fetch_meta_sco($dist);
}
$dist->{meta} ||= {};
push @config_deps, %{$dist->{meta}{configure_requires} || {}};
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);
$self->diag_ok($configure_state->{configured_ok} ? "OK" : "N/A");
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}) {
my %rootdeps = (@config_deps, @deps); # merge
for my $mod (keys %rootdeps) {
my $ver = $rootdeps{$mod};
print $mod, ($ver ? "~$ver" : ""), "\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 _) {
my @switches = $self->{pod2man} ? () : ("-I$self->{base}", "-MModuleBuildSkipMan");
$self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname);
$self->build([ $self->{perl}, @switches, "./Build" ], $distname) &&
$self->test([ $self->{perl}, "./Build", "test" ], $distname) &&
$self->install([ $self->{perl}, @switches, "./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) &&
$self->test([ $self->{make}, "test" ], $distname) &&
$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 $how = $reinstall ? "reinstalled $distname"
: $local ? "installed $distname (upgraded 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.", 1);
return;
}
}
sub configure_this {
my($self, $dist) = @_;
if (-e 'cpanfile' && $self->{installdeps}) {
require CPAN::cpanfile;
$dist->{cpanfile} = eval { CPAN::cpanfile->load('cpanfile') };
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 @mb_switches;
unless ($self->{pod2man}) {
# it has to be push, so Module::Build is loaded from the adjusted path when -L is in use
push @mb_switches, ("-I$self->{base}", "-MModuleBuildSkipMan");
}
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" ])) {
$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}, @mb_switches, "Build.PL" ])) {
$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) 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 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 = $self->_merge_hashref(
map Module::Metadata->package_versions_from_directory($_),
qw( blib/lib blib/arch ) # FCGI.pm :(
);
mkdir "blib/meta", 0777 or die $!;
my $local = {
name => $module_name,
target => $module,
version => $provides->{$module_name}{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 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 $prereq = $dist->{cpanfile}->prereq;
my @phase = $self->{notest} ? qw( build runtime ) : qw( build test runtime );
require CPAN::Meta::Requirements;
my $req = CPAN::Meta::Requirements->new;
$req->add_requirements($prereq->requirements_for($_, 'requires')) for @phase;
return %{$req->as_string_hash};
}
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_requires($mymeta);
}
}
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_requires($mymeta);
}
}
if (-e '_build/prereqs') {
$self->chat("Checking dependencies from _build/prereqs ...\n");
my $mymeta = do { open my $in, "_build/prereqs"; $self->safe_eval(join "", <$in>) };
@deps = $self->extract_requires($mymeta);
} 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, %$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, $1, $self->maybe_version($2);
}
}
}
return @deps;
}
sub maybe_version {
my($self, $string) = @_;
return $string && $string =~ /^\.?\d/ ? $string : undef;
}
sub extract_requires {
my($self, $meta) = @_;
if ($meta->{'meta-spec'} && $meta->{'meta-spec'}{version} == 2) {
my @phase = $self->{notest} ? qw( build runtime ) : qw( build test runtime );
my @deps = map {
my $p = $meta->{prereqs}{$_} || {};
%{$p->{requires} || {}};
} @phase;
return @deps;
}
my @deps;
push @deps, %{$meta->{build_requires}} if $meta->{build_requires};
push @deps, %{$meta->{requires}} if $meta->{requires};
return @deps;
}
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) {
$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;
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) = @_;
$stuff =~ /^${quote}.+${quote}$/ ? $stuff : ($quote . $stuff . $quote);
}
sub which {
my($self, $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 !~ /^$quote/) {
$fullpath = $self->shell_quote($fullpath);
}
return $fullpath;
}
}
return;
}
sub get { $_[0]->{_backends}{get}->(@_) };
sub mirror { $_[0]->{_backends}{mirror}->(@_) };
sub untar { $_[0]->{_backends}{untar}->(@_) };
sub unzip { $_[0]->{_backends}{unzip}->(@_) };
sub file_get {
my($self, $uri) = @_;
open my $fh, "<$uri" or return;
join '', <$fh>;
}
sub file_mirror {
my($self, $uri, $path) = @_;
File::Copy::copy($uri, $path);
}
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} && eval { require LWP::UserAgent; LWP::UserAgent->VERSION(5.802) }) {
$self->chat("You have LWP $LWP::VERSION\n");
my $ua = sub {
LWP::UserAgent->new(
parse_head => 0,
env_proxy => 1,
agent => "cpanminus/$VERSION",
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(@_);
$res->code;
};
} elsif ($self->{try_wget} and my $wget = $self->which('wget')) {
$self->chat("You have $wget\n");
$self->{_backends}{get} = sub {
my($self, $uri) = @_;
return $self->file_get($uri) if $uri =~ s!^file:/+!/!;
$self->safeexec( my $fh, $wget, $uri, ( $self->{verbose} ? () : '-q' ), '-O', '-' ) or die "wget $uri: $!";
local $/;
<$fh>;
};
$self->{_backends}{mirror} = sub {
my($self, $uri, $path) = @_;
return $self->file_mirror($uri, $path) if $uri =~ s!^file:/+!/!;
$self->safeexec( my $fh, $wget, '--retry-connrefused', $uri, ( $self->{verbose} ? () : '-q' ), '-O', $path ) or die "wget $uri: $!";
local $/;
<$fh>;
};
} elsif ($self->{try_curl} and my $curl = $self->which('curl')) {
$self->chat("You have $curl\n");
$self->{_backends}{get} = sub {
my($self, $uri) = @_;
return $self->file_get($uri) if $uri =~ s!^file:/+!/!;
$self->safeexec( my $fh, $curl, '-L', ( $self->{verbose} ? () : '-s' ), $uri ) or die "curl $uri: $!";
local $/;
<$fh>;
};
$self->{_backends}{mirror} = sub {
my($self, $uri, $path) = @_;
return $self->file_mirror($uri, $path) if $uri =~ s!^file:/+!/!;
$self->safeexec( my $fh, $curl, '-L', $uri, ( $self->{verbose} ? () : '-s' ), '-#', '-o', $path ) or die "curl $uri: $!";
local $/;
<$fh>;
};
} else {
require HTTP::Tiny;
$self->chat("Falling back to HTTP::Tiny $HTTP::Tiny::VERSION\n");
$self->{_backends}{get} = sub {
my $self = shift;
my $res = HTTP::Tiny->new->get($_[0]);
return unless $res->{success};
return $res->{content};
};
$self->{_backends}{mirror} = sub {
my $self = shift;
my $res = HTTP::Tiny->new->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 = "xf" . ($self->{verbose} ? 'v' : '');
my $ar = $tarfile =~ /bz2$/ ? 'j' : 'z';
my($root, @others) = `$tar tf$ar $tarfile`
or return undef;
chomp $root;
$root =~ s!^\./!!;
$root =~ s{^(.+?)/.*$}{$1};
system "$tar $xf$ar $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;
chomp $root;
$root =~ s{^(.+?)/.*$}{$1};
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 = ($t->list_files)[0];
$root =~ s{^(.+?)/.*$}{$1};
$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();
my $root;
for my $member ( @members ) {
my $af = $member->fileName();
next if ($af =~ m!^(/|\.\./)!);
$root = $af unless $root;
$status = $member->extractToFileNamed( $af );
$self->diag_fail("Extracting of file[$af] from zipfile[$file failed")
if $status != Archive::Zip::AZ_OK();
}
return -d $root ? $root : undef;
};
}
}
sub safeexec {
my $self = shift;
my $rdr = $_[0] ||= Symbol::gensym();
if (WIN32) {
my $cmd = join q{ }, map { $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 parse_meta {
my($self, $file) = @_;
return eval { (Parse::CPAN::Meta::LoadFile($file))[0] } || undef;
}
sub parse_meta_string {
my($self, $yaml) = @_;
return eval { (Parse::CPAN::Meta::Load($yaml))[0] } || undef;
}
1;
APP_CPANMINUS_SCRIPT
$fatpacked{"CPAN/DistnameInfo.pm"} = <<'CPAN_DISTNAMEINFO';
package CPAN::DistnameInfo;
$VERSION = "0.11";
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;
}
# 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__
CPAN_DISTNAMEINFO
$fatpacked{"CPAN/Meta.pm"} = <<'CPAN_META';
use 5.006;
use strict;
use warnings;
package CPAN::Meta;
BEGIN {
$CPAN::Meta::VERSION = '2.110930';
}
# ABSTRACT: the distribution metadata for a CPAN dist
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.4400 ();
sub _dclone {
my $ref = shift;
my $backend = Parse::CPAN::Meta->json_backend();
return $backend->new->decode(
$backend->new->convert_blessed->encode($ref)
);
}
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;
__END__
CPAN_META
$fatpacked{"CPAN/Meta/Converter.pm"} = <<'CPAN_META_CONVERTER';
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Converter;
BEGIN {
$CPAN::Meta::Converter::VERSION = '2.110930';
}
# ABSTRACT: Convert CPAN distribution metadata structures
use CPAN::Meta::Validator;
use version 0.82 ();
use Parse::CPAN::Meta 1.4400 ();
sub _dclone {
my $ref = shift;
my $backend = Parse::CPAN::Meta->json_backend();
return $backend->new->decode(
$backend->new->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 _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, $key, $meta, $to_version) = @_;
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>' );
if ( my $v = eval { version->new($element) } ) {
return $v->is_qv ? $v->normal : $element;
}
else {
return 0;
}
}
sub _version_map {
my ($element) = @_;
return undef unless defined $element;
if ( ref $element eq 'HASH' ) {
my $new_map = {};
for my $k ( keys %$element ) {
next unless _is_module_name($k);
my $value = $element->{$k};
if ( ! ( defined $value && length $value ) ) {
$new_map->{$k} = 0;
}
elsif ( $value eq 'undef' || $value eq '<undef>' ) {
$new_map->{$k} = 0;
}
elsif ( _is_module_name( $value ) ) { # some weird, old META have this
$new_map->{$k} = 0;
$new_map->{$value} = 0;
}
else {
$new_map->{$k} = _clean_version($value);
}
}
return $new_map;
}
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)) || {};
require Version::Requirements;
my $test_req = Version::Requirements->from_string_hash($test_h);
my $build_req = Version::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 $prereqs->{$phase}{$type};
}
sub _downgrade_optional_features {
my (undef, undef, $meta) = @_;
return undef 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 undef 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 undef }
},
repository => sub { return _is_urlish($_[0]) ? { url => $_[0] } : undef },
':custom' => \&_prefix_custom,
};
sub _upgrade_resources_2 {
my (undef, undef, $meta, $version) = @_;
return undef 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 undef 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 undef 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 undef 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' => \&_ucfirst_custom,
};
sub _downgrade_resources {
my (undef, undef, $meta, $version) = @_;
return undef 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 => \&_clean_version,
};
my $provides_spec_2 = {
file => \&_keep,
version => \&_clean_version,
':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);
}
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;
__END__
CPAN_META_CONVERTER
$fatpacked{"CPAN/Meta/Feature.pm"} = <<'CPAN_META_FEATURE';
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Feature;
BEGIN {
$CPAN::Meta::Feature::VERSION = '2.110930';
}
# ABSTRACT: an optional feature provided by a CPAN distribution
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;
__END__
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;
BEGIN {
$CPAN::Meta::History::VERSION = '2.110930';
}
# ABSTRACT: history of CPAN Meta Spec changes
1;
__END__
=pod
CPAN_META_HISTORY
$fatpacked{"CPAN/Meta/Prereqs.pm"} = <<'CPAN_META_PREREQS';
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Prereqs;
BEGIN {
$CPAN::Meta::Prereqs::VERSION = '2.110930';
}
# ABSTRACT: a set of distribution prerequisites by phase and type
use Carp qw(confess);
use Scalar::Util qw(blessed);
use Version::Requirements 0.101020; # finalize
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} = Version::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} ||= Version::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 = Version::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;
__END__
CPAN_META_PREREQS
$fatpacked{"CPAN/Meta/Spec.pm"} = <<'CPAN_META_SPEC';
# vi:tw=72
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Spec;
BEGIN {
$CPAN::Meta::Spec::VERSION = '2.110930';
}
# ABSTRACT: specification for CPAN distribution metadata
1;
__END__
=pod
CPAN_META_SPEC
$fatpacked{"CPAN/Meta/Validator.pm"} = <<'CPAN_META_VALIDATOR';
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Validator;
BEGIN {
$CPAN::Meta::Validator::VERSION = '2.110930';
}
# ABSTRACT: validate CPAN distribution metadata structures
#--------------------------------------------------------------------------#
# 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.phpt',
'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;
__END__
CPAN_META_VALIDATOR
$fatpacked{"CPAN/Meta/YAML.pm"} = <<'CPAN_META_YAML';
package CPAN::Meta::YAML;
BEGIN {
$CPAN::Meta::YAML::VERSION = '0.003';
}
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)/ 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 {
eval {
require Scalar::Util;
*refaddr = *Scalar::Util::refaddr;
};
eval <<'END_PERL' if $@;
# Failed to load Scalar::Util
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
}
1;
__END__
# ABSTRACT: Read and write a subset of YAML for CPAN Meta files
CPAN_META_YAML
$fatpacked{"HTTP/Tiny.pm"} = <<'HTTP_TINY';
# vim: ts=4 sts=4 sw=4 et:
#
# This file is part of HTTP-Tiny
#
# This software is copyright (c) 2011 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.
#
package HTTP::Tiny;
BEGIN {
$HTTP::Tiny::VERSION = '0.009';
}
use strict;
use warnings;
# ABSTRACT: A small, simple, correct HTTP/1.1 client
use Carp ();
my @attributes;
BEGIN {
@attributes = qw(agent default_headers max_redirect max_size proxy timeout);
no strict 'refs';
for my $accessor ( @attributes ) {
*{$accessor} = sub {
@_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
};
}
}
sub new {
my($class, %args) = @_;
(my $agent = $class) =~ s{::}{-}g;
my $self = {
agent => $agent . "/" . ($class->VERSION || 0),
max_redirect => 5,
timeout => 60,
};
for my $key ( @attributes ) {
$self->{$key} = $args{$key} if exists $args{$key}
}
return bless $self, $class;
}
sub get {
my ($self, $url, $args) = @_;
@_ == 2 || (@_ == 3 && ref $args eq 'HASH')
or Carp::croak(q/Usage: $http->get(URL, [HASHREF])/);
return $self->request('GET', $url, $args || {});
}
sub mirror {
my ($self, $url, $file, $args) = @_;
@_ == 3 || (@_ == 4 && ref $args eq 'HASH')
or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/);
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: $!/);
$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: $!/);
if ( $response->{success} ) {
rename $tempfile, $file
or Carp::croak "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])/);
$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 = {
success => q{},
status => 599,
reason => 'Internal Exception',
content => $e,
headers => {
'content-type' => 'text/plain',
'content-length' => length $e,
}
};
}
return $response;
}
my %DefaultPort = (
http => 80,
https => 443,
);
sub _request {
my ($self, $method, $url, $args) = @_;
my ($scheme, $host, $port, $path_query) = $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});
if ($self->{proxy}) {
$request->{uri} = "$scheme://$request->{host_port}$path_query";
croak(qq/HTTPS via proxy is not supported/)
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);
$handle->write_request($request);
my $response;
do { $response = $handle->read_response_header }
until (substr($response->{status},0,1) ne '1');
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';
return $response;
}
sub _prepare_headers_and_cb {
my ($self, $request, $args) = @_;
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}) {
$request->{headers}{'content-type'} ||= "application/octet-stream";
if (ref $args->{content} eq 'CODE') {
$request->{headers}{'transfer-encoding'} = 'chunked'
unless $request->{headers}{'content-length'}
|| $request->{headers}{'transfer-encoding'};
$request->{cb} = $args->{content};
}
else {
my $content = $args->{content};
if ( $] ge '5.008' ) {
utf8::downgrade($content, 1)
or Carp::croak(q/Wide character in request message body/);
}
$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';
}
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 _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 Carp::croak(qq/Cannot parse URL: '$url'/);
$scheme = lc $scheme;
$path_query = "/$path_query" unless $path_query =~ m<\A/>;
my $host = (length($authority)) ? lc $authority : 'localhost';
$host =~ s/\A[^@]*@//; # userinfo
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);
}
# 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;
};
}
package
HTTP::Tiny::Handle; # hide from PAUSE/indexers
use strict;
use warnings;
use Carp qw[croak];
use Errno qw[EINTR EPIPE];
use IO::Socket qw[SOCK_STREAM];
sub BUFSIZE () { 32768 }
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,
%args
}, $class;
}
my $ssl_verify_args = {
check_cn => "when_only",
wildcards_in_alt => "anywhere",
wildcards_in_cn => "anywhere"
};
sub connect {
@_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
my ($self, $scheme, $host, $port) = @_;
if ( $scheme eq 'https' ) {
eval "require IO::Socket::SSL"
unless exists $INC{'IO/Socket/SSL.pm'};
croak(qq/IO::Socket::SSL must be installed for https support\n/)
unless $INC{'IO/Socket/SSL.pm'};
}
elsif ( $scheme ne 'http' ) {
croak(qq/Unsupported URL scheme '$scheme'/);
}
$self->{fh} = 'IO::Socket::INET'->new(
PeerHost => $host,
PeerPort => $port,
Proto => 'tcp',
Type => SOCK_STREAM,
Timeout => $self->{timeout}
) or croak(qq/Could not connect to '$host:$port': $@/);
binmode($self->{fh})
or croak(qq/Could not binmode() socket: '$!'/);
if ( $scheme eq 'https') {
IO::Socket::SSL->start_SSL($self->{fh});
ref($self->{fh}) eq 'IO::Socket::SSL'
or die(qq/SSL connection failed for $host\n/);
$self->{fh}->verify_hostname( $host, $ssl_verify_args )
or die(qq/SSL certificate not valid for $host\n/);
}
$self->{host} = $host;
$self->{port} = $port;
return $self;
}
sub close {
@_ == 1 || croak(q/Usage: $handle->close()/);
my ($self) = @_;
CORE::close($self->{fh})
or croak(qq/Could not close socket: '$!'/);
}
sub write {
@_ == 2 || croak(q/Usage: $handle->write(buf)/);
my ($self, $buf) = @_;
if ( $] ge '5.008' ) {
utf8::downgrade($buf, 1)
or croak(q/Wide character in write()/);
}
my $len = length $buf;
my $off = 0;
local $SIG{PIPE} = 'IGNORE';
while () {
$self->can_write
or croak(q/Timed out while waiting for socket to become ready for writing/);
my $r = syswrite($self->{fh}, $buf, $len, $off);
if (defined $r) {
$len -= $r;
$off += $r;
last unless $len > 0;
}
elsif ($! == EPIPE) {
croak(qq/Socket closed by remote server: $!/);
}
elsif ($! != EINTR) {
croak(qq/Could not write to socket: '$!'/);
}
}
return $off;
}
sub read {
@_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len [, allow_partial])/);
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 croak(q/Timed out while waiting for socket to become ready for reading/);
my $r = sysread($self->{fh}, $buf, $len, length $buf);
if (defined $r) {
last unless $r;
$len -= $r;
}
elsif ($! != EINTR) {
croak(qq/Could not read from socket: '$!'/);
}
}
if ($len && !$allow_partial) {
croak(q/Unexpected end of stream/);
}
return $buf;
}
sub readline {
@_ == 1 || croak(q/Usage: $handle->readline()/);
my ($self) = @_;
while () {
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
return $1;
}
if (length $self->{rbuf} >= $self->{max_line_size}) {
croak(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}/);
}
$self->can_read
or croak(q/Timed out while waiting for socket to become ready for reading/);
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
if (defined $r) {
last unless $r;
}
elsif ($! != EINTR) {
croak(qq/Could not read from socket: '$!'/);
}
}
croak(q/Unexpected end of stream while looking for line/);
}
sub read_header_lines {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
my ($self, $headers) = @_;
$headers ||= {};
my $lines = 0;
my $val;
while () {
my $line = $self->readline;
if (++$lines >= $self->{max_header_lines}) {
croak(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}/);
}
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 croak(q/Unexpected header continuation line/);
next unless length $1;
$$val .= ' ' if length $$val;
$$val .= $1;
}
elsif ($line =~ /\A \x0D?\x0A \z/x) {
last;
}
else {
croak(q/Malformed header line: / . $Printable->($line));
}
}
return $headers;
}
sub write_request {
@_ == 2 || croak(q/Usage: $handle->write_request(request)/);
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') || croak(q/Usage: $handle->write_header_lines(headers)/);
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 croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
$field_name =~ s/\b(\w)/\u$1/g;
$HeaderCase{lc $field_name} = $field_name;
}
for (ref $v eq 'ARRAY' ? @$v : $v) {
/[^\x0D\x0A]/
or croak(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_));
$buf .= "$field_name: $_\x0D\x0A";
}
}
$buf .= "\x0D\x0A";
return $self->write($buf);
}
sub read_body {
@_ == 3 || croak(q/Usage: $handle->read_body(callback, response)/);
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 || croak(q/Usage: $handle->write_body(request)/);
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 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
my ($self, $cb, $response, $content_length) = @_;
$content_length ||= $response->{headers}{'content-length'};
if ( $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 || croak(q/Usage: $handle->write_content_body(request)/);
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 croak(q/Wide character in write_content()/);
}
$len += $self->write($data);
}
$len == $content_length
or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
return $len;
}
sub read_chunked_body {
@_ == 3 || croak(q/Usage: $handle->read_chunked_body(callback, $response)/);
my ($self, $cb, $response) = @_;
while () {
my $head = $self->readline;
$head =~ /\A ([A-Fa-f0-9]+)/x
or croak(q/Malformed chunk head: / . $Printable->($head));
my $len = hex($1)
or last;
$self->read_content_body($cb, $response, $len);
$self->read(2) eq "\x0D\x0A"
or croak(q/Malformed chunk: missing CRLF after chunk data/);
}
$self->read_header_lines($response->{headers});
return;
}
sub write_chunked_body {
@_ == 2 || croak(q/Usage: $handle->write_chunked_body(request)/);
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 croak(q/Wide character in write_chunked_body()/);
}
$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 || croak(q/Usage: $handle->read_response_header()/);
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 croak(q/Malformed Status-Line: / . $Printable->($line));
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
croak (qq/Unsupported HTTP protocol: $protocol/)
unless $version =~ /0*1\.0*[01]/;
return {
status => $status,
reason => $reason,
headers => $self->read_header_lines,
protocol => $protocol,
};
}
sub write_request_header {
@_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
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 croak(q/select(2): 'Bad file descriptor'/);
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 croak(qq/select(2): '$!'/);
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
$nfound = 0;
}
last;
}
$! = 0;
return $nfound;
}
sub can_read {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
my $self = shift;
return $self->_do_timeout('read', @_)
}
sub can_write {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
my $self = shift;
return $self->_do_timeout('write', @_)
}
1;
__END__
=pod
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.27200';
@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
JSON_PP
$fatpacked{"JSON/PP/Boolean.pm"} = <<'JSON_PP_BOOLEAN';
use JSON::PP ();
use strict;
1;
JSON_PP_BOOLEAN
$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.000007';
$VERSION = eval $VERSION;
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_REGEXP = qr{ # match a package declaration
^[\s\{;]* # intro chars on a line
package # the word 'package'
\s+ # whitespace
([\w:]+) # 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 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->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 );
if ( $package eq $prime_package ) {
if ( exists( $prime{$package} ) ) {
die "Unexpected conflict in '$package'; multiple versions found.\n";
} else {
$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 || die '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 ) {
( $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 die( "Can't open '$filename': $!" );
$self->_parse_fh($fh);
}
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 = '';
while (defined( my $line = <$fh> )) {
my $line_num = $.;
chomp( $line );
next if $line =~ /^\s*#/;
$in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod;
# Would be nice if we could also check $in_string or something too
last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;
if ( $in_pod || $line =~ /^=cut/ ) {
if ( $line =~ /^=head\d\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";
}
} else {
$pod_sect = '';
$pod_data = '';
# parse $line to see if it's a $VERSION declaration
my( $vers_sig, $vers_fullname, $vers_pkg ) =
$self->_parse_version_expression( $line );
if ( $line =~ $PKG_REGEXP ) {
$pkg = $1;
push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
$vers{$pkg} = (defined $2 ? $2 : undef) 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 );
} else {
# Warn unless the user is using the "$VERSION = eval
# $VERSION" idiom (though there are probably other idioms
# that we should watch out for...)
warn <<"EOM" unless $line =~ /=\s*eval/;
Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
ignoring subsequent declaration on line $line_num.
EOM
}
# 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;
} else {
warn <<"EOM";
Package '$pkg' already declared with version '$vers{$pkg}'
ignoring new version '$v' on line $line_num.
EOM
}
}
}
}
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
die "failed to build version sub for $self->{filename}";
my $result = eval { $vsub->() };
die "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) };
die "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;
}
die $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]->{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;
MODULE_METADATA
$fatpacked{"Parse/CPAN/Meta.pm"} = <<'PARSE_CPAN_META';
package Parse::CPAN::Meta;
use strict;
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::VERSION = '1.4401';
@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;
return CPAN::Meta::YAML::LoadFile(shift)
or die CPAN::Meta::YAML->errstr;
}
# Parse a document from a string.
sub Load ($) {
require CPAN::Meta::YAML;
return CPAN::Meta::YAML::Load(shift)
or die CPAN::Meta::YAML->errstr;
}
1;
__END__
PARSE_CPAN_META
$fatpacked{"Try/Tiny.pm"} = <<'TRY_TINY';
package Try::Tiny;
use strict;
#use warnings;
use vars qw(@EXPORT @EXPORT_OK $VERSION @ISA);
BEGIN {
require Exporter;
@ISA = qw(Exporter);
}
$VERSION = "0.09";
$VERSION = eval $VERSION;
@EXPORT = @EXPORT_OK = qw(try catch finally);
$Carp::Internal{+__PACKAGE__}++;
# Need to prototype as @ not $$ because of the way Perl evaluates the prototype.
# Keeping it at $$ means you only ever get 1 sub because we need to eval in a list
# context & not a scalar one
sub try (&;@) {
my ( $try, @code_refs ) = @_;
# we need to save this here, the eval block will be in scalar context due
# to $failed
my $wantarray = wantarray;
my ( $catch, @finally );
# find labeled blocks in the argument list.
# catch and finally tag the blocks by blessing a scalar reference to them.
foreach my $code_ref (@code_refs) {
next unless $code_ref;
my $ref = ref($code_ref);
if ( $ref eq 'Try::Tiny::Catch' ) {
$catch = ${$code_ref};
} elsif ( $ref eq 'Try::Tiny::Finally' ) {
push @finally, ${$code_ref};
} else {
use Carp;
confess("Unknown code ref type given '${ref}'. Check your usage & try again");
}
}
# save the value of $@ so we can set $@ back to it in the beginning of the eval
my $prev_error = $@;
my ( @ret, $error, $failed );
# FIXME consider using local $SIG{__DIE__} to accumulate all errors. It's
# not perfect, but we could provide a list of additional errors for
# $catch->();
{
# localize $@ to prevent clobbering of previous value by a successful
# eval.
local $@;
# failed will be true if the eval dies, because 1 will not be returned
# from the eval body
$failed = not eval {
$@ = $prev_error;
# evaluate the try block in the correct context
if ( $wantarray ) {
@ret = $try->();
} elsif ( defined $wantarray ) {
$ret[0] = $try->();
} else {
$try->();
};
return 1; # properly set $fail to false
};
# copy $@ to $error; when we leave this scope, local $@ will revert $@
# back to its previous value
$error = $@;
}
# set up a scope guard to invoke the finally block at the end
my @guards =
map { Try::Tiny::ScopeGuard->_new($_, $failed ? $error : ()) }
@finally;
# at this point $failed contains a true value if the eval died, even if some
# destructor overwrote $@ as the eval was unwinding.
if ( $failed ) {
# if we got an error, invoke the catch block.
if ( $catch ) {
# This works like given($error), but is backwards compatible and
# sets $_ in the dynamic scope for the body of C<$catch>
for ($error) {
return $catch->($error);
}
# in case when() was used without an explicit return, the C<for>
# loop will be aborted and there's no useful return value
}
return;
} else {
# no failure, $@ is back to what it was, everything is fine
return $wantarray ? @ret : $ret[0];
}
}
sub catch (&;@) {
my ( $block, @rest ) = @_;
return (
bless(\$block, 'Try::Tiny::Catch'),
@rest,
);
}
sub finally (&;@) {
my ( $block, @rest ) = @_;
return (
bless(\$block, 'Try::Tiny::Finally'),
@rest,
);
}
{
package # hide from PAUSE
Try::Tiny::ScopeGuard;
sub _new {
shift;
bless [ @_ ];
}
sub DESTROY {
my @guts = @{ shift() };
my $code = shift @guts;
$code->(@guts);
}
}
__PACKAGE__
__END__
TRY_TINY
$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
}
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 Carp ();
use Config;
our $VERSION = '1.008001'; # 1.8.1
our @KNOWN_FLAGS = qw(--self-contained);
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";
}
$arg_store{path} = $class->resolve_path($arg_store{path});
$class->setup_local_lib_for($arg_store{path});
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(@_);
};
}
}
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';
}
}
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) {
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);
}
sub setup_local_lib_for {
my ($class, $path) = @_;
$path = $class->ensure_dir_structure_for($path);
if ($0 eq '-') {
$class->print_environment_vars_for($path);
exit 0;
} else {
$class->setup_env_hash_for($path);
@INC = _uniq(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);
# Need to have the path exist to make a short name for it, so
# converting to a short name here.
$path = Win32::GetShortPathName($path) if $^O eq 'MSWin32';
return $path;
}
sub INTERPOLATE_ENV () { 1 }
sub LITERAL_ENV () { 0 }
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) = @_;
print $class->environment_vars_string_for($path);
}
sub environment_vars_string_for {
my ($class, $path) = @_;
my @envs = $class->build_environment_vars_for($path, LITERAL_ENV);
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;
$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 qq{export ${name}="${value}"\n};
}
sub build_csh_env_declaration {
my $class = shift;
my($name, $value) = @_;
return qq{setenv ${name} "${value}"\n};
}
sub build_win32_env_declaration {
my $class = shift;
my($name, $value) = @_;
return qq{set ${name}=${value}\n};
}
sub setup_env_hash_for {
my ($class, $path) = @_;
my %envs = $class->build_environment_vars_for($path, INTERPOLATE_ENV);
@ENV{keys %envs} = values %envs;
}
sub build_environment_vars_for {
my ($class, $path, $interpolate) = @_;
return (
PERL_LOCAL_LIB_ROOT => $path,
PERL_MB_OPT => "--install_base ${path}",
PERL_MM_OPT => "INSTALL_BASE=${path}",
PERL5LIB => join($Config{path_sep},
$class->install_base_arch_path($path),
$class->install_base_perl_path($path),
(($ENV{PERL5LIB}||()) ?
($interpolate == INTERPOLATE_ENV
? ($ENV{PERL5LIB})
: (($^O ne 'MSWin32') ? '$PERL5LIB' : '%PERL5LIB%' ))
: ())
),
PATH => join($Config{path_sep},
$class->install_base_bin_path($path),
($interpolate == INTERPOLATE_ENV
? ($ENV{PATH}||())
: (($^O ne 'MSWin32') ? '$PATH' : '%PATH%' ))
),
)
}
1;
LOCAL_LIB
$fatpacked{"parent.pm"} = <<'PARENT';
package parent;
use strict;
use vars qw($VERSION);
$VERSION = '0.225';
sub import {
my $class = shift;
my $inheritor = caller(0);
if ( @_ and $_[0] eq '-norequire' ) {
shift @_;
} else {
for ( my @filename = @_ ) {
if ( $_ eq $inheritor ) {
warn "Class '$inheritor' tried to inherit from itself\n";
};
s{::|'}{/}g;
require "$_.pm"; # dies if the file is not found
}
}
{
no strict 'refs';
push @{"$inheritor\::ISA"}, @_;
};
};
"All your base are belong to us"
__END__
PARENT
$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.88;
$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;
#--------------------------------------------------------------------------#
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;
if ($] >= 5.009000 && $] < 5.011004) {
no strict 'refs';
*version::stringify = \&version::vpp::stringify;
*{'version::(""'} = \&version::vpp::stringify;
*version::new = \&version::vpp::new;
*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;
if ($] >= 5.009000 && $] < 5.011004) {
no strict 'refs';
*version::stringify = \&version::vxs::stringify;
*{'version::(""'} = \&version::vxs::stringify;
*version::new = \&version::vxs::new;
*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/Requirements.pm"} = <<'VERSION_REQUIREMENTS';
use strict;
use warnings;
package Version::Requirements;
BEGIN {
$Version::Requirements::VERSION = '0.101020';
}
# ABSTRACT: a set of version requirements for a CPAN dist
use Carp ();
use Scalar::Util ();
use version 0.77 (); # the ->parse method
sub new {
my ($class) = @_;
return bless {} => $class;
}
sub _version_object {
my ($self, $version) = @_;
$version = (! defined $version) ? version->parse(0)
: (! Scalar::Util::blessed($version)) ? version->parse($version)
: $version;
return $version;
}
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 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 || 'Version::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 from_string_hash {
my ($class, $hash) = @_;
my $self = $class->new;
for my $module (keys %$hash) {
my @parts = split qr{\s*,\s*}, $hash->{ $module };
for my $part (@parts) {
my ($op, $ver) = split /\s+/, $part, 2;
if (! defined $ver) {
$self->add_minimum($module => $op);
} else {
Carp::confess("illegal requirement string: $hash->{ $module }")
unless my $methods = $methods_for_op{ $op };
$self->$_($module => $ver) for @$methods;
}
}
}
return $self;
}
##############################################################
{
package
Version::Requirements::_Range::Exact;
BEGIN {
$Version::Requirements::_Range::Exact::VERSION = '0.101020';
}
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
Version::Requirements::_Range::Range;
BEGIN {
$Version::Requirements::_Range::Range::VERSION = '0.101020';
}
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 Version::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 Version::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;
__END__
=pod
VERSION_REQUIREMENTS
$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.88;
use overload (
'""' => \&stringify,
'0+' => \&numify,
'cmp' => \&vcmp,
'<=>' => \&vcmp,
'bool' => \&vbool,
'nomethod' => \&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
# 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)");
}
}
# 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++;
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)");
}
$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) = @_;
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 object");
}
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 $version = $class->new($value);
return $version;
}
*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]}) {
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);
$app->doit or exit(1);
}
__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
cpanm --scandeps Moose # See what modules will be installed for Moose
=head1 COMMANDS
=over 4
=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 -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 doesn't print
anything to the STDERR.
=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 when examining the dependencies, it
assumes no non-core modules are installed on the system. It's handy if
you want to bundle application dependencies in one directory so you
can distribute to other machines.
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 --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.
Defaults to C<http://search.cpan.org/CPAN> which is a geo location
aware redirector.
=item --mirror-only
Download the mirror's 02packages.details.txt.gz index file instead of
querying the CPAN Meta DB.
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 --metacpan
B<EXPERIMENTAL>: Use L<http://api.metacpan.org/> API for module lookup instead of
L<http://cpanmetadb.plackperl.org/>.
=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 --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 --scandeps
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
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>
=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 --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>.
=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 for bare module names, but if you specify versions
with C<~>, it will always skip satisfied requirements.
=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 false (no man pages generated) if
C<-L|--local-lib-contained> option is supplied. Otherwise, defaults to
true, and 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