From ef9a90a35338e656e188c94954065d3de838498b Mon Sep 17 00:00:00 2001 From: Magnus Woldrich Date: Wed, 15 Feb 2012 09:08:20 +0100 Subject: [PATCH] cpanm: initial --- cpanm | 11316 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 11316 insertions(+) create mode 100755 cpanm diff --git a/cpanm b/cpanm new file mode 100755 index 00000000..14a9a3cb --- /dev/null +++ b/cpanm @@ -0,0 +1,11316 @@ +#!/usr/bin/env 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.5007"; + + =head1 NAME + + App::cpanminus - get, unpack, build and install modules from CPAN + + =head1 SYNOPSIS + + cpanm Module + + Run C 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 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 to your bin directory like + C (unless you configured C with + L), 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, 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 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 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. 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. + + Fetched files are unpacked in C<~/.cpanm> and automatically cleaned up + periodically. You can configure the location of this with the + C 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 and C). 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 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 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 and L? + + 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, + right? + + If you need these features, use L, L 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 + + =item * + + Uninstalling modules. See L. + + =item * + + Showing the changes of the modules you're about to upgrade. See L + + =item * + + Patching CPAN modules with distroprefs. + + =back + + See L or C to see what cpanminus I do :) + + =head1 COPYRIGHT + + Copyright 2010- Tatsuhiko Miyagawa + + The standalone executable contains the following modules embedded. + + =over 4 + + =item L Copyright 2003 Graham Barr + + =item L Copyright 2006-2009 Adam Kennedy + + =item L Copyright 2007-2009 Matt S Trout + + =item L Copyright 2011 Christian Hansen + + =item L Copyright 2001-2006 Ken Williams. 2010 Matt S Trout + + =item L Copyright 2004-2010 John Peacock + + =item L Copyright 2007−2011 by Makamaka Hannyaharamitu + + =item L Copyright (c) 2010 by David Golden and Ricardo Signes + + =item L Copyright (c) 2009 Yuval Kogman + + =item L Copyright (c) 2007-10 Max Maischein + + =item L copyright (c) 2010 by Ricardo Signes + + =item L 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 - source code repository, issue tracker + + =item L - 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 L L + + =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.5007"; + + my $quote = WIN32 ? q/"/ : q/'/; + + sub new { + my $class = shift; + + bless { + home => "$ENV{HOME}/.cpanm", + cmd => 'install', + seen => {}, + notest => 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}, + '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 ($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) = @_; + + 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!! + and return $self->cpan_module($module, $1); + + $self->diag_fail("Finding $module on search.cpan.org failed."); + } + + 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; + } + + 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 <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(<install_base_perl_path($base), + 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->install_base_arch_path($base), + 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 = ; + 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) = @_; + + 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://search.cpan.org/CPAN' ]; + } + 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 <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 = <{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 ]) && + $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" ]) && + $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) { + 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 $msg = "Building $distname failed"; + $self->diag_fail("Installing $stuff failed. See $self->{log} for details.", 1); + return; + } + } + + sub configure_this { + my($self, $dist) = @_; + + 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, + module => $module, + version => $provides->{$module}{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) = @_; + + 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, " }; + 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(?=-) + )(? 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 || ""); + + 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 '' ); + + 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 '' ) { + $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, for Miss Barbell Productions, + # L + #--------------------------------------------------------------------------# + + #--------------------------------------------------------------------------# + # 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 || ""; + 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 = '' 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 = ''; + } + $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 = ''; + } + $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 = ''; + } + $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 = ''; + } + $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 = ''; + } + $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 = ''; + } + $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 = ''; + } + $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 = ''; + } + $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 = ''; + } + $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 = ; + 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 + 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 + # 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 or L. + +=item --self-upgrade + +Upgrades itself. It's just an alias for: + + cpanm App::cpanminus + +=item --info + +Displays the distribution information in +C 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 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. + +=item -S, --sudo + +Switch to the root user with C 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. + +=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 compatible path to install modules to. You +don't need to set this if you already configure the shell environment +variables using L, 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, 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 (you can omit the trailing slash). You +can specify multiple mirror URLs by repeating the command line option. + +Defaults to C 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 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: Specifies the file path to C<02packages.details.txt> +for module search index. + +=item --metacpan + +B: Use L API for module lookup instead of +L. + +=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. + +=item --reinstall + +cpanm, when given a module name in the command line (i.e. C), 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 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 and C) +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. + +=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, C, C and C. + +=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 and L 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 is a special output format, where it prints the distribution +filename in the I 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 + +=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 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: 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 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: Specifies whether to cascade search when you specify +multiple mirrors and a mirror 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: The C environment variable have to be correctly set for this +to work with modules installed using L. + +=item --skip-satisfied + +B: 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 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 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, Wget, cURL and L +(in that order) and uses the first one available. + +=back + +=head1 SEE ALSO + +L + +=head1 COPYRIGHT + +Copyright 2010 Tatsuhiko Miyagawa. + +=head1 AUTHOR + +Tatsuhiko Miyagawa + +=cut