diff options
| -rwxr-xr-x | bin/cpanm | 11111 |
1 files changed, 398 insertions, 10713 deletions
@@ -4,732 +4,85 @@ # 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 +# % curl -L http://cpanmin.us | perl - App::cpanminus # # If you don't have curl but wget, replace `curl -L` with `wget -O -`. # # For more details about this program, visit http://search.cpan.org/dist/App-cpanminus -# + +our $VERSION = "1.6928"; # DO NOT EDIT -- this is an auto generated file + # This chunk of stuff was generated by App::FatPacker. To find the original # file's code, look for the end of this BEGIN block or the string 'FATPACK' BEGIN { my %fatpacked; $fatpacked{"App/cpanminus.pm"} = <<'APP_CPANMINUS'; - package App::cpanminus; - our $VERSION = "1.5007"; - - =head1 NAME - - App::cpanminus - get, unpack, build and install modules from CPAN - - =head1 SYNOPSIS - - cpanm Module - - Run C<cpanm -h> for more options. - - =head1 DESCRIPTION - - cpanminus is a script to get, unpack, build and install modules from - CPAN and does nothing else. - - It's dependency free (can bootstrap itself), requires zero - configuration, and stands alone. When running, it requires only 10MB - of RAM. - - =head1 INSTALLATION - - There are several ways to install cpanminus to your system. - - =head2 Package management system - - There are Debian packages, RPMs, FreeBSD ports, and packages for other - operation systems available. If you want to use the package management system, - search for cpanminus and use the appropriate command to install. This makes it - easy to install C<cpanm> to your system without thinking about where to - install, and later upgrade. - - =head2 Installing to system perl - - You can also use the latest cpanminus to install cpanminus itself: - - curl -L http://cpanmin.us | perl - --sudo App::cpanminus - - This will install C<cpanm> to your bin directory like - C</usr/local/bin> (unless you configured C<INSTALL_BASE> with - L<local::lib>), so you probably need the C<--sudo> option. - - =head2 Installing to local perl (perlbrew) - - If you have perl in your home directory, which is the case if you use - tools like L<perlbrew>, you don't need the C<--sudo> option, since - you're most likely to have a write permission to the perl's library - path. You can just do: - - curl -L http://cpanmin.us | perl - App::cpanminus - - to install the C<cpanm> executable to the perl's bin path, like - C<~/perl5/perlbrew/bin/cpanm>. - - =head2 Downloading the standalone executable - - You can also copy the standalone executable to whatever location you'd like. - - cd ~/bin - curl -LO http://xrl.us/cpanm - chmod +x cpanm - # edit shebang if you don't have /usr/bin/env - - This just works, but be sure to grab the new version manually when you - upgrade because C<--self-upgrade> might not work for this. - - =head1 DEPENDENCIES - - perl 5.8 or later. - - =over 4 - - =item * - - 'tar' executable (bsdtar or GNU tar version 1.22 are rcommended) or Archive::Tar to unpack files. - - =item * - - C compiler, if you want to build XS modules. - - =item * - - make - - =item * - - Module::Build (core in 5.10) - - =back - - =head1 QUESTIONS - - =head2 Another CPAN installer? - - OK, the first motivation was this: the CPAN shell runs out of memory (or swaps - heavily and gets really slow) on Slicehost/linode's most affordable plan with - only 256MB RAM. Should I pay more to install perl modules from CPAN? I don't - think so. - - =head2 But why a new client? - - First of all, let me be clear that CPAN and CPANPLUS are great tools - I've used for I<literally> years (you know how many modules I have on - CPAN, right?). I really respect their efforts of maintaining the most - important tools in the CPAN toolchain ecosystem. - - However, for less experienced users (mostly from outside the Perl community), - or even really experienced Perl developers who know how to shoot themselves in - their feet, setting up the CPAN toolchain often feels like yak shaving, - especially when all they want to do is just install some modules and start - writing code. - - =head2 Zero-conf? How does this module get/parse/update the CPAN index? - - It queries the CPAN Meta DB site running on Google AppEngine at - L<http://cpanmetadb.plackperl.org/>. The site is updated every hour to reflect - the latest changes from fast syncing mirrors. The script then also falls back - to scrape the site L<http://search.cpan.org/>. - - Fetched files are unpacked in C<~/.cpanm> and automatically cleaned up - periodically. You can configure the location of this with the - C<PERL_CPANM_HOME> environment variable. - - =head2 Where does this install modules to? Do I need root access? - - It installs to wherever ExtUtils::MakeMaker and Module::Build are - configured to (via C<PERL_MM_OPT> and C<PERL_MB_OPT>). So if you're - using local::lib, then it installs to your local perl5 - directory. Otherwise it installs to the site_perl directory that - belongs to your perl. - - cpanminus at a boot time checks whether you have configured - local::lib, or have the permission to install modules to the site_perl - directory. If neither, it automatically sets up local::lib compatible - installation path in a C<perl5> directory under your home - directory. To avoid this, run the script as the root user, with - C<--sudo> option or with C<--local-lib> option. - - =head2 cpanminus can't install the module XYZ. Is it a bug? - - It is more likely a problem with the distribution itself. cpanminus - doesn't support or is known to have issues with distributions like as - follows: - - =over 4 - - =item * - - Tests that require input from STDIN. - - =item * - - Tests that might fail when C<AUTOMATED_TESTING> is enabled. - - =item * - - Modules that have invalid numeric values as VERSION (such as C<1.1a>) - - =back - - These failures can be reported back to the author of the module so - that they can fix it accordingly, rather than me. - - =head2 Does cpanm support the feature XYZ of L<CPAN> and L<CPANPLUS>? - - Most likely not. Here are the things that cpanm doesn't do by - itself. And it's a feature - you got that from the name I<minus>, - right? - - If you need these features, use L<CPAN>, L<CPANPLUS> or the standalone - tools that are mentioned. - - =over 4 - - =item * - - Bundle:: module dependencies - - =item * - - CPAN testers reporting - - =item * - - Building RPM packages from CPAN modules - - =item * - - Listing the outdated modules that needs upgrading. See L<App::cpanoutdated> - - =item * - - Uninstalling modules. See L<pm-uninstall>. - - =item * - - Showing the changes of the modules you're about to upgrade. See L<cpan-listchanges> - - =item * - - Patching CPAN modules with distroprefs. - - =back - - See L<cpanm> or C<cpanm -h> to see what cpanminus I<can> do :) - - =head1 COPYRIGHT - - Copyright 2010- Tatsuhiko Miyagawa - - The standalone executable contains the following modules embedded. - - =over 4 - - =item L<CPAN::DistnameInfo> Copyright 2003 Graham Barr - - =item L<Parse::CPAN::Meta> Copyright 2006-2009 Adam Kennedy - - =item L<local::lib> Copyright 2007-2009 Matt S Trout - - =item L<HTTP::Tiny> Copyright 2011 Christian Hansen - - =item L<Module::Metadata> Copyright 2001-2006 Ken Williams. 2010 Matt S Trout - - =item L<version> Copyright 2004-2010 John Peacock - - =item L<JSON::PP> Copyright 2007−2011 by Makamaka Hannyaharamitu - - =item L<CPAN::Meta> Copyright (c) 2010 by David Golden and Ricardo Signes - - =item L<Try::Tiny> Copyright (c) 2009 Yuval Kogman - - =item L<parent> Copyright (c) 2007-10 Max Maischein - - =item L<Version::Requirements> copyright (c) 2010 by Ricardo Signes - - =item L<CPAN::Meta::YAML> copyright (c) 2010 by Adam Kennedy - - =back - - =head1 LICENSE - - Same as Perl. - - =head1 CREDITS - - =head2 CONTRIBUTORS - - Patches and code improvements were contributed by: - - Goro Fuji, Kazuhiro Osawa, Tokuhiro Matsuno, Kenichi Ishigaki, Ian - Wells, Pedro Melo, Masayoshi Sekimura, Matt S Trout (mst), squeeky, - horus and Ingy dot Net. - - =head2 ACKNOWLEDGEMENTS - - Bug reports, suggestions and feedbacks were sent by, or general - acknowledgement goes to: - - Jesse Vincent, David Golden, Andreas Koenig, Jos Boumans, Chris - Williams, Adam Kennedy, Audrey Tang, J. Shirley, Chris Prather, Jesse - Luehrs, Marcus Ramberg, Shawn M Moore, chocolateboy, Chirs Nehren, - Jonathan Rockway, Leon Brocard, Simon Elliott, Ricardo Signes, AEvar - Arnfjord Bjarmason, Eric Wilhelm, Florian Ragwitz and xaicron. - - =head1 COMMUNITY - - =over 4 - - =item L<http://github.com/miyagawa/cpanminus> - source code repository, issue tracker - - =item L<irc://irc.perl.org/#toolchain> - discussions about Perl toolchain. I'm there. - - =back - - =head1 NO WARRANTY - - This software is provided "as-is," without any express or implied - warranty. In no event shall the author be held liable for any damages - arising from the use of the software. - - =head1 SEE ALSO - - L<CPAN> L<CPANPLUS> L<pip> - - =cut - - 1; + package App::cpanminus;our$VERSION="1.7001";1; APP_CPANMINUS +$fatpacked{"App/cpanminus/CPANVersion.pm"} = <<'APP_CPANMINUS_CPANVERSION'; + package App::cpanminus::CPANVersion;use strict;sub vcmp {my($self,$l,$r)=@_;local($^W)=0;return 0 if$l eq $r;for ($l,$r){s/_//g}for ($l,$r){next unless tr/.// > 1 || /^v/;s/^v?/v/;1 while s/\.0+(\d)/.$1/}if ($l=~/^v/ <=> $r=~/^v/){for ($l,$r){next if /^v/;$_=$self->float2vv($_)}}my$lvstring="v0";my$rvstring="v0";if ($] >= 5.006 && $l =~ /^v/ && $r =~ /^v/){$lvstring=$self->vstring($l);$rvstring=$self->vstring($r)}return (($l ne "undef")<=> ($r ne "undef")|| $lvstring cmp $rvstring || $l <=> $r || $l cmp $r)}sub vgt {my($self,$l,$r)=@_;$self->vcmp($l,$r)> 0}sub vlt {my($self,$l,$r)=@_;$self->vcmp($l,$r)< 0}sub vge {my($self,$l,$r)=@_;$self->vcmp($l,$r)>= 0}sub vle {my($self,$l,$r)=@_;$self->vcmp($l,$r)<= 0}sub vstring {my($self,$n)=@_;$n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";pack "U*",split /\./,$n}sub float2vv {my($self,$n)=@_;my($rev)=int($n);$rev ||=0;my($mantissa)=$n =~ /\.(\d{1,12})/;$mantissa ||=0;$mantissa .= "0" while length($mantissa)%3;my$ret="v" .$rev;while ($mantissa){$mantissa =~ s/(\d{1,3})// or die "Panic: length>0 but not a digit? mantissa[$mantissa]";$ret .= ".".int($1)}$ret =~ s/(\.0)+/.0/;$ret}sub readable {my($self,$n)=@_;$n =~ /^([\w\-\+\.]+)/;return $1 if defined $1 && length($1)>0;if ($] < 5.006){warn("Suspicious version string seen [$n]\n");return$n}my$better=sprintf "v%vd",$n;return$better}1; +APP_CPANMINUS_CPANVERSION + +$fatpacked{"App/cpanminus/Dependency.pm"} = <<'APP_CPANMINUS_DEPENDENCY'; + package App::cpanminus::Dependency;use strict;use CPAN::Meta::Requirements;sub from_prereqs {my($class,$prereq,$phases,$types)=@_;my@deps;for my$type (@$types){my$req=CPAN::Meta::Requirements->new;$req->add_requirements($prereq->requirements_for($_,$type))for @$phases;push@deps,$class->from_versions($req->as_string_hash,$type)}return@deps}sub from_versions {my($class,$versions,$type)=@_;my@deps;while (my($module,$version)=each %$versions){push@deps,$class->new($module,$version,$type)}@deps}sub new {my($class,$module,$version,$type)=@_;bless {module=>$module,version=>$version,type=>$type || 'requires',},$class}sub module {$_[0]->{module}}sub version {$_[0]->{version}}sub type {$_[0]->{type}}sub is_requirement {$_[0]->{type}eq 'requires'}1; +APP_CPANMINUS_DEPENDENCY + +$fatpacked{"App/cpanminus/ParsePM.pm"} = <<'APP_CPANMINUS_PARSEPM'; + package App::cpanminus::ParsePM;use strict;use warnings;use Safe;use JSON::PP;use Dumpvalue;use version ();use File::Spec ();use File::Temp ();use POSIX ':sys_wait_h';use App::cpanminus::CPANVersion;our$VERSION='0.04';our$VERBOSE=0;our$ALLOW_DEV_VERSION=0;sub new {my ($class,$meta)=@_;bless {META_CONTENT=>$meta},$class}sub parse {my ($self,$pmfile)=@_;$pmfile =~ s|\\|/|g;my($filemtime)=(stat$pmfile)[9];$self->{MTIME}=$filemtime;$self->{PMFILE}=$pmfile;unless ($self->_version_from_meta_ok){$self->{VERSION}=$self->_parse_version;if ($self->{VERSION}=~ /^\{.*\}$/){}elsif ($self->{VERSION}=~ /[_\s]/ &&!$ALLOW_DEV_VERSION){return}}my($ppp)=$self->_packages_per_pmfile;my@keys_ppp=$self->_filter_ppps(sort keys %$ppp);$self->_verbose(1,"Will check keys_ppp[@keys_ppp]\n");my ($package);DBPACK: foreach$package (@keys_ppp){if ($package !~ /^\w[\w\:\']*\w?\z/ || $package !~ /\w\z/ || $package =~ /:/ && $package !~ /::/ || $package =~ /\w:\w/ || $package =~ /:::/){$self->_verbose(1,"Package[$package] did not pass the ultimate sanity check");delete$ppp->{$package};next}my$pp=$ppp->{$package};if ($pp->{version}&& $pp->{version}=~ /^\{.*\}$/){my$err=JSON::PP::decode_json($pp->{version});if ($err->{openerr}){$self->_verbose(1,qq{Parse::PMFile was not able to + read the file. It issued the following error: C< $err->{r} >},)}else {$self->_verbose(1,qq{Parse::PMFile was not able to + parse the following line in that file: C< $err->{line} > + + Note: the indexer is running in a Safe compartement and cannot + provide the full functionality of perl in the VERSION line. It + is trying hard, but sometime it fails. As a workaround, please + consider writing a META.yml that contains a 'provides' + attribute or contact the CPAN admins to investigate (yet + another) workaround against "Safe" limitations.)},)}delete$ppp->{$package};next}for ($package,$pp->{version},){if (!defined || /^\s*$/ || /\s/){delete$ppp->{$package};next}}}return$ppp}sub _parse_version {my$self=shift;use strict;my$pmfile=$self->{PMFILE};my$tmpfile=File::Spec->catfile(File::Spec->tmpdir,"ParsePMFile$$" .rand(1000));my$pmcp=$pmfile;for ($pmcp){s/([^\\](\\\\)*)@/$1\\@/g}my($v);{package main;my$pid=fork();die "Can't fork: $!" unless defined$pid;if ($pid){waitpid($pid,0);if (open my$fh,'<',$tmpfile){$v=<$fh>}}else {my($comp)=Safe->new("_pause::mldistwatch");my$eval=qq{ + local(\$^W) = 0; + App::cpanminus::ParsePM::_parse_version_safely("$pmcp"); + };$comp->permit("entereval");$comp->share("*App::cpanminus::ParsePM::_parse_version_safely");$comp->share("*version::new");$comp->share("*version::numify");$comp->share_from('main',['*version::','*Exporter::','*DynaLoader::']);$comp->share_from('version',['&qv']);$comp->deny(qw/enteriter iter unstack goto/);{no strict;$v=$comp->reval($eval)}if ($@){my$err=$@;if (ref$err){if ($err->{line}=~ /[\$*]([\w\:\']*)\bVERSION\b.*?\=(.*)/){local*qv=\&version::qv;$v=eval "$2"}if ($@){$self->_verbose(1,sprintf("reval failed: err[%s] for eval[%s]",JSON::PP::encode_json($err),$eval,));$v=JSON::PP::encode_json($err)}}else {$v=JSON::PP::encode_json({openerr=>$err })}}if (defined$v){$v=$v->numify if ref($v)eq 'version'}else {$v=""}open my$fh,'>:utf8',$tmpfile;print$fh $v;exit 0}}unlink$tmpfile if -e $tmpfile;return$self->_normalize_version($v)}sub _packages_per_pmfile {my$self=shift;my$ppp={};my$pmfile=$self->{PMFILE};my$filemtime=$self->{MTIME};my$version=$self->{VERSION};$DB::single++;open my$fh,"<","$pmfile" or return$ppp;local $/="\n";my$inpod=0;PLINE: while (<$fh>){chomp;my($pline)=$_;$inpod=$pline =~ /^=(?!cut)/ ? 1 : $pline =~ /^=cut/ ? 0 : $inpod;next if$inpod;next if substr($pline,0,4)eq "=cut";$pline =~ s/\#.*//;next if$pline =~ /^\s*$/;if ($pline =~ /\b__(?:END|DATA)__\b/ and $pmfile !~ /\.PL$/){last PLINE}my$pkg;my$strict_version;if ($pline =~ m{ + # (.*) # takes too much time if $pline is long + \bpackage\s+ + ([\w\:\']+) + \s* + (?: $ | [\}\;] | \s+($version::STRICT) ) + }x){$pkg=$1;$strict_version=$2;if ($pkg eq "DB"){next PLINE}}if ($pkg){$pkg =~ s/\'/::/;next PLINE unless$pkg =~ /^[A-Za-z]/;next PLINE unless$pkg =~ /\w$/;next PLINE if$pkg eq "main";next PLINE if length($pkg)> 128;$ppp->{$pkg}{parsed}++;$ppp->{$pkg}{infile}=$pmfile;if ($self->_simile($pmfile,$pkg)){$ppp->{$pkg}{simile}=$pmfile;if ($self->_version_from_meta_ok){my$provides=$self->{META_CONTENT}{provides};if (exists$provides->{$pkg}){if (exists$provides->{$pkg}{version}){my$v=$provides->{$pkg}{version};if ($v =~ /[_\s]/ &&!$ALLOW_DEV_VERSION){next PLINE}else {$ppp->{$pkg}{version}=$self->_normalize_version($v)}}else {$ppp->{$pkg}{version}="undef"}}}else {if (defined$strict_version){$ppp->{$pkg}{version}=$strict_version }else {$ppp->{$pkg}{version}=defined$version ? $version : ""}no warnings;if ($version eq 'undef'){$ppp->{$pkg}{version}=$version unless defined$ppp->{$pkg}{version}}else {$ppp->{$pkg}{version}=$version if$version > $ppp->{$pkg}{version}|| $version gt $ppp->{$pkg}{version}}}}else {$ppp->{$pkg}{version}=$version unless defined$ppp->{$pkg}{version}&& length($ppp->{$pkg}{version})}$ppp->{$pkg}{filemtime}=$filemtime}else {}}$fh->close;$ppp}{no strict;sub _parse_version_safely {my($parsefile)=@_;my$result;local*FH;local $/="\n";open(FH,$parsefile)or die "Could not open '$parsefile': $!";my$inpod=0;while (<FH>){$inpod=/^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;next if$inpod || /^\s*#/;chop;next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;my$current_parsed_line=$_;my$eval=qq{ + package # + ExtUtils::MakeMaker::_version; + + local $1$2; + \$$2=undef; do { + $_ + }; \$$2 + };local $^W=0;local$SIG{__WARN__}=sub {};$result=eval($eval);if ($@ or!defined$result){die +{eval=>$eval,line=>$current_parsed_line,file=>$parsefile,err=>$@,}}last}close FH;$result="undef" unless defined$result;return$result}}sub _filter_ppps {my($self,@ppps)=@_;my@res;MANI: for my$ppp (@ppps){if ($self->{META_CONTENT}){my$no_index=$self->{META_CONTENT}{no_index}|| $self->{META_CONTENT}{private};if (ref($no_index)eq 'HASH'){my%map=(package=>qr{\z},namespace=>qr{::},);for my$k (qw(package namespace)){next unless my$v=$no_index->{$k};my$rest=$map{$k};if (ref$v eq "ARRAY"){for my$ve (@$v){$ve =~ s|::$||;if ($ppp =~ /^$ve$rest/){$self->_verbose(1,"Skipping ppp[$ppp] due to ve[$ve]");next MANI}else {$self->_verbose(1,"NOT skipping ppp[$ppp] due to ve[$ve]")}}}else {$v =~ s|::$||;if ($ppp =~ /^$v$rest/){$self->_verbose(1,"Skipping ppp[$ppp] due to v[$v]");next MANI}else {$self->_verbose(1,"NOT skipping ppp[$ppp] due to v[$v]")}}}}else {$self->_verbose(1,"No keyword 'no_index' or 'private' in META_CONTENT")}}else {}push@res,$ppp}$self->_verbose(1,"Result of filter_ppps: res[@res]");@res}sub _simile {my($self,$file,$package)=@_;$file =~ s|.*/||;$file =~ s|\.pm(?:\.PL)?||;my$ret=$package =~ m/\b\Q$file\E$/;$ret ||=0;unless ($ret){$ret=1 if lc$file eq 'version'}$self->_verbose(1,"Result of simile(): file[$file] package[$package] ret[$ret]\n");$ret}sub _normalize_version {my($self,$v)=@_;$v="undef" unless defined$v;my$dv=Dumpvalue->new;my$sdv=$dv->stringify($v,1);$self->_verbose(1,"Result of normalize_version: sdv[$sdv]\n");return$v if$v eq "undef";return$v if$v =~ /^\{.*\}$/;$v =~ s/^\s+//;$v =~ s/\s+\z//;if ($v =~ /_/){return$v }my$vv=eval {no warnings;version->new($v)->numify};if ($@){return "undef"}if ($vv eq $v){}else {my$forced=$self->_force_numeric($v);if ($forced eq $vv){}elsif ($forced =~ /^v(.+)/){$vv=version->new($1)->numify}else {if ($forced==$vv){$vv=$forced}}}return$vv}sub _force_numeric {my($self,$v)=@_;$v=App::cpanminus::CPANVersion->readable($v);if ($v =~ /^(\+?)(\d*)(\.(\d*))?/ && (defined $2 && length $2 || defined $4 && length $4)){my$two=defined $2 ? $2 : "";my$three=defined $3 ? $3 : "";$v="$two$three"}$v}sub _version_from_meta_ok {my($self)=@_;return$self->{VERSION_FROM_META_OK}if exists$self->{VERSION_FROM_META_OK};my$c=$self->{META_CONTENT};return($self->{VERSION_FROM_META_OK}=0)unless$c->{provides};my ($mb_v)=(defined$c->{generated_by}? $c->{generated_by}: '')=~ /Module::Build version ([\d\.]+)/;return($self->{VERSION_FROM_META_OK}=1)unless$mb_v;return($self->{VERSION_FROM_META_OK}=1)if$mb_v eq '0.250.0';if ($mb_v >= 0.19 && $mb_v < 0.26 &&!keys %{$c->{provides}}){return($self->{VERSION_FROM_META_OK}=0)}return($self->{VERSION_FROM_META_OK}=1)}sub _verbose {my($self,$level,@what)=@_;warn@what if$level <= $VERBOSE}1; +APP_CPANMINUS_PARSEPM + $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; + package App::cpanminus::script;use strict;use Config;use Cwd ();use App::cpanminus;use File::Basename ();use File::Find ();use File::Path ();use File::Spec ();use File::Copy ();use File::Temp ();use Getopt::Long ();use Parse::CPAN::Meta;use Symbol ();use String::ShellQuote ();use version ();use aliased 'App::cpanminus::Dependency';use constant WIN32=>$^O eq 'MSWin32';use constant SUNOS=>$^O eq 'solaris';use constant CAN_SYMLINK=>eval {symlink("","");1};our$VERSION=$App::cpanminus::VERSION;if ($INC{"App/FatPacker/Trace.pm"}){require JSON::PP;require CPAN::Meta::YAML;require CPAN::Meta::Prereqs;require version::vpp;require File::pushd}my$quote=WIN32 ? q/"/ : q/'/;sub agent {my$self=shift;my$agent="cpanminus/$VERSION";$agent .= " perl/$]" if$self->{report_perl_version};$agent}sub determine_home {my$class=shift;my$homedir=$ENV{HOME}|| eval {require File::HomeDir;File::HomeDir->my_home}|| join('',@ENV{qw(HOMEDRIVE HOMEPATH)});if (WIN32){require Win32;$homedir=Win32::GetShortPathName($homedir)}return "$homedir/.cpanm"}sub new {my$class=shift;bless {home=>$class->determine_home,cmd=>'install',seen=>{},notest=>undef,test_only=>undef,installdeps=>undef,force=>undef,sudo=>undef,make=>undef,verbose=>undef,quiet=>undef,interactive=>undef,log=>undef,mirrors=>[],mirror_only=>undef,mirror_index=>undef,cpanmetadb=>"http://cpanmetadb.plackperl.org/v1.0/",perl=>$^X,argv=>[],local_lib=>undef,self_contained=>undef,prompt_timeout=>0,prompt=>undef,configure_timeout=>60,build_timeout=>3600,test_timeout=>1800,try_lwp=>1,try_wget=>1,try_curl=>1,uninstall_shadows=>($] < 5.012),skip_installed=>1,skip_satisfied=>0,auto_cleanup=>7,pod2man=>1,installed_dists=>0,install_types=>['requires'],with_develop=>0,showdeps=>0,scandeps=>0,scandeps_tree=>[],format=>'tree',save_dists=>undef,skip_configure=>0,verify=>0,report_perl_version=>1,build_args=>{},features=>{},pure_perl=>0,cpanfile_path=>'cpanfile',@_,},$class}sub env {my($self,$key)=@_;$ENV{"PERL_CPANM_" .$key}}sub install_type_handlers {my$self=shift;my@handlers;for my$type (qw(recommends suggests)){push@handlers,"with-$type"=>sub {my%uniq;$self->{install_types}=[grep!$uniq{$_}++,@{$self->{install_types}},$type ]};push@handlers,"without-$type"=>sub {$self->{install_types}=[grep $_ ne $type,@{$self->{install_types}}]}}@handlers}sub build_args_handlers {my$self=shift;my@handlers;for my$phase (qw(configure build test install)){push@handlers,"$phase-args=s"=>\($self->{build_args}{$phase})}@handlers}sub parse_options {my$self=shift;local@ARGV=@{$self->{argv}};push@ARGV,grep length,split /\s+/,$self->env('OPT');push@ARGV,@_;Getopt::Long::Configure("bundling");Getopt::Long::GetOptions('f|force'=>sub {$self->{skip_installed}=0;$self->{force}=1},'n|notest!'=>\$self->{notest},'test-only'=>sub {$self->{notest}=0;$self->{skip_installed}=0;$self->{test_only}=1},'S|sudo!'=>\$self->{sudo},'v|verbose'=>\$self->{verbose},'verify!'=>\$self->{verify},'q|quiet!'=>\$self->{quiet},'h|help'=>sub {$self->{action}='show_help'},'V|version'=>sub {$self->{action}='show_version'},'perl=s'=>\$self->{perl},'l|local-lib=s'=>sub {$self->{local_lib}=$self->maybe_abs($_[1])},'L|local-lib-contained=s'=>sub {$self->{local_lib}=$self->maybe_abs($_[1]);$self->{self_contained}=1;$self->{pod2man}=undef},'self-contained!'=>\$self->{self_contained},'mirror=s@'=>$self->{mirrors},'mirror-only!'=>\$self->{mirror_only},'mirror-index=s'=>\$self->{mirror_index},'cpanmetadb=s'=>\$self->{cpanmetadb},'cascade-search!'=>\$self->{cascade_search},'prompt!'=>\$self->{prompt},'installdeps'=>\$self->{installdeps},'skip-installed!'=>\$self->{skip_installed},'skip-satisfied!'=>\$self->{skip_satisfied},'reinstall'=>sub {$self->{skip_installed}=0},'interactive!'=>\$self->{interactive},'i|install'=>sub {$self->{cmd}='install'},'info'=>sub {$self->{cmd}='info'},'look'=>sub {$self->{cmd}='look';$self->{skip_installed}=0},'U|uninstall'=>sub {$self->{cmd}='uninstall'},'self-upgrade'=>sub {$self->{action}='self_upgrade'},'uninst-shadows!'=>\$self->{uninstall_shadows},'lwp!'=>\$self->{try_lwp},'wget!'=>\$self->{try_wget},'curl!'=>\$self->{try_curl},'auto-cleanup=s'=>\$self->{auto_cleanup},'man-pages!'=>\$self->{pod2man},'scandeps'=>\$self->{scandeps},'showdeps'=>sub {$self->{showdeps}=1;$self->{skip_installed}=0},'format=s'=>\$self->{format},'save-dists=s'=>sub {$self->{save_dists}=$self->maybe_abs($_[1])},'skip-configure!'=>\$self->{skip_configure},'dev!'=>\$self->{dev_release},'metacpan!'=>\$self->{metacpan},'report-perl-version!'=>\$self->{report_perl_version},'configure-timeout=i'=>\$self->{configure_timeout},'build-timeout=i'=>\$self->{build_timeout},'test-timeout=i'=>\$self->{test_timeout},'with-develop'=>\$self->{with_develop},'without-develop'=>sub {$self->{with_develop}=0},'with-feature=s'=>sub {$self->{features}{$_[1]}=1},'without-feature=s'=>sub {$self->{features}{$_[1]}=0},'with-all-features'=>sub {$self->{features}{__all}=1},'pp|pureperl!'=>\$self->{pure_perl},"cpanfile=s"=>\$self->{cpanfile_path},$self->install_type_handlers,$self->build_args_handlers,);if (!@ARGV && $0 ne '-' &&!-t STDIN){push@ARGV,$self->load_argv_from_fh(\*STDIN);$self->{load_from_stdin}=1}$self->{argv}=\@ARGV}sub check_upgrade {my$self=shift;my$install_base=$ENV{PERL_LOCAL_LIB_ROOT}? $self->local_lib_target($ENV{PERL_LOCAL_LIB_ROOT}): $Config{installsitebin};if ($0 eq '-'){return}elsif ($0 !~ /^$install_base/){if ($0 =~ m!perlbrew/bin!){die <<DIE}else {die <<DIE}}}sub check_libs {my$self=shift;return if$self->{_checked}++;$self->bootstrap_local_lib;if (@{$self->{bootstrap_deps}|| []}){local$self->{notest}=1;local$self->{scandeps}=0;$self->install_deps(Cwd::cwd,0,@{$self->{bootstrap_deps}})}}sub setup_verify {my$self=shift;my$has_modules=eval {require Module::Signature;require Digest::SHA;1};$self->{cpansign}=$self->which('cpansign');unless ($has_modules && $self->{cpansign}){warn "WARNING: Module::Signature and Digest::SHA is required for distribution verifications.\n";$self->{verify}=0}}sub parse_module_args {my($self,$module)=@_;$module =~ s/^([A-Za-z0-9_:]+)@([v\d\._]+)$/$1~== $2/;if ($module =~ /\~[v\d\._,\!<>= ]+$/){return split /\~/,$module,2}else {return$module,undef}}sub _exit {my($self,$code)=@_;die App::cpanminus::CommandExit->new($code)}sub doit {my$self=shift;my$code;eval {$code=($self->_doit==0)};if (my$e=$@){if (ref$e eq 'App::cpanminus::CommandExit'){$code=$e->code}else {warn$e;$code=1}}return$code}sub _doit {my$self=shift;$self->setup_home;$self->init_tools;$self->setup_verify if$self->{verify};if (my$action=$self->{action}){$self->$action()and return 1}$self->show_help(1)unless @{$self->{argv}}or $self->{load_from_stdin};$self->configure_mirrors;my$cwd=Cwd::cwd;my@fail;for my$module (@{$self->{argv}}){if ($module =~ s/\.pm$//i){my ($volume,$dirs,$file)=File::Spec->splitpath($module);$module=join '::',grep {$_}File::Spec->splitdir($dirs),$file}($module,my$version)=$self->parse_module_args($module);$self->chdir($cwd);if ($self->{cmd}eq 'uninstall'){$self->uninstall_module($module)or push@fail,$module}else {$self->install_module($module,0,$version)or push@fail,$module}}if ($self->{base}&& $self->{auto_cleanup}){$self->cleanup_workdirs}if ($self->{installed_dists}){my$dists=$self->{installed_dists}> 1 ? "distributions" : "distribution";$self->diag("$self->{installed_dists} $dists installed\n",1)}if ($self->{scandeps}){$self->dump_scandeps()}$self->chdir($cwd);return!@fail}sub setup_home {my$self=shift;$self->{home}=$self->env('HOME')if$self->env('HOME');unless (_writable($self->{home})){die "Can't write to cpanm home '$self->{home}': You should fix it with chown/chmod first.\n"}$self->{base}="$self->{home}/work/" .time .".$$";File::Path::mkpath([$self->{base}],0,0777);$self->{log}=File::Spec->catfile($self->{base},"build.log");my$final_log="$self->{home}/build.log";{open my$out,">$self->{log}" or die "$self->{log}: $!"}if (CAN_SYMLINK){my$build_link="$self->{home}/latest-build";unlink$build_link;symlink$self->{base},$build_link;unlink$final_log;symlink$self->{log},$final_log}else {my$log=$self->{log};my$home=$self->{home};$self->{at_exit}=sub {my$self=shift;my$temp_log="$home/build.log." .time .".$$";File::Copy::copy($log,$temp_log)&& unlink($final_log)&& rename($temp_log,$final_log)}}$self->chat("cpanm (App::cpanminus) $VERSION on perl $] built for $Config{archname}\n" ."Work directory is $self->{base}\n")}sub package_index_for {my ($self,$mirror)=@_;return$self->source_for($mirror)."/02packages.details.txt"}sub generate_mirror_index {my ($self,$mirror)=@_;my$file=$self->package_index_for($mirror);my$gz_file=$file .'.gz';my$index_mtime=(stat$gz_file)[9];unless (-e $file && (stat$file)[9]>= $index_mtime){$self->chat("Uncompressing index file...\n");if (eval {require Compress::Zlib}){my$gz=Compress::Zlib::gzopen($gz_file,"rb")or do {$self->diag_fail("$Compress::Zlib::gzerrno opening compressed index");return};open my$fh,'>',$file or do {$self->diag_fail("$! opening uncompressed index for write");return};my$buffer;while (my$status=$gz->gzread($buffer)){if ($status < 0){$self->diag_fail($gz->gzerror ." reading compressed index");return}print$fh $buffer}}else {if (system("gunzip -c $gz_file > $file")){$self->diag_fail("Cannot uncompress -- please install gunzip or Compress::Zlib");return}}utime$index_mtime,$index_mtime,$file}return 1}sub search_mirror_index {my ($self,$mirror,$module,$version)=@_;$self->search_mirror_index_file($self->package_index_for($mirror),$module,$version)}sub search_mirror_index_file {my($self,$file,$module,$version)=@_;open my$fh,'<',$file or return;my$found;while (<$fh>){if (m!^\Q$module\E\s+([\w\.]+)\s+(\S*)!m){$found=$self->cpan_module($module,$2,$1);last}}return$found unless$self->{cascade_search};if ($found){if ($self->satisfy_version($module,$found->{module_version},$version)){return$found}else {$self->chat("Found $module $found->{module_version} which doesn't satisfy $version.\n")}}return}sub with_version_range {my($self,$version)=@_;defined($version)&& $version =~ /[<>=]/}sub encode_json {my($self,$data)=@_;require JSON::PP;my$json=JSON::PP::encode_json($data);$json =~ s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;$json}sub version_to_query {my($self,$module,$version)=@_;require CPAN::Meta::Requirements;my$requirements=CPAN::Meta::Requirements->new;$requirements->add_string_requirement($module,$version || '0');my$req=$requirements->requirements_for_module($module);if ($req =~ s/^==\s*//){return {term=>{'module.version'=>$req },}}elsif ($req !~ /\s/){return {range=>{'module.version_numified'=>{'gte'=>$self->numify_ver($req)}},}}else {my%ops=qw(< lt <= lte > gt >= gte);my(%range,@exclusion);my@requirements=split /,\s*/,$req;for my$r (@requirements){if ($r =~ s/^([<>]=?)\s*//){$range{$ops{$1}}=$self->numify_ver($r)}elsif ($r =~ s/\!=\s*//){push@exclusion,$self->numify_ver($r)}}my@filters=({range=>{'module.version_numified'=>\%range }},);if (@exclusion){push@filters,{not=>{or=>[map {+{term=>{'module.version_numified'=>$self->numify_ver($_)}}}@exclusion ]},}}return@filters}}sub numify_ver {my($self,$ver)=@_;version->new($ver)->numify}sub maturity_filter {my($self,$module,$version)=@_;my@filters;if (!$self->with_version_range($version)or $self->{dev_release}){push@filters,{not=>{term=>{status=>'backpan' }}}}unless ($self->{dev_release}or $version =~ /==/){push@filters,{term=>{maturity=>'released' }}}return@filters}sub by_version {my%s=qw(latest 3 cpan 2 backpan 1);$b->{_score}<=> $a->{_score}|| $s{$b->{fields}{status}}<=> $s{$a->{fields}{status}}}sub by_first_come {$a->{fields}{date}cmp $b->{fields}{date}}sub by_date {$b->{fields}{date}cmp $a->{fields}{date}}sub find_best_match {my($self,$match,$version)=@_;return unless$match && @{$match->{hits}{hits}|| []};my@hits=$self->{dev_release}? sort {by_version || by_date}@{$match->{hits}{hits}}: sort {by_version || by_first_come}@{$match->{hits}{hits}};$hits[0]->{fields}}sub search_metacpan {my($self,$module,$version)=@_;require JSON::PP;$self->chat("Searching $module ($version) on metacpan ...\n");my$metacpan_uri='http://api.metacpan.org/v0';my@filter=$self->maturity_filter($module,$version);my$query={filtered=>{(@filter ? (filter=>{and=>\@filter }): ()),query=>{nested=>{score_mode=>'max',path=>'module',query=>{custom_score=>{metacpan_script=>"score_version_numified",query=>{constant_score=>{filter=>{and=>[{term=>{'module.authorized'=>JSON::PP::true()}},{term=>{'module.indexed'=>JSON::PP::true()}},{term=>{'module.name'=>$module }},$self->version_to_query($module,$version),]}}},}},}},}};my$module_uri="$metacpan_uri/file/_search?source=";$module_uri .= $self->encode_json({query=>$query,fields=>['date','release','module','status' ],});my($release,$module_version);my$module_json=$self->get($module_uri);my$module_meta=eval {JSON::PP::decode_json($module_json)};my$match=$self->find_best_match($module_meta);if ($match){$release=$match->{release};my$module_matched=(grep {$_->{name}eq $module}@{$match->{module}})[0];$module_version=$module_matched->{version}}unless ($release){$self->chat("! Could not find a release matching $module ($version) on MetaCPAN.\n");return}my$dist_uri="$metacpan_uri/release/_search?source=";$dist_uri .= $self->encode_json({filter=>{term=>{'release.name'=>$release },},fields=>['download_url','stat','status' ],});my$dist_json=$self->get($dist_uri);my$dist_meta=eval {JSON::PP::decode_json($dist_json)};if ($dist_meta){$dist_meta=$dist_meta->{hits}{hits}[0]{fields}}if ($dist_meta && $dist_meta->{download_url}){(my$distfile=$dist_meta->{download_url})=~ s!.+/authors/id/!!;local$self->{mirrors}=$self->{mirrors};if ($dist_meta->{status}eq 'backpan'){$self->{mirrors}=['http://backpan.perl.org' ]}elsif ($dist_meta->{stat}{mtime}> time()-24*60*60){$self->{mirrors}=['http://cpan.metacpan.org' ]}return$self->cpan_module($module,$distfile,$module_version)}$self->diag_fail("Finding $module on metacpan failed.");return}sub search_database {my($self,$module,$version)=@_;my$found;my$range=($self->with_version_range($version)|| $self->{dev_release});if ($range or $self->{metacpan}){$found=$self->search_metacpan($module,$version)and return$found;$found=$self->search_cpanmetadb($module,$version)and return$found}else {$found=$self->search_cpanmetadb($module,$version)and return$found;$found=$self->search_metacpan($module,$version)and return$found}}sub search_cpanmetadb {my($self,$module,$version)=@_;$self->chat("Searching $module on cpanmetadb ...\n");(my$uri=$self->{cpanmetadb})=~ s{/?$}{/package/$module};my$yaml=$self->get($uri);my$meta=$self->parse_meta_string($yaml);if ($meta && $meta->{distfile}){return$self->cpan_module($module,$meta->{distfile},$meta->{version})}$self->diag_fail("Finding $module on cpanmetadb failed.");return}sub search_module {my($self,$module,$version)=@_;if ($self->{mirror_index}){$self->mask_output(chat=>"Searching $module on mirror index $self->{mirror_index} ...\n");my$pkg=$self->search_mirror_index_file($self->{mirror_index},$module,$version);return$pkg if$pkg;unless ($self->{cascade_search}){$self->mask_output(diag_fail=>"Finding $module ($version) on mirror index $self->{mirror_index} failed.");return}}unless ($self->{mirror_only}){my$found=$self->search_database($module,$version);return$found if$found}MIRROR: for my$mirror (@{$self->{mirrors}}){$self->mask_output(chat=>"Searching $module on mirror $mirror ...\n");my$name='02packages.details.txt.gz';my$uri="$mirror/modules/$name";my$gz_file=$self->package_index_for($mirror).'.gz';unless ($self->{pkgs}{$uri}){$self->mask_output(chat=>"Downloading index file $uri ...\n");$self->mirror($uri,$gz_file);$self->generate_mirror_index($mirror)or next MIRROR;$self->{pkgs}{$uri}="!!retrieved!!"}my$pkg=$self->search_mirror_index($mirror,$module,$version);return$pkg if$pkg;$self->mask_output(diag_fail=>"Finding $module ($version) on mirror $mirror failed.")}return}sub source_for {my($self,$mirror)=@_;$mirror =~ s/[^\w\.\-]+/%/g;my$dir="$self->{home}/sources/$mirror";File::Path::mkpath([$dir ],0,0777);return$dir}sub load_argv_from_fh {my($self,$fh)=@_;my@argv;while(defined(my$line=<$fh>)){chomp$line;$line =~ s/#.+$//;$line =~ s/^\s+//;$line =~ s/\s+$//;push@argv,split ' ',$line if$line}return@argv}sub show_version {my$self=shift;print "cpanm (App::cpanminus) version $VERSION ($0)\n";print "perl version $] ($^X)\n\n";print " \%Config:\n";for my$key (qw(archname installsitelib installsitebin installman1dir installman3dir sitelibexp archlibexp privlibexp)){print " $key=$Config{$key}\n"}print " \%ENV:\n";for my$key (grep /^PERL/,sort keys%ENV){print " $key=$ENV{$key}\n"}print " \@INC:\n";for my$inc (@INC){print " $inc\n" unless ref($inc)eq 'CODE'}return 1}sub show_help {my$self=shift;if ($_[0]){print <<USAGE;$self->_exit(1)}print <<HELP;return 1}sub _writable {my$dir=shift;my@dir=File::Spec->splitdir($dir);while (@dir){$dir=File::Spec->catdir(@dir);if (-e $dir){return -w _}pop@dir}return}sub maybe_abs {my($self,$lib)=@_;if ($lib eq '_' or $lib =~ /^~/ or File::Spec->file_name_is_absolute($lib)){return$lib}else {return File::Spec->canonpath(File::Spec->catdir(Cwd::cwd(),$lib))}}sub local_lib_target {my($self,$root)=@_;(grep {$_ ne ''}split /\Q$Config{path_sep}/,$root)[-1]}sub bootstrap_local_lib {my$self=shift;if ($self->{local_lib}){return$self->setup_local_lib($self->{local_lib})}if ($ENV{PERL_LOCAL_LIB_ROOT}&& $ENV{PERL_MM_OPT}){return$self->setup_local_lib($self->local_lib_target($ENV{PERL_LOCAL_LIB_ROOT}),1)}return if$self->{sudo}or (_writable($Config{installsitelib})and _writable($Config{installsitebin}));if ($ENV{PERL_MM_OPT}and ($ENV{MODULEBUILDRC}or $ENV{PERL_MB_OPT})){$self->bootstrap_local_lib_deps;return}$self->setup_local_lib;$self->diag(<<DIAG,1);sleep 2}sub _core_only_inc {my($self,$base)=@_;require local::lib;(local::lib->resolve_path(local::lib->install_base_perl_path($base)),local::lib->resolve_path(local::lib->install_base_arch_path($base)),@Config{qw(privlibexp archlibexp)},)}sub _diff {my($self,$old,$new)=@_;my@diff;my%old=map {$_=>1}@$old;for my$n (@$new){push@diff,$n unless exists$old{$n}}@diff}sub _setup_local_lib_env {my($self,$base)=@_;$self->diag(<<WARN,1)if$base =~ /\s/;local$SIG{__WARN__}=sub {};local::lib->setup_env_hash_for($base,0)}sub setup_local_lib {my($self,$base,$no_env)=@_;$base=undef if$base eq '_';require local::lib;{local $0='cpanm';$base ||="~/perl5";$base=local::lib->resolve_path($base);if ($self->{self_contained}){my@inc=$self->_core_only_inc($base);$self->{search_inc}=[@inc ]}else {$self->{search_inc}=[local::lib->install_base_arch_path($base),local::lib->install_base_perl_path($base),@INC,]}$self->_setup_local_lib_env($base)unless$no_env;$self->{local_lib}=$base}$self->bootstrap_local_lib_deps}sub bootstrap_local_lib_deps {my$self=shift;push @{$self->{bootstrap_deps}},Dependency->new('ExtUtils::MakeMaker'=>6.31),Dependency->new('ExtUtils::Install'=>1.46)}sub prompt_bool {my($self,$mess,$def)=@_;my$val=$self->prompt($mess,$def);return lc$val eq 'y'}sub prompt {my($self,$mess,$def)=@_;my$isa_tty=-t STDIN && (-t STDOUT ||!(-f STDOUT || -c STDOUT));my$dispdef=defined$def ? "[$def] " : " ";$def=defined$def ? $def : "";if (!$self->{prompt}|| (!$isa_tty && eof STDIN)){return$def}local $|=1;local $\;my$ans;eval {local$SIG{ALRM}=sub {undef$ans;die "alarm\n"};print STDOUT "$mess $dispdef";alarm$self->{prompt_timeout}if$self->{prompt_timeout};$ans=<STDIN>;alarm 0};if (defined$ans){chomp$ans}else {print STDOUT "\n"}return (!defined$ans || $ans eq '')? $def : $ans}sub diag_ok {my($self,$msg)=@_;chomp$msg;$msg ||="OK";if ($self->{in_progress}){$self->_diag("$msg\n");$self->{in_progress}=0}$self->log("-> $msg\n")}sub diag_fail {my($self,$msg,$always)=@_;chomp$msg;if ($self->{in_progress}){$self->_diag("FAIL\n");$self->{in_progress}=0}if ($msg){$self->_diag("! $msg\n",$always,1);$self->log("-> FAIL $msg\n")}}sub diag_progress {my($self,$msg)=@_;chomp$msg;$self->{in_progress}=1;$self->_diag("$msg ... ");$self->log("$msg\n")}sub _diag {my($self,$msg,$always,$error)=@_;my$fh=$error ? *STDERR : *STDOUT;print {$fh}$msg if$always or $self->{verbose}or!$self->{quiet}}sub diag {my($self,$msg,$always)=@_;$self->_diag($msg,$always);$self->log($msg)}sub chat {my$self=shift;print STDERR @_ if$self->{verbose};$self->log(@_)}sub mask_output {my$self=shift;my$method=shift;$self->$method($self->mask_uri_passwords(@_))}sub log {my$self=shift;open my$out,">>$self->{log}";print$out @_}sub run {my($self,$cmd)=@_;if (WIN32){$cmd=$self->shell_quote(@$cmd)if ref$cmd eq 'ARRAY';unless ($self->{verbose}){$cmd .= " >> " .$self->shell_quote($self->{log})." 2>&1"}!system$cmd}else {my$pid=fork;if ($pid){waitpid$pid,0;return!$?}else {$self->run_exec($cmd)}}}sub run_exec {my($self,$cmd)=@_;if (ref$cmd eq 'ARRAY'){unless ($self->{verbose}){open my$logfh,">>",$self->{log};open STDERR,'>&',$logfh;open STDOUT,'>&',$logfh;close$logfh}exec @$cmd}else {unless ($self->{verbose}){$cmd .= " >> " .$self->shell_quote($self->{log})." 2>&1"}exec$cmd}}sub run_timeout {my($self,$cmd,$timeout)=@_;return$self->run($cmd)if WIN32 || $self->{verbose}||!$timeout;my$pid=fork;if ($pid){eval {local$SIG{ALRM}=sub {die "alarm\n"};alarm$timeout;waitpid$pid,0;alarm 0};if ($@ && $@ eq "alarm\n"){$self->diag_fail("Timed out (> ${timeout}s). Use --verbose to retry.");local$SIG{TERM}='IGNORE';kill TERM=>0;waitpid$pid,0;return}return!$?}elsif ($pid==0){$self->run_exec($cmd)}else {$self->chat("! fork failed: falling back to system()\n");$self->run($cmd)}}sub append_args {my($self,$cmd,$phase)=@_;if (my$args=$self->{build_args}{$phase}){$cmd=join ' ',$self->shell_quote(@$cmd),$args}$cmd}sub configure {my($self,$cmd,$depth)=@_;local$ENV{PERL5_CPAN_IS_RUNNING}=local$ENV{PERL5_CPANPLUS_IS_RUNNING}=$$;local$ENV{PERL5_CPANM_IS_RUNNING}=$$;my$use_default=!$self->{interactive};local$ENV{PERL_MM_USE_DEFAULT}=$use_default;local$ENV{PERL_MM_OPT}=$ENV{PERL_MM_OPT};local$ENV{PERL_MB_OPT}=$ENV{PERL_MB_OPT};unless ($self->{pod2man}){$ENV{PERL_MM_OPT}.= " INSTALLMAN1DIR=none INSTALLMAN3DIR=none";$ENV{PERL_MB_OPT}.= " --config installman1dir= --config installsiteman1dir= --config installman3dir= --config installsiteman3dir="}if ($self->{pure_perl}){$ENV{PERL_MM_OPT}.= " PUREPERL_ONLY=1";$ENV{PERL_MB_OPT}.= " --pureperl-only"}$cmd=$self->append_args($cmd,'configure')if$depth==0;local$self->{verbose}=$self->{verbose}|| $self->{interactive};$self->run_timeout($cmd,$self->{configure_timeout})}sub build {my($self,$cmd,$distname,$depth)=@_;local$ENV{PERL_MM_USE_DEFAULT}=!$self->{interactive};$cmd=$self->append_args($cmd,'build')if$depth==0;return 1 if$self->run_timeout($cmd,$self->{build_timeout});while (1){my$ans=lc$self->prompt("Building $distname failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?","s");return if$ans eq 's';return$self->build($cmd,$distname,$depth)if$ans eq 'r';$self->show_build_log if$ans eq 'e';$self->look if$ans eq 'l'}}sub test {my($self,$cmd,$distname,$depth)=@_;return 1 if$self->{notest};local$ENV{PERL_MM_USE_DEFAULT}=!$self->{interactive};local$ENV{NONINTERACTIVE_TESTING}=!$self->{interactive};$cmd=$self->append_args($cmd,'test')if$depth==0;return 1 if$self->run_timeout($cmd,$self->{test_timeout});if ($self->{force}){$self->diag_fail("Testing $distname failed but installing it anyway.");return 1}else {$self->diag_fail;while (1){my$ans=lc$self->prompt("Testing $distname failed.\nYou can s)kip, r)etry, f)orce install, e)xamine build log, or l)ook ?","s");return if$ans eq 's';return$self->test($cmd,$distname,$depth)if$ans eq 'r';return 1 if$ans eq 'f';$self->show_build_log if$ans eq 'e';$self->look if$ans eq 'l'}}}sub install {my($self,$cmd,$uninst_opts,$depth)=@_;if ($depth==0 && $self->{test_only}){return 1}if ($self->{sudo}){unshift @$cmd,"sudo"}if ($self->{uninstall_shadows}&&!$ENV{PERL_MM_OPT}){push @$cmd,@$uninst_opts}$cmd=$self->append_args($cmd,'install')if$depth==0;$self->run($cmd)}sub look {my$self=shift;my$shell=$ENV{SHELL};$shell ||=$ENV{COMSPEC}if WIN32;if ($shell){my$cwd=Cwd::cwd;$self->diag("Entering $cwd with $shell\n");system$shell}else {$self->diag_fail("You don't seem to have a SHELL :/")}}sub show_build_log {my$self=shift;my@pagers=($ENV{PAGER},(WIN32 ? (): ('less')),'more');my$pager;while (@pagers){$pager=shift@pagers;next unless$pager;$pager=$self->which($pager);next unless$pager;last}if ($pager){system("$pager < $self->{log}")}else {$self->diag_fail("You don't seem to have a PAGER :/")}}sub chdir {my$self=shift;Cwd::chdir(File::Spec->canonpath($_[0]))or die "$_[0]: $!"}sub configure_mirrors {my$self=shift;unless (@{$self->{mirrors}}){$self->{mirrors}=['http://www.cpan.org' ]}for (@{$self->{mirrors}}){s!^/!file:///!;s!/$!!}}sub self_upgrade {my$self=shift;$self->check_upgrade;$self->{argv}=['App::cpanminus' ];return}sub install_module {my($self,$module,$depth,$version)=@_;$self->check_libs;if ($self->{seen}{$module}++){$self->chat("Already tried $module. Skipping.\n");return 1}if ($self->{skip_satisfied}){my($ok,$local)=$self->check_module($module,$version || 0);if ($ok){$self->diag("You have $module ($local)\n",1);return 1}}my$dist=$self->resolve_name($module,$version);unless ($dist){my$what=$module .($version ? " ($version)" : "");$self->diag_fail("Couldn't find module or a distribution $what",1);return}if ($dist->{distvname}&& $self->{seen}{$dist->{distvname}}++){$self->chat("Already tried $dist->{distvname}. Skipping.\n");return 1}if ($self->{cmd}eq 'info'){print$self->format_dist($dist),"\n";return 1}$dist->{depth}=$depth;if ($dist->{module}){unless ($self->satisfy_version($dist->{module},$dist->{module_version},$version)){$self->diag("Found $dist->{module} $dist->{module_version} which doesn't satisfy $version.\n",1);return}my$cmp=$version ? "==" : "";my$requirement=$dist->{module_version}? "$cmp$dist->{module_version}" : 0;my($ok,$local)=$self->check_module($dist->{module},$requirement);if ($self->{skip_installed}&& $ok){$self->diag("$dist->{module} is up to date. ($local)\n",1);return 1}}if ($dist->{dist}eq 'perl'){$self->diag("skipping $dist->{pathname}\n");return 1}$self->diag("--> Working on $module\n");$dist->{dir}||=$self->fetch_module($dist);unless ($dist->{dir}){$self->diag_fail("Failed to fetch distribution $dist->{distvname}",1);return}$self->chat("Entering $dist->{dir}\n");$self->chdir($self->{base});$self->chdir($dist->{dir});if ($self->{cmd}eq 'look'){$self->look;return 1}return$self->build_stuff($module,$dist,$depth)}sub uninstall_search_path {my$self=shift;$self->{local_lib}? (local::lib->install_base_arch_path($self->{local_lib}),local::lib->install_base_perl_path($self->{local_lib})): @Config{qw(installsitearch installsitelib)}}sub uninstall_module {my ($self,$module)=@_;$self->check_libs;my@inc=$self->uninstall_search_path;my($metadata,$packlist)=$self->packlists_containing($module,\@inc);unless ($packlist){$self->diag_fail(<<DIAG,1);return}my@uninst_files=$self->uninstall_target($metadata,$packlist);$self->ask_permission($module,\@uninst_files)or return;$self->uninstall_files(@uninst_files,$packlist);$self->diag("Successfully uninstalled $module\n",1);return 1}sub packlists_containing {my($self,$module,$inc)=@_;require Module::Metadata;my$metadata=Module::Metadata->new_from_module($module,inc=>$inc)or return;my$packlist;my$wanted=sub {return unless $_ eq '.packlist' && -f $_;for my$file ($self->unpack_packlist($File::Find::name)){$packlist ||=$File::Find::name if$file eq $metadata->filename}};{require File::pushd;my$pushd=File::pushd::pushd();my@search=grep -d $_,map File::Spec->catdir($_,'auto'),@$inc;File::Find::find($wanted,@search)}return$metadata,$packlist}sub uninstall_target {my($self,$metadata,$packlist)=@_;if ($self->has_shadow_install($metadata)or $self->{local_lib}){grep$self->should_unlink($_),$self->unpack_packlist($packlist)}else {$self->unpack_packlist($packlist)}}sub has_shadow_install {my($self,$metadata)=@_;my@shadow=grep defined,map Module::Metadata->new_from_module($metadata->name,inc=>[$_]),@INC;@shadow >= 2}sub should_unlink {my($self,$file)=@_;if ($self->{local_lib}){$file =~ /^\Q$self->{local_lib}\E/}else {!(grep$file =~ /^\Q$_\E/,@Config{qw(installbin installscript installman1dir installman3dir)})}}sub ask_permission {my ($self,$module,$files)=@_;$self->diag("$module contains the following files:\n\n");for my$file (@$files){$self->diag(" $file\n")}$self->diag("\n");return 'force uninstall' if$self->{force};local$self->{prompt}=1;return$self->prompt_bool("Are you sure you want to uninstall $module?",'y')}sub unpack_packlist {my ($self,$packlist)=@_;open my$fh,'<',$packlist or die "$packlist: $!";map {chomp;$_}<$fh>}sub uninstall_files {my ($self,@files)=@_;$self->diag("\n");for my$file (@files){$self->diag("Unlink: $file\n");unlink$file or $self->diag_fail("$!: $file")}$self->diag("\n");return 1}sub format_dist {my($self,$dist)=@_;return "$dist->{cpanid}/$dist->{filename}"}sub trim {local $_=shift;tr/\n/ /d;s/^\s*|\s*$//g;$_}sub fetch_module {my($self,$dist)=@_;$self->chdir($self->{base});for my$uri (@{$dist->{uris}}){$self->mask_output(diag_progress=>"Fetching $uri");my$filename=$dist->{filename}|| $uri;my$name=File::Basename::basename($filename);my$cancelled;my$fetch=sub {my$file;eval {local$SIG{INT}=sub {$cancelled=1;die "SIGINT\n"};$self->mirror($uri,$name);$file=$name if -e $name};$self->diag("ERROR: " .trim("$@")."\n",1)if $@ && $@ ne "SIGINT\n";return$file};my($try,$file);while ($try++ < 3){$file=$fetch->();last if$cancelled or $file;$self->diag_fail("Download $uri failed. Retrying ... ")}if ($cancelled){$self->diag_fail("Download cancelled.");return}unless ($file){$self->diag_fail("Failed to download $uri");next}$self->diag_ok;$dist->{local_path}=File::Spec->rel2abs($name);my$dir=$self->unpack($file,$uri,$dist);next unless$dir;if (my$save=$self->{save_dists}){my$path=$dist->{pathname}? "$save/authors/id/$dist->{pathname}" : "$save/vendor/$file";$self->chat("Copying $name to $path\n");File::Path::mkpath([File::Basename::dirname($path)],0,0777);File::Copy::copy($file,$path)or warn $!}return$dist,$dir}}sub unpack {my($self,$file,$uri,$dist)=@_;if ($self->{verify}){$self->verify_archive($file,$uri,$dist)or return}$self->chat("Unpacking $file\n");my$dir=$file =~ /\.zip/i ? $self->unzip($file): $self->untar($file);unless ($dir){$self->diag_fail("Failed to unpack $file: no directory")}return$dir}sub verify_checksums_signature {my($self,$chk_file)=@_;require Module::Signature;$self->chat("Verifying the signature of CHECKSUMS\n");my$rv=eval {local$SIG{__WARN__}=sub {};my$v=Module::Signature::_verify($chk_file);$v==Module::Signature::SIGNATURE_OK()};if ($rv){$self->chat("Verified OK!\n")}else {$self->diag_fail("Verifying CHECKSUMS signature failed: $rv\n");return}return 1}sub verify_archive {my($self,$file,$uri,$dist)=@_;unless ($dist->{cpanid}){$self->chat("Archive '$file' does not seem to be from PAUSE. Skip verification.\n")}(my$mirror=$uri)=~ s!/authors/id.*$!!;(my$chksum_uri=$uri)=~ s!/[^/]*$!/CHECKSUMS!;my$chk_file=$self->source_for($mirror)."/$dist->{cpanid}.CHECKSUMS";$self->mask_output(diag_progress=>"Fetching $chksum_uri");$self->mirror($chksum_uri,$chk_file);unless (-e $chk_file){$self->diag_fail("Fetching $chksum_uri failed.\n");return}$self->diag_ok;$self->verify_checksums_signature($chk_file)or return;$self->verify_checksum($file,$chk_file)}sub verify_checksum {my($self,$file,$chk_file)=@_;$self->chat("Verifying the SHA1 for $file\n");open my$fh,"<$chk_file" or die "$chk_file: $!";my$data=join '',<$fh>;$data =~ s/\015?\012/\n/g;require Safe;my$chksum=Safe->new->reval($data);if (!ref$chksum or ref$chksum ne 'HASH'){$self->diag_fail("! Checksum file downloaded from $chk_file is broken.\n");return}if (my$sha=$chksum->{$file}{sha256}){my$hex=$self->sha1_for($file);if ($hex eq $sha){$self->chat("Checksum for $file: Verified!\n")}else {$self->diag_fail("Checksum mismatch for $file\n");return}}else {$self->chat("Checksum for $file not found in CHECKSUMS.\n");return}}sub sha1_for {my($self,$file)=@_;require Digest::SHA;open my$fh,"<",$file or die "$file: $!";my$dg=Digest::SHA->new(256);my($data);while (read($fh,$data,4096)){$dg->add($data)}return$dg->hexdigest}sub verify_signature {my($self,$dist)=@_;$self->diag_progress("Verifying the SIGNATURE file");my$out=`$self->{cpansign} -v --skip 2>&1`;$self->log($out);if ($out =~ /Signature verified OK/){$self->diag_ok("Verified OK");return 1}else {$self->diag_fail("SIGNATURE verificaion for $dist->{filename} failed\n");return}}sub resolve_name {my($self,$module,$version)=@_;if ($module =~ /^(ftp|https?|file):/){if ($module =~ m!authors/id/(.*)!){return$self->cpan_dist($1,$module)}else {return {uris=>[$module ]}}}if ($module =~ m!^[\./]! && -d $module){return {source=>'local',dir=>Cwd::abs_path($module),}}if (-f $module){return {source=>'local',uris=>["file://" .Cwd::abs_path($module)],}}if ($module =~ /(?:^git:|\.git(?:@.+)?$)/){return$self->git_uri($module)}if ($module =~ s!^cpan:///distfile/!!){return$self->cpan_dist($module)}if ($module =~ m!^(?:[A-Z]/[A-Z]{2}/)?([A-Z]{2}[\-A-Z0-9]*/.*)$!){return$self->cpan_dist($1)}return$self->search_module($module,$version)}sub cpan_module {my($self,$module,$dist,$version)=@_;my$dist=$self->cpan_dist($dist);$dist->{module}=$module;$dist->{module_version}=$version if$version && $version ne 'undef';return$dist}sub cpan_dist {my($self,$dist,$url)=@_;$dist =~ s!^([A-Z]{2})!substr($1,0,1)."/".substr($1,0,2)."/".$1!e;require CPAN::DistnameInfo;my$d=CPAN::DistnameInfo->new($dist);if ($url){$url=[$url ]unless ref$url eq 'ARRAY'}else {my$id=$d->cpanid;my$fn=substr($id,0,1)."/" .substr($id,0,2)."/" .$id ."/" .$d->filename;my@mirrors=@{$self->{mirrors}};my@urls=map "$_/authors/id/$fn",@mirrors;$url=\@urls,}return {$d->properties,source=>'cpan',uris=>$url,}}sub git_uri {my ($self,$uri)=@_;($uri,my$commitish)=split /(?<=\.git)@/i,$uri,2;my$dir=File::Temp::tempdir(CLEANUP=>1);$self->mask_output(diag_progress=>"Cloning $uri");$self->run(['git','clone',$uri,$dir ]);unless (-e "$dir/.git"){$self->diag_fail("Failed cloning git repository $uri",1);return}if ($commitish){require File::pushd;my$dir=File::pushd::pushd($dir);unless ($self->run(['git','checkout',$commitish ])){$self->diag_fail("Failed to checkout '$commitish' in git repository $uri\n");return}}$self->diag_ok;return {source=>'local',dir=>$dir,}}sub setup_module_build_patch {my$self=shift;open my$out,">$self->{base}/ModuleBuildSkipMan.pm" or die $!;print$out <<EOF}sub core_version_for {my($self,$module)=@_;require Module::CoreList;unless (exists$Module::CoreList::version{$]+0}){die sprintf("Module::CoreList %s (loaded from %s) doesn't seem to have entries for perl $]. " ."You're strongly recommended to upgrade Module::CoreList from CPAN.\n",$Module::CoreList::VERSION,$INC{"Module/CoreList.pm"})}unless (exists$Module::CoreList::version{$]+0}{$module}){return -1}return$Module::CoreList::version{$]+0}{$module}}sub check_module {my($self,$mod,$want_ver)=@_;require Module::Metadata;my$meta=Module::Metadata->new_from_module($mod,inc=>$self->{search_inc})or return 0,undef;my$version=$meta->version;if ($self->{self_contained}&& $self->loaded_from_perl_lib($meta)){$version=$self->core_version_for($mod);return 0,undef if$version && $version==-1}$self->{local_versions}{$mod}=$version;if ($self->is_deprecated($meta)){return 0,$version}elsif ($self->satisfy_version($mod,$version,$want_ver)){return 1,($version || 'undef')}else {return 0,$version}}sub satisfy_version {my($self,$mod,$version,$want_ver)=@_;$want_ver='0' unless defined($want_ver)&& length($want_ver);require CPAN::Meta::Requirements;my$requirements=CPAN::Meta::Requirements->new;$requirements->add_string_requirement($mod,$want_ver);$requirements->accepts_module($mod,$version)}sub unsatisfy_how {my($self,$ver,$want_ver)=@_;if ($want_ver =~ /^[v0-9\.\_]+$/){return "$ver < $want_ver"}else {return "$ver doesn't satisfy $want_ver"}}sub is_deprecated {my($self,$meta)=@_;my$deprecated=eval {require Module::CoreList;Module::CoreList::is_deprecated($meta->{module})};return$deprecated && $self->loaded_from_perl_lib($meta)}sub loaded_from_perl_lib {my($self,$meta)=@_;require Config;for my$dir (qw(archlibexp privlibexp)){my$confdir=$Config{$dir};if ($confdir eq substr($meta->filename,0,length($confdir))){return 1}}return}sub should_install {my($self,$mod,$ver)=@_;$self->chat("Checking if you have $mod $ver ... ");my($ok,$local)=$self->check_module($mod,$ver);if ($ok){$self->chat("Yes ($local)\n")}elsif ($local){$self->chat("No (" .$self->unsatisfy_how($local,$ver).")\n")}else {$self->chat("No\n")}return$mod unless$ok;return}sub check_perl_version {my($self,$version)=@_;require CPAN::Meta::Requirements;my$req=CPAN::Meta::Requirements->from_string_hash({perl=>$version });$req->accepts_module(perl=>$])}sub install_deps {my($self,$dir,$depth,@deps)=@_;my(@install,%seen,@fail);for my$dep (@deps){next if$seen{$dep->module};if ($dep->module eq 'perl'){if ($dep->is_requirement &&!$self->check_perl_version($dep->version)){$self->diag("Needs perl @{[$dep->version]}, you have $]\n");push@fail,'perl'}}elsif ($self->should_install($dep->module,$dep->version)){push@install,$dep;$seen{$dep->module}=1}}if (@install){$self->diag("==> Found dependencies: " .join(", ",map $_->module,@install)."\n")}for my$dep (@install){$self->install_module($dep->module,$depth + 1,$dep->version)}$self->chdir($self->{base});$self->chdir($dir)if$dir;if ($self->{scandeps}){return 1}my@not_ok=$self->unsatisfied_deps(@deps);if (@not_ok){return 0,\@not_ok}else {return 1}}sub unsatisfied_deps {my($self,@deps)=@_;require CPAN::Meta::Check;require CPAN::Meta::Requirements;my$reqs=CPAN::Meta::Requirements->new;for my$dep (grep $_->is_requirement,@deps){$reqs->add_string_requirement($dep->module=>$dep->version || '0')}my$ret=CPAN::Meta::Check::check_requirements($reqs,'requires',$self->{search_inc});grep defined,values %$ret}sub install_deps_bailout {my($self,$target,$dir,$depth,@deps)=@_;my($ok,$fail)=$self->install_deps($dir,$depth,@deps);if (!$ok){$self->diag_fail("Installing the dependencies failed: " .join(", ",@$fail),1);unless ($self->prompt_bool("Do you want to continue building $target anyway?","n")){$self->diag_fail("Bailing out the installation for $target.",1);return}}return 1}sub build_stuff {my($self,$stuff,$dist,$depth)=@_;if ($self->{verify}&& -e 'SIGNATURE'){$self->verify_signature($dist)or return}require CPAN::Meta;my($meta_file)=grep -f,qw(META.json META.yml);if ($meta_file){$self->chat("Checking configure dependencies from $meta_file\n");$dist->{cpanmeta}=eval {CPAN::Meta->load_file($meta_file)}}elsif ($dist->{dist}&& $dist->{version}){$self->chat("META.yml/json not found. Creating skeleton for it.\n");$dist->{cpanmeta}=CPAN::Meta->new({name=>$dist->{dist},version=>$dist->{version}})}$dist->{meta}=$dist->{cpanmeta}? $dist->{cpanmeta}->as_struct : {};my@config_deps;if ($dist->{cpanmeta}){push@config_deps,Dependency->from_prereqs($dist->{cpanmeta}->effective_prereqs,['configure'],$self->{install_types},)}else {push@config_deps,Dependency->from_versions($dist->{meta}{configure_requires}|| {},'configure',)}if (-e 'Build.PL' &&!$self->should_use_mm($dist->{dist})){push@config_deps,Dependency->from_versions({'Module::Build'=>'0.36' },'configure',)}my$target=$dist->{meta}{name}? "$dist->{meta}{name}-$dist->{meta}{version}" : $dist->{dir};$self->install_deps_bailout($target,$dist->{dir},$depth,@config_deps)or return;$self->diag_progress("Configuring $target");my$configure_state=$self->configure_this($dist,$depth);$self->diag_ok($configure_state->{configured_ok}? "OK" : "N/A");$dist->{provides}=$self->extract_packages($dist->{cpanmeta},".")if$dist->{cpanmeta}&& $dist->{source}eq 'cpan';my$root_target=(($self->{installdeps}or $self->{showdeps})and $depth==0);$dist->{want_phases}=$self->{notest}&&!$root_target ? [qw(build runtime)]: [qw(build test runtime)];push @{$dist->{want_phases}},'develop' if$self->{with_develop}&& $depth==0;my@deps=$self->find_prereqs($dist);my$module_name=$self->find_module_name($configure_state)|| $dist->{meta}{name};$module_name =~ s/-/::/g;if ($self->{showdeps}){for my$dep (@config_deps,@deps){print$dep->module,($dep->version ? ("~".$dep->version): ""),"\n"}return 1}my$distname=$dist->{meta}{name}? "$dist->{meta}{name}-$dist->{meta}{version}" : $stuff;my$walkup;if ($self->{scandeps}){$walkup=$self->scandeps_append_child($dist)}$self->install_deps_bailout($distname,$dist->{dir},$depth,@deps)or return;if ($self->{scandeps}){unless ($configure_state->{configured_ok}){my$diag=<<DIAG;if (@config_deps){my@tree=@{$self->{scandeps_tree}};$diag .= "!\n" .join("",map "! * $_->[0]{module}\n",@tree[0..$#tree-1])if@tree}$self->diag("!\n$diag!\n",1)}$walkup->();return 1}if ($self->{installdeps}&& $depth==0){if ($configure_state->{configured_ok}){$self->diag("<== Installed dependencies for $stuff. Finishing.\n");return 1}else {$self->diag("! Configuring $distname failed. See $self->{log} for details.\n",1);return}}my$installed;if ($configure_state->{use_module_build}&& -e 'Build' && -f _){$self->diag_progress("Building " .($self->{notest}? "" : "and testing ").$distname);$self->build([$self->{perl},"./Build" ],$distname,$depth)&& $self->test([$self->{perl},"./Build","test" ],$distname,$depth)&& $self->install([$self->{perl},"./Build","install" ],["--uninst",1 ],$depth)&& $installed++}elsif ($self->{make}&& -e 'Makefile'){$self->diag_progress("Building " .($self->{notest}? "" : "and testing ").$distname);$self->build([$self->{make}],$distname,$depth)&& $self->test([$self->{make},"test" ],$distname,$depth)&& $self->install([$self->{make},"install" ],["UNINST=1" ],$depth)&& $installed++}else {my$why;my$configure_failed=$configure_state->{configured}&&!$configure_state->{configured_ok};if ($configure_failed){$why="Configure failed for $distname."}elsif ($self->{make}){$why="The distribution doesn't have a proper Makefile.PL/Build.PL"}else {$why="Can't configure the distribution. You probably need to have 'make'."}$self->diag_fail("$why See $self->{log} for details.",1);return}if ($installed && $self->{test_only}){$self->diag_ok;$self->diag("Successfully tested $distname\n",1)}elsif ($installed){my$local=$self->{local_versions}{$dist->{module}|| ''};my$version=$dist->{module_version}|| $dist->{meta}{version}|| $dist->{version};my$reinstall=$local && ($local eq $version);my$action=$local &&!$reinstall ? $self->numify_ver($version)< $self->numify_ver($local)? "downgraded" : "upgraded" : undef;my$how=$reinstall ? "reinstalled $distname" : $local ? "installed $distname ($action from $local)" : "installed $distname" ;my$msg="Successfully $how";$self->diag_ok;$self->diag("$msg\n",1);$self->{installed_dists}++;$self->save_meta($stuff,$dist,$module_name,\@config_deps,\@deps);return 1}else {my$what=$self->{test_only}? "Testing" : "Installing";$self->diag_fail("$what $stuff failed. See $self->{log} for details. Retry with --force to force install it.",1);return}}sub perl_requirements {my($self,@requires)=@_;my@perl;for my$requires (grep defined,@requires){if (exists$requires->{perl}){push@perl,Dependency->new(perl=>$requires->{perl})}}return@perl}sub should_use_mm {my($self,$dist)=@_;my%should_use_mm=map {$_=>1}qw(version ExtUtils-ParseXS ExtUtils-Install ExtUtils-Manifest);$should_use_mm{$dist}}sub configure_this {my($self,$dist,$depth)=@_;if (-e $self->{cpanfile_path}&& $self->{installdeps}&& $depth==0){require Module::CPANfile;$dist->{cpanfile}=eval {Module::CPANfile->load($self->{cpanfile_path})};$self->diag_fail($@,1)if $@;return {configured=>1,configured_ok=>!!$dist->{cpanfile},use_module_build=>0,}}if ($self->{skip_configure}){my$eumm=-e 'Makefile';my$mb=-e 'Build' && -f _;return {configured=>1,configured_ok=>$eumm || $mb,use_module_build=>$mb,}}my$state={};my$try_eumm=sub {if (-e 'Makefile.PL'){$self->chat("Running Makefile.PL\n");if ($self->configure([$self->{perl},"Makefile.PL" ],$depth)){$state->{configured_ok}=-e 'Makefile'}$state->{configured}++}};my$try_mb=sub {if (-e 'Build.PL'){$self->chat("Running Build.PL\n");if ($self->configure([$self->{perl},"Build.PL" ],$depth)){$state->{configured_ok}=-e 'Build' && -f _}$state->{use_module_build}++;$state->{configured}++}};my@try;if ($dist->{dist}&& $self->should_use_mm($dist->{dist})){@try=($try_eumm,$try_mb)}else {@try=($try_mb,$try_eumm)}for my$try (@try){$try->();last if$state->{configured_ok}}unless ($state->{configured_ok}){while (1){my$ans=lc$self->prompt("Configuring $dist->{dist} failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?","s");last if$ans eq 's';return$self->configure_this($dist,$depth)if$ans eq 'r';$self->show_build_log if$ans eq 'e';$self->look if$ans eq 'l'}}return$state}sub find_module_name {my($self,$state)=@_;return unless$state->{configured_ok};if ($state->{use_module_build}&& -e "_build/build_params"){my$params=do {open my$in,"_build/build_params";$self->safe_eval(join "",<$in>)};return eval {$params->[2]{module_name}}|| undef}elsif (-e "Makefile"){open my$mf,"Makefile";while (<$mf>){if (/^\#\s+NAME\s+=>\s+(.*)/){return$self->safe_eval($1)}}}return}sub list_files {my$self=shift;if (-e 'MANIFEST'){require ExtUtils::Manifest;my$manifest=eval {ExtUtils::Manifest::manifind()}|| {};return sort {lc$a cmp lc$b}keys %$manifest}else {require File::Find;my@files;my$finder=sub {my$name=$File::Find::name;$name =~ s!\.[/\\]!!;push@files,$name};File::Find::find($finder,".");return sort {lc$a cmp lc$b}@files}}sub extract_packages {my($self,$meta,$dir)=@_;my$try=sub {my$file=shift;return 1 unless$meta->{no_index};return 0 if grep {$file =~ m!^$_/!}@{$meta->{no_index}{directory}|| []};return 0 if grep {$file eq $_}@{$meta->{no_index}{file}|| []};return 1};require App::cpanminus::ParsePM;my@files=grep {/\.pm(?:\.PL)?$/ && $try->($_)}$self->list_files;my$provides={};for my$file (@files){my$parser=App::cpanminus::ParsePM->new($meta);my$packages=$parser->parse($file);while (my($package,$meta)=each %$packages){$provides->{$package}||={file=>$meta->{infile},($meta->{version}eq 'undef')? (): (version=>$meta->{version}),}}}return$provides}sub save_meta {my($self,$module,$dist,$module_name,$config_deps,$build_deps)=@_;return unless$dist->{distvname}&& $dist->{source}eq 'cpan';my$base=($ENV{PERL_MM_OPT}|| '')=~ /INSTALL_BASE=/ ? ($self->install_base($ENV{PERL_MM_OPT})."/lib/perl5"): $Config{sitelibexp};my$provides=$dist->{provides};File::Path::mkpath("blib/meta",0,0777);my$local={name=>$module_name,target=>$module,version=>exists$provides->{$module_name}? ($provides->{$module_name}{version}|| $dist->{version}): $dist->{version},dist=>$dist->{distvname},pathname=>$dist->{pathname},provides=>$provides,};require JSON::PP;open my$fh,">","blib/meta/install.json" or die $!;print$fh JSON::PP::encode_json($local);if (-e "MYMETA.json"){File::Copy::copy("MYMETA.json","blib/meta/MYMETA.json")}my@cmd=(($self->{sudo}? 'sudo' : ()),$^X,'-MExtUtils::Install=install','-e',qq[install({ 'blib/meta' => '$base/$Config{archname}/.meta/$dist->{distvname}' })],);$self->run(\@cmd)}sub _merge_hashref {my($self,@hashrefs)=@_;my%hash;for my$h (@hashrefs){%hash=(%hash,%$h)}return \%hash}sub install_base {my($self,$mm_opt)=@_;$mm_opt =~ /INSTALL_BASE=(\S+)/ and return $1;die "Your PERL_MM_OPT doesn't contain INSTALL_BASE"}sub safe_eval {my($self,$code)=@_;eval$code}sub configure_features {my($self,$dist,@features)=@_;map $_->identifier,grep {$self->effective_feature($dist,$_)}@features}sub effective_feature {my($self,$dist,$feature)=@_;if ($dist->{depth}==0){my$value=$self->{features}{$feature->identifier};return$value if defined$value;return 1 if$self->{features}{__all}}if ($self->{interactive}){require CPAN::Meta::Requirements;$self->diag("[@{[ $feature->description ]}]\n",1);my$req=CPAN::Meta::Requirements->new;for my$phase (@{$dist->{want_phases}}){for my$type (@{$self->{install_types}}){$req->add_requirements($feature->prereqs->requirements_for($phase,$type))}}my$reqs=$req->as_string_hash;my@missing;for my$module (keys %$reqs){if ($self->should_install($module,$req->{$module})){push@missing,$module}}if (@missing){my$howmany=@missing;$self->diag("==> Found missing dependencies: " .join(", ",@missing)."\n",1);local$self->{prompt}=1;return$self->prompt_bool("Install the $howmany optional module(s)?","y")}}return}sub find_prereqs {my($self,$dist)=@_;my@deps=$self->extract_meta_prereqs($dist);if ($dist->{module}=~ /^Bundle::/i){push@deps,$self->bundle_deps($dist)}return@deps}sub extract_meta_prereqs {my($self,$dist)=@_;if ($dist->{cpanfile}){my@features=$self->configure_features($dist,$dist->{cpanfile}->features);my$prereqs=$dist->{cpanfile}->prereqs_with(@features);return Dependency->from_prereqs($prereqs,$dist->{want_phases},$self->{install_types})}my$meta=$dist->{meta};my@deps;if (-e "MYMETA.json"){require JSON::PP;$self->chat("Checking dependencies from MYMETA.json ...\n");my$json=do {open my$in,"<MYMETA.json";local $/;<$in>};my$mymeta=JSON::PP::decode_json($json);if ($mymeta){$meta->{$_}=$mymeta->{$_}for qw(name version);return$self->extract_prereqs($mymeta,$dist)}}if (-e 'MYMETA.yml'){$self->chat("Checking dependencies from MYMETA.yml ...\n");my$mymeta=$self->parse_meta('MYMETA.yml');if ($mymeta){$meta->{$_}=$mymeta->{$_}for qw(name version);return$self->extract_prereqs($mymeta,$dist)}}if (-e '_build/prereqs'){$self->chat("Checking dependencies from _build/prereqs ...\n");my$prereqs=do {open my$in,"_build/prereqs";$self->safe_eval(join "",<$in>)};@deps=$self->extract_prereqs({name=>$meta->{name},version=>$meta->{version},%$prereqs },$dist)}elsif (-e 'Makefile'){$self->chat("Finding PREREQ from Makefile ...\n");open my$mf,"Makefile";while (<$mf>){if (/^\#\s+PREREQ_PM => \{\s*(.*?)\s*\}/){my@all;my@pairs=split ', ',$1;for (@pairs){my ($pkg,$v)=split '=>',$_;push@all,[$pkg,$v ]}my$list=join ", ",map {"'$_->[0]' => $_->[1]"}@all;my$prereq=$self->safe_eval("no strict; +{ $list }");push@deps,Dependency->from_versions($prereq)if$prereq;last}}}return@deps}sub bundle_deps {my($self,$dist)=@_;my@files;File::Find::find({wanted=>sub {push@files,File::Spec->rel2abs($_)if /\.pm/i},no_chdir=>1,},'.');my@deps;for my$file (@files){open my$pod,"<",$file or next;my$in_contents;while (<$pod>){if (/^=head\d\s+CONTENTS/){$in_contents=1}elsif (/^=/){$in_contents=0}elsif ($in_contents){/^(\S+)\s*(\S+)?/ and push@deps,Dependency->new($1,$self->maybe_version($2))}}}return@deps}sub maybe_version {my($self,$string)=@_;return$string && $string =~ /^\.?\d/ ? $string : undef}sub extract_prereqs {my($self,$metadata,$dist)=@_;require CPAN::Meta;my$meta=CPAN::Meta->new($metadata,{lazy_validation=>1 });my@features=$self->configure_features($dist,$meta->features);return Dependency->from_prereqs($meta->effective_prereqs(\@features),$dist->{want_phases},$self->{install_types})}sub cleanup_workdirs {my$self=shift;my$expire=time - 24 * 60 * 60 * $self->{auto_cleanup};my@targets;opendir my$dh,"$self->{home}/work";while (my$e=readdir$dh){next if$e !~ /^(\d+)\.\d+$/;my$time=$1;if ($time < $expire){push@targets,"$self->{home}/work/$e"}}if (@targets){if (@targets >= 64){$self->diag("Expiring " .scalar(@targets)." work directories. This might take long...\n")}else {$self->chat("Expiring " .scalar(@targets)." work directories.\n")}File::Path::rmtree(\@targets,0,0)}}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)=@_;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}}sub shell_quote {my($self,@stuff)=@_;if (WIN32){join ' ',map {/^${quote}.+${quote}$/ ? $_ : ($quote .$_ .$quote)}@stuff}else {String::ShellQuote::shell_quote_best_effort(@stuff)}}sub which {my($self,$name)=@_;return$name if File::Spec->file_name_is_absolute($name)&& -x $name;my$exe_ext=$Config{_exe};for my$dir (File::Spec->path){my$fullpath=File::Spec->catfile($dir,$name);if (-x $fullpath || -x ($fullpath .= $exe_ext)){if ($fullpath =~ /\s/){$fullpath=$self->shell_quote($fullpath)}return$fullpath}}return}sub get {my($self,$uri)=@_;if ($uri =~ /^file:/){$self->file_get($uri)}else {$self->{_backends}{get}->(@_)}}sub mirror {my($self,$uri,$local)=@_;if ($uri =~ /^file:/){$self->file_mirror($uri,$local)}else {$self->{_backends}{mirror}->(@_)}}sub untar {$_[0]->{_backends}{untar}->(@_)};sub unzip {$_[0]->{_backends}{unzip}->(@_)};sub uri_to_file {my($self,$uri)=@_;if ($uri =~ s!file:/+!!){$uri="/$uri" unless$uri =~ m![a-zA-Z]:!}return$uri}sub file_get {my($self,$uri)=@_;my$file=$self->uri_to_file($uri);open my$fh,"<$file" or return;join '',<$fh>}sub file_mirror {my($self,$uri,$path)=@_;my$file=$self->uri_to_file($uri);File::Copy::copy($file,$path)}sub has_working_lwp {my($self,$mirrors)=@_;my$https=grep /^https:/,@$mirrors;eval {require LWP::UserAgent;LWP::UserAgent->VERSION(5.802);require LWP::Protocol::https if$https;1}}sub init_tools {my$self=shift;return if$self->{initialized}++;if ($self->{make}=$self->which($Config{make})){$self->chat("You have make $self->{make}\n")}if ($self->{try_lwp}&& $self->has_working_lwp($self->{mirrors})){$self->chat("You have LWP $LWP::VERSION\n");my$ua=sub {LWP::UserAgent->new(parse_head=>0,env_proxy=>1,agent=>$self->agent,timeout=>30,@_,)};$self->{_backends}{get}=sub {my$self=shift;my$res=$ua->()->request(HTTP::Request->new(GET=>$_[0]));return unless$res->is_success;return$res->decoded_content};$self->{_backends}{mirror}=sub {my$self=shift;my$res=$ua->()->mirror(@_);die$res->content if$res->code==501;$res->code}}elsif ($self->{try_wget}and my$wget=$self->which('wget')){$self->chat("You have $wget\n");my@common=('--user-agent',$self->agent,'--retry-connrefused',($self->{verbose}? (): ('-q')),);$self->{_backends}{get}=sub {my($self,$uri)=@_;$self->safeexec(my$fh,$wget,$uri,@common,'-O','-')or die "wget $uri: $!";local $/;<$fh>};$self->{_backends}{mirror}=sub {my($self,$uri,$path)=@_;$self->safeexec(my$fh,$wget,$uri,@common,'-O',$path)or die "wget $uri: $!";local $/;<$fh>}}elsif ($self->{try_curl}and my$curl=$self->which('curl')){$self->chat("You have $curl\n");my@common=('--location','--user-agent',$self->agent,($self->{verbose}? (): '-s'),);$self->{_backends}{get}=sub {my($self,$uri)=@_;$self->safeexec(my$fh,$curl,@common,$uri)or die "curl $uri: $!";local $/;<$fh>};$self->{_backends}{mirror}=sub {my($self,$uri,$path)=@_;$self->safeexec(my$fh,$curl,@common,$uri,'-#','-o',$path)or die "curl $uri: $!";local $/;<$fh>}}else {require HTTP::Tiny;$self->chat("Falling back to HTTP::Tiny $HTTP::Tiny::VERSION\n");my%common=(agent=>$self->agent,);$self->{_backends}{get}=sub {my$self=shift;my$res=HTTP::Tiny->new(%common)->get($_[0]);return unless$res->{success};return$res->{content}};$self->{_backends}{mirror}=sub {my$self=shift;my$res=HTTP::Tiny->new(%common)->mirror(@_);return$res->{status}}}my$tar=$self->which('tar');my$tar_ver;my$maybe_bad_tar=sub {WIN32 || SUNOS || (($tar_ver=`$tar --version 2>/dev/null`)=~ /GNU.*1\.13/i)};if ($tar &&!$maybe_bad_tar->()){chomp$tar_ver;$self->chat("You have $tar: $tar_ver\n");$self->{_backends}{untar}=sub {my($self,$tarfile)=@_;my$xf=($self->{verbose}? 'v' : '')."xf";my$ar=$tarfile =~ /bz2$/ ? 'j' : 'z';my($root,@others)=`$tar ${ar}tf $tarfile` or return undef;FILE: {chomp$root;$root =~ s!^\./!!;$root =~ s{^(.+?)/.*$}{$1};if (!length($root)){$root=shift(@others);redo FILE if$root}}system "$tar $ar$xf $tarfile";return$root if -d $root;$self->diag_fail("Bad archive: $tarfile");return undef}}elsif ($tar and my$gzip=$self->which('gzip')and my$bzip2=$self->which('bzip2')){$self->chat("You have $tar, $gzip and $bzip2\n");$self->{_backends}{untar}=sub {my($self,$tarfile)=@_;my$x="x" .($self->{verbose}? 'v' : '')."f -";my$ar=$tarfile =~ /bz2$/ ? $bzip2 : $gzip;my($root,@others)=`$ar -dc $tarfile | $tar tf -` or return undef;FILE: {chomp$root;$root =~ s!^\./!!;$root =~ s{^(.+?)/.*$}{$1};if (!length($root)){$root=shift(@others);redo FILE if$root}}system "$ar -dc $tarfile | $tar $x";return$root if -d $root;$self->diag_fail("Bad archive: $tarfile");return undef}}elsif (eval {require Archive::Tar}){$self->chat("Falling back to Archive::Tar $Archive::Tar::VERSION\n");$self->{_backends}{untar}=sub {my$self=shift;my$t=Archive::Tar->new($_[0]);my($root,@others)=$t->list_files;FILE: {$root =~ s!^\./!!;$root =~ s{^(.+?)/.*$}{$1};if (!length($root)){$root=shift(@others);redo FILE if$root}}$t->extract;return -d $root ? $root : undef}}else {$self->{_backends}{untar}=sub {die "Failed to extract $_[1] - You need to have tar or Archive::Tar installed.\n"}}if (my$unzip=$self->which('unzip')){$self->chat("You have $unzip\n");$self->{_backends}{unzip}=sub {my($self,$zipfile)=@_;my$opt=$self->{verbose}? '' : '-q';my(undef,$root,@others)=`$unzip -t $zipfile` or return undef;chomp$root;$root =~ s{^\s+testing:\s+([^/]+)/.*?\s+OK$}{$1};system "$unzip $opt $zipfile";return$root if -d $root;$self->diag_fail("Bad archive: [$root] $zipfile");return undef}}else {$self->{_backends}{unzip}=sub {eval {require Archive::Zip}or die "Failed to extract $_[1] - You need to have unzip or Archive::Zip installed.\n";my($self,$file)=@_;my$zip=Archive::Zip->new();my$status;$status=$zip->read($file);$self->diag_fail("Read of file[$file] failed")if$status!=Archive::Zip::AZ_OK();my@members=$zip->members();for my$member (@members){my$af=$member->fileName();next if ($af =~ m!^(/|\.\./)!);$status=$member->extractToFileNamed($af);$self->diag_fail("Extracting of file[$af] from zipfile[$file failed")if$status!=Archive::Zip::AZ_OK()}my ($root)=$zip->membersMatching(qr<^[^/]+/$>);$root &&=$root->fileName;return -d $root ? $root : undef}}}sub safeexec {my$self=shift;my$rdr=$_[0]||=Symbol::gensym();if (WIN32){my$cmd=$self->shell_quote(@_[1..$#_]);return open($rdr,"$cmd |")}if (my$pid=open($rdr,'-|')){return$pid}elsif (defined$pid){exec(@_[1 .. $#_ ]);exit 1}else {return}}sub mask_uri_passwords {my($self,@strings)=@_;s{ (https?://) ([^:/]+) : [^@/]+ @ }{$1$2:*password*@}gx for@strings;return@strings}sub parse_meta {my($self,$file)=@_;return eval {Parse::CPAN::Meta->load_file($file)}}sub parse_meta_string {my($self,$yaml)=@_;return eval {Parse::CPAN::Meta->load_yaml_string($yaml)}}package App::cpanminus::CommandExit;sub new {bless {code=>$_[1]},$_[0]}sub code {$_[0]->{code}}1; + It appears your cpanm executable was installed via `perlbrew install-cpanm`. + cpanm --self-upgrade won't upgrade the version of cpanm you're running. - 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; - } - } + Run the following command to get it upgraded. - $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"); - } + perlbrew install-cpanm - 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; - } + DIE + You are running cpanm from the path where your current perl won't install executables to. + Because of that, cpanm --self-upgrade won't upgrade the version of cpanm you're running. - sub search_module { - my($self, $module, $version) = @_; + cpanm path : $0 + Install path : $Config{installsitebin} - unless ($self->{mirror_only}) { - if ($self->{metacpan}) { - require JSON::PP; - $self->chat("Searching $module on metacpan ...\n"); - my $module_uri = "http://api.metacpan.org/module/$module"; - my $module_json = $self->get($module_uri); - my $module_meta = eval { JSON::PP::decode_json($module_json) }; - if ($module_meta && $module_meta->{distribution}) { - my $dist_uri = "http://api.metacpan.org/release/$module_meta->{distribution}"; - my $dist_json = $self->get($dist_uri); - my $dist_meta = eval { JSON::PP::decode_json($dist_json) }; - if ($dist_meta && $dist_meta->{download_url}) { - (my $distfile = $dist_meta->{download_url}) =~ s!.+/authors/id/!!; - local $self->{mirrors} = $self->{mirrors}; - if ($dist_meta->{stat}->{mtime} > time()-24*60*60) { - $self->{mirrors} = ['http://cpan.metacpan.org']; - } - return $self->cpan_module($module, $distfile, $dist_meta->{version}); - } - } - $self->diag_fail("Finding $module on metacpan failed."); - } - - $self->chat("Searching $module on cpanmetadb ...\n"); - my $uri = "http://cpanmetadb.plackperl.org/v1.0/package/$module"; - my $yaml = $self->get($uri); - my $meta = $self->parse_meta_string($yaml); - if ($meta && $meta->{distfile}) { - return $self->cpan_module($module, $meta->{distfile}, $meta->{version}); - } - - $self->diag_fail("Finding $module on cpanmetadb failed."); - - $self->chat("Searching $module on search.cpan.org ...\n"); - my $uri = "http://search.cpan.org/perldoc?$module"; - my $html = $self->get($uri); - $html =~ m!<a href="/CPAN/authors/id/(.*?\.(?:tar\.gz|tgz|tar\.bz2|zip))">! - and return $self->cpan_module($module, $1); - - $self->diag_fail("Finding $module on search.cpan.org failed."); - } - - 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 <<USAGE; + It means you either installed cpanm globally with system perl, or use distro packages such + as rpm or apt-get, and you have to use them again to upgrade cpanm. + DIE Usage: cpanm [options] Module [...] Try `cpanm --help` or `man cpanm` for more options. USAGE - } - - print <<HELP; Usage: cpanm [options] Module [...] Options: @@ -738,6 +91,7 @@ $fatpacked{"App/cpanminus/script.pm"} = <<'APP_CPANMINUS_SCRIPT'; --interactive Turns on interactive configure (required for Task:: modules) -f,--force force install -n,--notest Do not run unit tests + --test-only Run tests only, do not install -S,--sudo sudo to run install commands --installdeps Only install dependencies --showdeps Only display direct dependencies @@ -747,12 +101,14 @@ $fatpacked{"App/cpanminus/script.pm"} = <<'APP_CPANMINUS_SCRIPT'; --prompt Prompt when configure/build/test fails -l,--local-lib Specify the install base to install modules -L,--local-lib-contained Specify the install base to install all non-core modules + --self-contained Install all non-core modules, even if they're already installed. --auto-cleanup Number of days that cpanm's work directories expire in. Defaults to 7 Commands: --self-upgrade upgrades itself --info Displays distribution info on CPAN --look Opens the distribution with your SHELL + -U,--uninstall Uninstalls the modules (EXPERIMENTAL) -V,--version Displays software version Examples: @@ -774,639 +130,23 @@ $fatpacked{"App/cpanminus/script.pm"} = <<'APP_CPANMINUS_SCRIPT'; Type `man cpanm` or `perldoc cpanm` for the more detailed explanation of the options. HELP - - return 1; - } - - sub _writable { - my $dir = shift; - my @dir = File::Spec->splitdir($dir); - while (@dir) { - $dir = File::Spec->catdir(@dir); - if (-e $dir) { - return -w _; - } - pop @dir; - } - - return; - } - - sub maybe_abs { - my($self, $lib) = @_; - return $lib if $lib eq '_'; # special case: gh-113 - $lib =~ /^[~\/]/ ? $lib : File::Spec->canonpath(Cwd::cwd . "/$lib"); - } - - sub bootstrap_local_lib { - my $self = shift; - - # If -l is specified, use that. - if ($self->{local_lib}) { - return $self->setup_local_lib($self->{local_lib}); - } - - # root, locally-installed perl or --sudo: don't care about install_base - return if $self->{sudo} or (_writable($Config{installsitelib}) and _writable($Config{installsitebin})); - - # local::lib is configured in the shell -- yay - if ($ENV{PERL_MM_OPT} and ($ENV{MODULEBUILDRC} or $ENV{PERL_MB_OPT})) { - $self->bootstrap_local_lib_deps; - return; - } - - $self->setup_local_lib; - - $self->diag(<<DIAG); ! ! Can't write to $Config{installsitelib} and $Config{installsitebin}: Installing modules to $ENV{HOME}/perl5 ! To turn off this warning, you have to do one of the following: ! - run me as a root or with --sudo option (to install to $Config{installsitelib} and $Config{installsitebin}) - | - run me with --local-lib option e.g. cpanm --local-lib=~/perl5 - ! - Set PERL_CPANM_OPT="--local-lib=~/perl5" environment variable (in your shell rc file) - ! - Configure local::lib in your shell to set PERL_MM_OPT etc. + ! - Configure local::lib your existing local::lib in this shell to set PERL_MM_OPT etc. + ! - Install local::lib by running the following commands + ! + ! cpanm --local-lib=~/perl5 local::lib && eval \$(perl -I ~/perl5/lib/perl5/ -Mlocal::lib) ! DIAG - sleep 2; - } - - sub _core_only_inc { - my($self, $base) = @_; - require local::lib; - ( - local::lib->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) = @_; + WARNING: Your lib directory name ($base) contains a space in it. It's known to cause issues with perl builder tools such as local::lib and MakeMaker. You're recommended to rename your directory. + WARN + $module is not found in the following directories and can't be uninstalled. - my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ; - my $dispdef = defined $def ? "[$def] " : " "; - $def = defined $def ? $def : ""; + @{[ join(" \n", map " $_", @inc) ]} - if (!$self->{prompt} || (!$isa_tty && eof STDIN)) { - return $def; - } - - local $|=1; - local $\; - my $ans; - eval { - local $SIG{ALRM} = sub { undef $ans; die "alarm\n" }; - print STDOUT "$mess $dispdef"; - alarm $self->{prompt_timeout} if $self->{prompt_timeout}; - $ans = <STDIN>; - alarm 0; - }; - if ( defined $ans ) { - chomp $ans; - } else { # user hit ctrl-D or alarm timeout - print STDOUT "\n"; - } - - return (!defined $ans || $ans eq '') ? $def : $ans; - } - - sub diag_ok { - my($self, $msg) = @_; - chomp $msg; - $msg ||= "OK"; - if ($self->{in_progress}) { - $self->_diag("$msg\n"); - $self->{in_progress} = 0; - } - $self->log("-> $msg\n"); - } - - sub diag_fail { - my($self, $msg, $always) = @_; - chomp $msg; - if ($self->{in_progress}) { - $self->_diag("FAIL\n"); - $self->{in_progress} = 0; - } - - if ($msg) { - $self->_diag("! $msg\n", $always); - $self->log("-> FAIL $msg\n"); - } - } - - sub diag_progress { - my($self, $msg) = @_; - chomp $msg; - $self->{in_progress} = 1; - $self->_diag("$msg ... "); - $self->log("$msg\n"); - } - - sub _diag { - my($self, $msg, $always) = @_; - print STDERR $msg if $always or $self->{verbose} or !$self->{quiet}; - } - - sub diag { - my($self, $msg, $always) = @_; - $self->_diag($msg, $always); - $self->log($msg); - } - - sub chat { - my $self = shift; - print STDERR @_ if $self->{verbose}; - $self->log(@_); - } - - sub log { - my $self = shift; - open my $out, ">>$self->{log}"; - print $out @_; - } - - sub run { - my($self, $cmd) = @_; - - if (WIN32 && ref $cmd eq 'ARRAY') { - $cmd = join q{ }, map { $self->shell_quote($_) } @$cmd; - } - - if (ref $cmd eq 'ARRAY') { - my $pid = fork; - if ($pid) { - waitpid $pid, 0; - return !$?; - } else { - $self->run_exec($cmd); - } - } else { - unless ($self->{verbose}) { - $cmd .= " >> " . $self->shell_quote($self->{log}) . " 2>&1"; - } - !system $cmd; - } - } - - sub run_exec { - my($self, $cmd) = @_; - - if (ref $cmd eq 'ARRAY') { - unless ($self->{verbose}) { - open my $logfh, ">>", $self->{log}; - open STDERR, '>&', $logfh; - open STDOUT, '>&', $logfh; - close $logfh; - } - exec @$cmd; - } else { - unless ($self->{verbose}) { - $cmd .= " >> " . $self->shell_quote($self->{log}) . " 2>&1"; - } - exec $cmd; - } - } - - sub run_timeout { - my($self, $cmd, $timeout) = @_; - return $self->run($cmd) if WIN32 || $self->{verbose} || !$timeout; - - my $pid = fork; - if ($pid) { - eval { - local $SIG{ALRM} = sub { die "alarm\n" }; - alarm $timeout; - waitpid $pid, 0; - alarm 0; - }; - if ($@ && $@ eq "alarm\n") { - $self->diag_fail("Timed out (> ${timeout}s). Use --verbose to retry."); - local $SIG{TERM} = 'IGNORE'; - kill TERM => 0; - waitpid $pid, 0; - return; - } - return !$?; - } elsif ($pid == 0) { - $self->run_exec($cmd); - } else { - $self->chat("! fork failed: falling back to system()\n"); - $self->run($cmd); - } - } - - sub configure { - my($self, $cmd) = @_; - - # trick AutoInstall - local $ENV{PERL5_CPAN_IS_RUNNING} = local $ENV{PERL5_CPANPLUS_IS_RUNNING} = $$; - - # e.g. skip CPAN configuration on local::lib - local $ENV{PERL5_CPANM_IS_RUNNING} = $$; - - my $use_default = !$self->{interactive}; - local $ENV{PERL_MM_USE_DEFAULT} = $use_default; - - # skip man page generation - local $ENV{PERL_MM_OPT} = $ENV{PERL_MM_OPT}; - unless ($self->{pod2man}) { - $ENV{PERL_MM_OPT} .= " INSTALLMAN1DIR=none INSTALLMAN3DIR=none"; - } - - local $self->{verbose} = $self->{verbose} || $self->{interactive}; - $self->run_timeout($cmd, $self->{configure_timeout}); - } - - sub build { - my($self, $cmd, $distname) = @_; - - return 1 if $self->run_timeout($cmd, $self->{build_timeout}); - while (1) { - my $ans = lc $self->prompt("Building $distname failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?", "s"); - return if $ans eq 's'; - return $self->build($cmd, $distname) if $ans eq 'r'; - $self->show_build_log if $ans eq 'e'; - $self->look if $ans eq 'l'; - } - } - - sub test { - my($self, $cmd, $distname) = @_; - return 1 if $self->{notest}; - - # https://rt.cpan.org/Ticket/Display.html?id=48965#txn-1013385 - local $ENV{PERL_MM_USE_DEFAULT} = 1; - - return 1 if $self->run_timeout($cmd, $self->{test_timeout}); - if ($self->{force}) { - $self->diag_fail("Testing $distname failed but installing it anyway."); - return 1; - } else { - $self->diag_fail; - while (1) { - my $ans = lc $self->prompt("Testing $distname failed.\nYou can s)kip, r)etry, f)orce install, e)xamine build log, or l)ook ?", "s"); - return if $ans eq 's'; - return $self->test($cmd, $distname) if $ans eq 'r'; - return 1 if $ans eq 'f'; - $self->show_build_log if $ans eq 'e'; - $self->look if $ans eq 'l'; - } - } - } - - sub install { - my($self, $cmd, $uninst_opts) = @_; - - 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 <<EOF; + DIAG package ModuleBuildSkipMan; CHECK { if (%Module::Build::) { @@ -1417,880 +157,13 @@ $fatpacked{"App/cpanminus/script.pm"} = <<'APP_CPANMINUS_SCRIPT'; } 1; EOF - } - - sub check_module { - my($self, $mod, $want_ver) = @_; - - require Module::Metadata; - my $meta = Module::Metadata->new_from_module($mod, inc => $self->{search_inc}) - or return 0, undef; - - my $version = $meta->version; - - # When -L is in use, the version loaded from 'perl' library path - # might be newer than (or actually wasn't core at) the version - # that is shipped with the current perl - if ($self->{self_contained} && $self->loaded_from_perl_lib($meta)) { - require Module::CoreList; - unless (exists $Module::CoreList::version{$]+0}{$mod}) { - return 0, undef; - } - $version = $Module::CoreList::version{$]+0}{$mod}; - } - - $self->{local_versions}{$mod} = $version; - - if ($self->is_deprecated($meta)){ - return 0, $version; - } elsif (!$want_ver or $version >= version->new($want_ver)) { - return 1, ($version || 'undef'); - } else { - return 0, $version; - } - } - - sub is_deprecated { - my($self, $meta) = @_; - - my $deprecated = eval { - require Module::CoreList; - Module::CoreList::is_deprecated($meta->{module}); - }; - - return unless $deprecated; - return $self->loaded_from_perl_lib($meta); - } - - sub loaded_from_perl_lib { - my($self, $meta) = @_; - - require Config; - for my $dir (qw(archlibexp privlibexp)) { - my $confdir = $Config{$dir}; - if ($confdir eq substr($meta->filename, 0, length($confdir))) { - return 1; - } - } - - return; - } - - sub should_install { - my($self, $mod, $ver) = @_; - - $self->chat("Checking if you have $mod $ver ... "); - my($ok, $local) = $self->check_module($mod, $ver); - - if ($ok) { $self->chat("Yes ($local)\n") } - elsif ($local) { $self->chat("No ($local < $ver)\n") } - else { $self->chat("No\n") } - - return $mod unless $ok; - return; - } - - sub install_deps { - my($self, $dir, $depth, @deps) = @_; - - my(@install, %seen); - while (my($mod, $ver) = splice @deps, 0, 2) { - next if $seen{$mod} or $mod eq 'perl' or $mod eq 'Config'; - if ($self->should_install($mod, $ver)) { - push @install, [ $mod, $ver ]; - $seen{$mod} = 1; - } - } - - if (@install) { - $self->diag("==> Found dependencies: " . join(", ", map $_->[0], @install) . "\n"); - } - - my @fail; - for my $mod (@install) { - $self->install_module($mod->[0], $depth + 1, $mod->[1]) - or push @fail, $mod->[0]; - } - - $self->chdir($self->{base}); - $self->chdir($dir) if $dir; - - return @fail; - } - - sub install_deps_bailout { - my($self, $target, $dir, $depth, @deps) = @_; - - my @fail = $self->install_deps($dir, $depth, @deps); - if (@fail) { - unless ($self->prompt_bool("Installing the following dependencies failed:\n==> " . - join(", ", @fail) . "\nDo you want to continue building $target anyway?", "n")) { - $self->diag_fail("Bailing out the installation for $target. Retry with --prompt or --force.", 1); - return; - } - } - - return 1; - } - - sub build_stuff { - my($self, $stuff, $dist, $depth) = @_; - - my @config_deps; - if (!%{$dist->{meta} || {}} && -e 'META.yml') { - $self->chat("Checking configure dependencies from META.yml\n"); - $dist->{meta} = $self->parse_meta('META.yml'); - } - - if (!$dist->{meta} && $dist->{source} eq 'cpan') { - $self->chat("META.yml not found or unparsable. Fetching META.yml from search.cpan.org\n"); - $dist->{meta} = $self->fetch_meta_sco($dist); - } - - $dist->{meta} ||= {}; - - push @config_deps, %{$dist->{meta}{configure_requires} || {}}; - - my $target = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $dist->{dir}; - - $self->install_deps_bailout($target, $dist->{dir}, $depth, @config_deps) - or return; - - $self->diag_progress("Configuring $target"); - - my $configure_state = $self->configure_this($dist); - - $self->diag_ok($configure_state->{configured_ok} ? "OK" : "N/A"); - - my @deps = $self->find_prereqs($dist); - my $module_name = $self->find_module_name($configure_state) || $dist->{meta}{name}; - $module_name =~ s/-/::/g; - - if ($self->{showdeps}) { - my %rootdeps = (@config_deps, @deps); # merge - for my $mod (keys %rootdeps) { - my $ver = $rootdeps{$mod}; - print $mod, ($ver ? "~$ver" : ""), "\n"; - } - return 1; - } - - my $distname = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $stuff; - - my $walkup; - if ($self->{scandeps}) { - $walkup = $self->scandeps_append_child($dist); - } - - $self->install_deps_bailout($distname, $dist->{dir}, $depth, @deps) - or return; - - if ($self->{scandeps}) { - unless ($configure_state->{configured_ok}) { - my $diag = <<DIAG; ! Configuring $distname failed. See $self->{log} for details. ! You might have to install the following modules first to get --scandeps working correctly. DIAG - if (@config_deps) { - my @tree = @{$self->{scandeps_tree}}; - $diag .= "!\n" . join("", map "! * $_->[0]{module}\n", @tree[0..$#tree-1]) if @tree; - } - $self->diag("!\n$diag!\n", 1); - } - $walkup->(); - return 1; - } - - if ($self->{installdeps} && $depth == 0) { - if ($configure_state->{configured_ok}) { - $self->diag("<== Installed dependencies for $stuff. Finishing.\n"); - return 1; - } else { - $self->diag("! Configuring $distname failed. See $self->{log} for details.\n", 1); - return; - } - } - - my $installed; - if ($configure_state->{use_module_build} && -e 'Build' && -f _) { - my @switches = $self->{pod2man} ? () : ("-I$self->{base}", "-MModuleBuildSkipMan"); - $self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname); - $self->build([ $self->{perl}, @switches, "./Build" ], $distname) && - $self->test([ $self->{perl}, "./Build", "test" ], $distname) && - $self->install([ $self->{perl}, @switches, "./Build", "install" ], [ "--uninst", 1 ]) && - $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, "<MYMETA.json"; local $/; <$in> }; - my $mymeta = JSON::PP::decode_json($json); - if ($mymeta) { - $meta->{$_} = $mymeta->{$_} for qw(name version); - return $self->extract_requires($mymeta); - } - } - - if (-e 'MYMETA.yml') { - $self->chat("Checking dependencies from MYMETA.yml ...\n"); - my $mymeta = $self->parse_meta('MYMETA.yml'); - if ($mymeta) { - $meta->{$_} = $mymeta->{$_} for qw(name version); - return $self->extract_requires($mymeta); - } - } - - if (-e '_build/prereqs') { - $self->chat("Checking dependencies from _build/prereqs ...\n"); - my $mymeta = do { open my $in, "_build/prereqs"; $self->safe_eval(join "", <$in>) }; - @deps = $self->extract_requires($mymeta); - } elsif (-e 'Makefile') { - $self->chat("Finding PREREQ from Makefile ...\n"); - open my $mf, "Makefile"; - while (<$mf>) { - if (/^\#\s+PREREQ_PM => {\s*(.*?)\s*}/) { - my @all; - my @pairs = split ', ', $1; - for (@pairs) { - my ($pkg, $v) = split '=>', $_; - push @all, [ $pkg, $v ]; - } - my $list = join ", ", map { "'$_->[0]' => $_->[1]" } @all; - my $prereq = $self->safe_eval("no strict; +{ $list }"); - push @deps, %$prereq if $prereq; - last; - } - } - } - - return @deps; - } - - sub bundle_deps { - my($self, $dist) = @_; - - my @files; - File::Find::find({ - wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i }, - no_chdir => 1, - }, '.'); - - my @deps; - - for my $file (@files) { - open my $pod, "<", $file or next; - my $in_contents; - while (<$pod>) { - if (/^=head\d\s+CONTENTS/) { - $in_contents = 1; - } elsif (/^=/) { - $in_contents = 0; - } elsif ($in_contents) { - /^(\S+)\s*(\S+)?/ - and push @deps, $1, $self->maybe_version($2); - } - } - } - - return @deps; - } - - sub maybe_version { - my($self, $string) = @_; - return $string && $string =~ /^\.?\d/ ? $string : undef; - } - - sub extract_requires { - my($self, $meta) = @_; - - if ($meta->{'meta-spec'} && $meta->{'meta-spec'}{version} == 2) { - my @phase = $self->{notest} ? qw( build runtime ) : qw( build test runtime ); - my @deps = map { - my $p = $meta->{prereqs}{$_} || {}; - %{$p->{requires} || {}}; - } @phase; - return @deps; - } - - my @deps; - push @deps, %{$meta->{build_requires}} if $meta->{build_requires}; - push @deps, %{$meta->{requires}} if $meta->{requires}; - - return @deps; - } - - sub cleanup_workdirs { - my $self = shift; - - my $expire = time - 24 * 60 * 60 * $self->{auto_cleanup}; - my @targets; - - opendir my $dh, "$self->{home}/work"; - while (my $e = readdir $dh) { - next if $e !~ /^(\d+)\.\d+$/; # {UNIX time}.{PID} - my $time = $1; - if ($time < $expire) { - push @targets, "$self->{home}/work/$e"; - } - } - - if (@targets) { - $self->chat("Expiring ", scalar(@targets), " work directories.\n"); - File::Path::rmtree(\@targets, 0, 0); # safe = 0, since blib usually doesn't have write bits - } - } - - sub scandeps_append_child { - my($self, $dist) = @_; - - my $new_node = [ $dist, [] ]; - - my $curr_node = $self->{scandeps_current} || [ undef, $self->{scandeps_tree} ]; - push @{$curr_node->[1]}, $new_node; - - $self->{scandeps_current} = $new_node; - - return sub { $self->{scandeps_current} = $curr_node }; - } - - sub dump_scandeps { - my $self = shift; - - if ($self->{format} eq 'tree') { - $self->walk_down(sub { - my($dist, $depth) = @_; - if ($depth == 0) { - print "$dist->{distvname}\n"; - } else { - print " " x ($depth - 1); - print "\\_ $dist->{distvname}\n"; - } - }, 1); - } elsif ($self->{format} =~ /^dists?$/) { - $self->walk_down(sub { - my($dist, $depth) = @_; - print $self->format_dist($dist), "\n"; - }, 0); - } elsif ($self->{format} eq 'json') { - require JSON::PP; - print JSON::PP::encode_json($self->{scandeps_tree}); - } elsif ($self->{format} eq 'yaml') { - require YAML; - print YAML::Dump($self->{scandeps_tree}); - } else { - $self->diag("Unknown format: $self->{format}\n"); - } - } - - sub walk_down { - my($self, $cb, $pre) = @_; - $self->_do_walk_down($self->{scandeps_tree}, $cb, 0, $pre); - } - - sub _do_walk_down { - my($self, $children, $cb, $depth, $pre) = @_; - - # DFS - $pre determines when we call the callback - for my $node (@$children) { - $cb->($node->[0], $depth) if $pre; - $self->_do_walk_down($node->[1], $cb, $depth + 1, $pre); - $cb->($node->[0], $depth) unless $pre; - } - } - - sub DESTROY { - my $self = shift; - $self->{at_exit}->($self) if $self->{at_exit}; - } - - # Utils - - sub shell_quote { - my($self, $stuff) = @_; - $stuff =~ /^${quote}.+${quote}$/ ? $stuff : ($quote . $stuff . $quote); - } - - sub which { - my($self, $name) = @_; - my $exe_ext = $Config{_exe}; - for my $dir (File::Spec->path) { - my $fullpath = File::Spec->catfile($dir, $name); - if (-x $fullpath || -x ($fullpath .= $exe_ext)) { - if ($fullpath =~ /\s/ && $fullpath !~ /^$quote/) { - $fullpath = $self->shell_quote($fullpath); - } - return $fullpath; - } - } - return; - } - - sub get { $_[0]->{_backends}{get}->(@_) }; - sub mirror { $_[0]->{_backends}{mirror}->(@_) }; - sub untar { $_[0]->{_backends}{untar}->(@_) }; - sub unzip { $_[0]->{_backends}{unzip}->(@_) }; - - sub file_get { - my($self, $uri) = @_; - open my $fh, "<$uri" or return; - join '', <$fh>; - } - - sub file_mirror { - my($self, $uri, $path) = @_; - File::Copy::copy($uri, $path); - } - - sub init_tools { - my $self = shift; - - return if $self->{initialized}++; - - if ($self->{make} = $self->which($Config{make})) { - $self->chat("You have make $self->{make}\n"); - } - - # use --no-lwp if they have a broken LWP, to upgrade LWP - if ($self->{try_lwp} && eval { require LWP::UserAgent; LWP::UserAgent->VERSION(5.802) }) { - $self->chat("You have LWP $LWP::VERSION\n"); - my $ua = sub { - LWP::UserAgent->new( - parse_head => 0, - env_proxy => 1, - agent => "cpanminus/$VERSION", - timeout => 30, - @_, - ); - }; - $self->{_backends}{get} = sub { - my $self = shift; - my $res = $ua->()->request(HTTP::Request->new(GET => $_[0])); - return unless $res->is_success; - return $res->decoded_content; - }; - $self->{_backends}{mirror} = sub { - my $self = shift; - my $res = $ua->()->mirror(@_); - $res->code; - }; - } elsif ($self->{try_wget} and my $wget = $self->which('wget')) { - $self->chat("You have $wget\n"); - $self->{_backends}{get} = sub { - my($self, $uri) = @_; - return $self->file_get($uri) if $uri =~ s!^file:/+!/!; - $self->safeexec( my $fh, $wget, $uri, ( $self->{verbose} ? () : '-q' ), '-O', '-' ) or die "wget $uri: $!"; - local $/; - <$fh>; - }; - $self->{_backends}{mirror} = sub { - my($self, $uri, $path) = @_; - return $self->file_mirror($uri, $path) if $uri =~ s!^file:/+!/!; - $self->safeexec( my $fh, $wget, '--retry-connrefused', $uri, ( $self->{verbose} ? () : '-q' ), '-O', $path ) or die "wget $uri: $!"; - local $/; - <$fh>; - }; - } elsif ($self->{try_curl} and my $curl = $self->which('curl')) { - $self->chat("You have $curl\n"); - $self->{_backends}{get} = sub { - my($self, $uri) = @_; - return $self->file_get($uri) if $uri =~ s!^file:/+!/!; - $self->safeexec( my $fh, $curl, '-L', ( $self->{verbose} ? () : '-s' ), $uri ) or die "curl $uri: $!"; - local $/; - <$fh>; - }; - $self->{_backends}{mirror} = sub { - my($self, $uri, $path) = @_; - return $self->file_mirror($uri, $path) if $uri =~ s!^file:/+!/!; - $self->safeexec( my $fh, $curl, '-L', $uri, ( $self->{verbose} ? () : '-s' ), '-#', '-o', $path ) or die "curl $uri: $!"; - local $/; - <$fh>; - }; - } else { - require HTTP::Tiny; - $self->chat("Falling back to HTTP::Tiny $HTTP::Tiny::VERSION\n"); - - $self->{_backends}{get} = sub { - my $self = shift; - my $res = HTTP::Tiny->new->get($_[0]); - return unless $res->{success}; - return $res->{content}; - }; - $self->{_backends}{mirror} = sub { - my $self = shift; - my $res = HTTP::Tiny->new->mirror(@_); - return $res->{status}; - }; - } - - my $tar = $self->which('tar'); - my $tar_ver; - my $maybe_bad_tar = sub { WIN32 || SUNOS || (($tar_ver = `$tar --version 2>/dev/null`) =~ /GNU.*1\.13/i) }; - - if ($tar && !$maybe_bad_tar->()) { - chomp $tar_ver; - $self->chat("You have $tar: $tar_ver\n"); - $self->{_backends}{untar} = sub { - my($self, $tarfile) = @_; - - my $xf = "xf" . ($self->{verbose} ? 'v' : ''); - my $ar = $tarfile =~ /bz2$/ ? 'j' : 'z'; - - my($root, @others) = `$tar tf$ar $tarfile` - or return undef; - - chomp $root; - $root =~ s!^\./!!; - $root =~ s{^(.+?)/.*$}{$1}; - - system "$tar $xf$ar $tarfile"; - return $root if -d $root; - - $self->diag_fail("Bad archive: $tarfile"); - return undef; - } - } elsif ( $tar - and my $gzip = $self->which('gzip') - and my $bzip2 = $self->which('bzip2')) { - $self->chat("You have $tar, $gzip and $bzip2\n"); - $self->{_backends}{untar} = sub { - my($self, $tarfile) = @_; - - my $x = "x" . ($self->{verbose} ? 'v' : '') . "f -"; - my $ar = $tarfile =~ /bz2$/ ? $bzip2 : $gzip; - - my($root, @others) = `$ar -dc $tarfile | $tar tf -` - or return undef; - - chomp $root; - $root =~ s{^(.+?)/.*$}{$1}; - - system "$ar -dc $tarfile | $tar $x"; - return $root if -d $root; - - $self->diag_fail("Bad archive: $tarfile"); - return undef; - } - } elsif (eval { require Archive::Tar }) { # uses too much memory! - $self->chat("Falling back to Archive::Tar $Archive::Tar::VERSION\n"); - $self->{_backends}{untar} = sub { - my $self = shift; - my $t = Archive::Tar->new($_[0]); - my $root = ($t->list_files)[0]; - $root =~ s{^(.+?)/.*$}{$1}; - $t->extract; - return -d $root ? $root : undef; - }; - } else { - $self->{_backends}{untar} = sub { - die "Failed to extract $_[1] - You need to have tar or Archive::Tar installed.\n"; - }; - } - - if (my $unzip = $self->which('unzip')) { - $self->chat("You have $unzip\n"); - $self->{_backends}{unzip} = sub { - my($self, $zipfile) = @_; - - my $opt = $self->{verbose} ? '' : '-q'; - my(undef, $root, @others) = `$unzip -t $zipfile` - or return undef; - - chomp $root; - $root =~ s{^\s+testing:\s+(.+?)/\s+OK$}{$1}; - - system "$unzip $opt $zipfile"; - return $root if -d $root; - - $self->diag_fail("Bad archive: [$root] $zipfile"); - return undef; - } - } else { - $self->{_backends}{unzip} = sub { - eval { require Archive::Zip } - or die "Failed to extract $_[1] - You need to have unzip or Archive::Zip installed.\n"; - my($self, $file) = @_; - my $zip = Archive::Zip->new(); - my $status; - $status = $zip->read($file); - $self->diag_fail("Read of file[$file] failed") - if $status != Archive::Zip::AZ_OK(); - my @members = $zip->members(); - my $root; - for my $member ( @members ) { - my $af = $member->fileName(); - next if ($af =~ m!^(/|\.\./)!); - $root = $af unless $root; - $status = $member->extractToFileNamed( $af ); - $self->diag_fail("Extracting of file[$af] from zipfile[$file failed") - if $status != Archive::Zip::AZ_OK(); - } - return -d $root ? $root : undef; - }; - } - } - - sub safeexec { - my $self = shift; - my $rdr = $_[0] ||= Symbol::gensym(); - - if (WIN32) { - my $cmd = join q{ }, map { $self->shell_quote($_) } @_[ 1 .. $#_ ]; - return open( $rdr, "$cmd |" ); - } - - if ( my $pid = open( $rdr, '-|' ) ) { - return $pid; - } - elsif ( defined $pid ) { - exec( @_[ 1 .. $#_ ] ); - exit 1; - } - else { - return; - } - } - - sub parse_meta { - my($self, $file) = @_; - return eval { (Parse::CPAN::Meta::LoadFile($file))[0] } || undef; - } - - sub parse_meta_string { - my($self, $yaml) = @_; - return eval { (Parse::CPAN::Meta::Load($yaml))[0] } || undef; - } - - 1; APP_CPANMINUS_SCRIPT $fatpacked{"CPAN/DistnameInfo.pm"} = <<'CPAN_DISTNAMEINFO'; - - package CPAN::DistnameInfo; - - $VERSION = "0.11"; - use strict; - - sub distname_info { - my $file = shift or return; - - my ($dist, $version) = $file =~ /^ + package CPAN::DistnameInfo;$VERSION="0.12";use strict;sub distname_info {my$file=shift or return;my ($dist,$version)=$file =~ /^ ((?:[-+.]*(?:[A-Za-z0-9]+|(?<=\D)_|_(?=\D))* (?: [A-Za-z](?=[^A-Za-z]|$) @@ -2298,3398 +171,50 @@ $fatpacked{"CPAN/DistnameInfo.pm"} = <<'CPAN_DISTNAMEINFO'; \d(?=-) )(?<![._-][vV]) )+)(.*) - $/xs or return ($file,undef,undef); - - if ($dist =~ /-undef\z/ and ! length $version) { - $dist =~ s/-undef\z//; - } - - # Remove potential -withoutworldwriteables suffix - $version =~ s/-withoutworldwriteables$//; - - if ($version =~ /^(-[Vv].*)-(\d.*)/) { - - # Catch names like Unicode-Collate-Standard-V3_1_1-0.1 - # where the V3_1_1 is part of the distname - $dist .= $1; - $version = $2; - } - - # Normalize the Dist.pm-1.23 convention which CGI.pm and - # a few others use. - $dist =~ s{\.pm$}{}; - - $version = $1 - if !length $version and $dist =~ s/-(\d+\w)$//; - - $version = $1 . $version - if $version =~ /^\d+$/ and $dist =~ s/-(\w+)$//; - - if ($version =~ /\d\.\d/) { - $version =~ s/^[-_.]+//; - } - else { - $version =~ s/^[-_]+//; - } - - my $dev; - if (length $version) { - if ($file =~ /^perl-?\d+\.(\d+)(?:\D(\d+))?(-(?:TRIAL|RC)\d+)?$/) { - $dev = 1 if (($1 > 6 and $1 & 1) or ($2 and $2 >= 50)) or $3; - } - elsif ($version =~ /\d\D\d+_\d/ or $version =~ /-TRIAL/) { - $dev = 1; - } - } - else { - $version = undef; - } - - ($dist, $version, $dev); - } - - sub new { - my $class = shift; - my $distfile = shift; - - $distfile =~ s,//+,/,g; - - my %info = ( pathname => $distfile ); - - ($info{filename} = $distfile) =~ s,^(((.*?/)?authors/)?id/)?([A-Z])/(\4[A-Z])/(\5[-A-Z0-9]*)/,, - and $info{cpanid} = $6; - - if ($distfile =~ m,([^/]+)\.(tar\.(?:g?z|bz2)|zip|tgz)$,i) { # support more ? - $info{distvname} = $1; - $info{extension} = $2; - } - - @info{qw(dist version beta)} = distname_info($info{distvname}); - $info{maturity} = delete $info{beta} ? 'developer' : 'released'; - - return bless \%info, $class; - } - - sub dist { shift->{dist} } - sub version { shift->{version} } - sub maturity { shift->{maturity} } - sub filename { shift->{filename} } - sub cpanid { shift->{cpanid} } - sub distvname { shift->{distvname} } - sub extension { shift->{extension} } - sub pathname { shift->{pathname} } - - sub properties { %{ $_[0] } } - - 1; - - __END__ - + $/xs or return ($file,undef,undef);if ($dist =~ /-undef\z/ and!length$version){$dist =~ s/-undef\z//}$version =~ s/-withoutworldwriteables$//;if ($version =~ /^(-[Vv].*)-(\d.*)/){$dist .= $1;$version=$2}if ($version =~ /(.+_.*)-(\d.*)/){$dist .= $1;$version=$2}$dist =~ s{\.pm$}{};$version=$1 if!length$version and $dist =~ s/-(\d+\w)$//;$version=$1 .$version if$version =~ /^\d+$/ and $dist =~ s/-(\w+)$//;if ($version =~ /\d\.\d/){$version =~ s/^[-_.]+//}else {$version =~ s/^[-_]+//}my$dev;if (length$version){if ($file =~ /^perl-?\d+\.(\d+)(?:\D(\d+))?(-(?:TRIAL|RC)\d+)?$/){$dev=1 if (($1 > 6 and $1 & 1)or ($2 and $2 >= 50))or $3}elsif ($version =~ /\d\D\d+_\d/ or $version =~ /-TRIAL/){$dev=1}}else {$version=undef}($dist,$version,$dev)}sub new {my$class=shift;my$distfile=shift;$distfile =~ s,//+,/,g;my%info=(pathname=>$distfile);($info{filename}=$distfile)=~ s,^(((.*?/)?authors/)?id/)?([A-Z])/(\4[A-Z])/(\5[-A-Z0-9]*)/,, and $info{cpanid}=$6;if ($distfile =~ m,([^/]+)\.(tar\.(?:g?z|bz2)|zip|tgz)$,i){$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; 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__ - - + use 5.006;use strict;use warnings;package CPAN::Meta;our$VERSION='2.132510';use Carp qw(carp croak);use CPAN::Meta::Feature;use CPAN::Meta::Prereqs;use CPAN::Meta::Converter;use CPAN::Meta::Validator;use Parse::CPAN::Meta 1.4403 ();BEGIN {*_dclone=\&CPAN::Meta::Converter::_dclone}BEGIN {my@STRING_READERS=qw(abstract description dynamic_config generated_by name release_status version);no strict 'refs';for my$attr (@STRING_READERS){*$attr=sub {$_[0]{$attr }}}}BEGIN {my@LIST_READERS=qw(author keywords license);no strict 'refs';for my$attr (@LIST_READERS){*$attr=sub {my$value=$_[0]{$attr };croak "$attr must be called in list context" unless wantarray;return @{_dclone($value)}if ref$value;return$value}}}sub authors {$_[0]->author}sub licenses {$_[0]->license}BEGIN {my@MAP_READERS=qw(meta-spec resources provides no_index prereqs optional_features);no strict 'refs';for my$attr (@MAP_READERS){(my$subname=$attr)=~ s/-/_/;*$subname=sub {my$value=$_[0]{$attr };return _dclone($value)if$value;return {}}}}sub custom_keys {return grep {/^x_/i}keys %{$_[0]}}sub custom {my ($self,$attr)=@_;my$value=$self->{$attr};return _dclone($value)if ref$value;return$value}sub _new {my ($class,$struct,$options)=@_;my$self;if ($options->{lazy_validation}){my$cmc=CPAN::Meta::Converter->new($struct);$self=$cmc->convert(version=>2);return bless$self,$class}else {my$cmv=CPAN::Meta::Validator->new($struct);unless ($cmv->is_valid){die "Invalid metadata structure. Errors: " .join(", ",$cmv->errors)."\n"}}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}sub TO_JSON {return {%{$_[0]}}}1; CPAN_META +$fatpacked{"CPAN/Meta/Check.pm"} = <<'CPAN_META_CHECK'; + package CPAN::Meta::Check;{$CPAN::Meta::Check::VERSION='0.007'}use strict;use warnings;use Exporter 5.57 'import';our@EXPORT=qw//;our@EXPORT_OK=qw/check_requirements requirements_for verify_dependencies/;our%EXPORT_TAGS=(all=>[@EXPORT,@EXPORT_OK ]);use CPAN::Meta::Requirements 2.120920;use Module::Metadata;sub _check_dep {my ($reqs,$module,$dirs)=@_;my$version=$module eq 'perl' ? $] : do {my$metadata=Module::Metadata->new_from_module($module,inc=>$dirs);return "Module '$module' is not installed" if not defined$metadata;eval {$metadata->version}};return "Missing version info for module '$module'" if$reqs->requirements_for_module($module)and not $version;return sprintf 'Installed version (%s) of %s is not in range \'%s\'',$version,$module,$reqs->requirements_for_module($module)if not $reqs->accepts_module($module,$version || 0);return}sub _check_conflict {my ($reqs,$module,$dirs)=@_;my$metadata=Module::Metadata->new_from_module($module,inc=>$dirs);return if not defined$metadata;my$version=eval {$metadata->version};return "Missing version info for module '$module'" if not $version;return sprintf 'Installed version (%s) of %s is in range \'%s\'',$version,$module,$reqs->requirements_for_module($module)if$reqs->accepts_module($module,$version);return}sub requirements_for {my ($meta,$phases,$type)=@_;my$prereqs=ref($meta)eq 'CPAN::Meta' ? $meta->effective_prereqs : $meta;if (!ref$phases){return$prereqs->requirements_for($phases,$type)}else {my$ret=CPAN::Meta::Requirements->new;for my$phase (@{$phases}){$ret->add_requirements($prereqs->requirements_for($phase,$type))}return$ret}}sub check_requirements {my ($reqs,$type,$dirs)=@_;my%ret;if ($type ne 'conflicts'){for my$module ($reqs->required_modules){$ret{$module}=_check_dep($reqs,$module,$dirs)}}else {for my$module ($reqs->required_modules){$ret{$module}=_check_conflict($reqs,$module,$dirs)}}return \%ret}sub verify_dependencies {my ($meta,$phases,$type,$dirs)=@_;my$reqs=requirements_for($meta,$phases,$type);my$issues=check_requirements($reqs,$type,$dirs);return grep {defined}values %{$issues}}1; +CPAN_META_CHECK + $fatpacked{"CPAN/Meta/Converter.pm"} = <<'CPAN_META_CONVERTER'; - use 5.006; - use strict; - use warnings; - package CPAN::Meta::Converter; - BEGIN { - $CPAN::Meta::Converter::VERSION = '2.110930'; - } - # ABSTRACT: Convert CPAN distribution metadata structures - - - use CPAN::Meta::Validator; - use version 0.82 (); - use Parse::CPAN::Meta 1.4400 (); - - sub _dclone { - my $ref = shift; - my $backend = Parse::CPAN::Meta->json_backend(); - return $backend->new->decode( - $backend->new->convert_blessed->encode($ref) - ); - } - - my %known_specs = ( - '2' => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec', - '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html', - '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html', - '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html', - '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html', - '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html' - ); - - my @spec_list = sort { $a <=> $b } keys %known_specs; - my ($LOWEST, $HIGHEST) = @spec_list[0,-1]; - - #--------------------------------------------------------------------------# - # converters - # - # called as $converter->($element, $field_name, $full_meta, $to_version) - # - # defined return value used for field - # undef return value means field is skipped - #--------------------------------------------------------------------------# - - sub _keep { $_[0] } - - sub _keep_or_one { defined($_[0]) ? $_[0] : 1 } - - sub _keep_or_zero { defined($_[0]) ? $_[0] : 0 } - - sub _keep_or_unknown { defined($_[0]) && length($_[0]) ? $_[0] : "unknown" } - - sub _generated_by { - my $gen = shift; - my $sig = __PACKAGE__ . " version " . (__PACKAGE__->VERSION || "<dev>"); - - return $sig unless defined $gen and length $gen; - return $gen if $gen =~ /(, )\Q$sig/; - return "$gen, $sig"; - } - - sub _listify { ! defined $_[0] ? undef : ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]] } - - sub _prefix_custom { - my $key = shift; - $key =~ s/^(?!x_) # Unless it already starts with x_ + use 5.006;use strict;use warnings;package CPAN::Meta::Converter;our$VERSION='2.132510';use CPAN::Meta::Validator;use CPAN::Meta::Requirements;use version 0.88 ();use Parse::CPAN::Meta 1.4400 ();sub _dclone {my$ref=shift;no warnings 'once';local*UNIVERSAL::TO_JSON=sub {return "$_[0]"};my$backend=Parse::CPAN::Meta->json_backend();return$backend->new->utf8->decode($backend->new->utf8->allow_blessed->convert_blessed->encode($ref))}my%known_specs=('2'=>'http://search.cpan.org/perldoc?CPAN::Meta::Spec','1.4'=>'http://module-build.sourceforge.net/META-spec-v1.4.html','1.3'=>'http://module-build.sourceforge.net/META-spec-v1.3.html','1.2'=>'http://module-build.sourceforge.net/META-spec-v1.2.html','1.1'=>'http://module-build.sourceforge.net/META-spec-v1.1.html','1.0'=>'http://module-build.sourceforge.net/META-spec-v1.0.html');my@spec_list=sort {$a <=> $b}keys%known_specs;my ($LOWEST,$HIGHEST)=@spec_list[0,-1];sub _keep {$_[0]}sub _keep_or_one {defined($_[0])? $_[0]: 1}sub _keep_or_zero {defined($_[0])? $_[0]: 0}sub _keep_or_unknown {defined($_[0])&& length($_[0])? $_[0]: "unknown"}sub _generated_by {my$gen=shift;my$sig=__PACKAGE__ ." version " .(__PACKAGE__->VERSION || "<dev>");return$sig unless defined$gen and length$gen;return$gen if$gen =~ /(, )\Q$sig/;return "$gen, $sig"}sub _listify {!defined $_[0]? undef : ref $_[0]eq 'ARRAY' ? $_[0]: [$_[0]]}sub _prefix_custom {my$key=shift;$key =~ s/^(?!x_) # Unless it already starts with x_ (?:x-?)? # Remove leading x- or x (if present) - /x_/ix; # and prepend x_ - return $key; - } - - sub _ucfirst_custom { - my $key = shift; - $key = ucfirst $key unless $key =~ /[A-Z]/; - return $key; - } - - sub _change_meta_spec { - my ($element, undef, undef, $version) = @_; - $element->{version} = $version; - $element->{url} = $known_specs{$version}; - return $element; - } - - my @valid_licenses_1 = ( - 'perl', - 'gpl', - 'apache', - 'artistic', - 'artistic_2', - 'lgpl', - 'bsd', - 'gpl', - 'mit', - 'mozilla', - 'open_source', - 'unrestricted', - 'restrictive', - 'unknown', - ); - - my %license_map_1 = ( - ( map { $_ => $_ } @valid_licenses_1 ), - artistic2 => 'artistic_2', - ); - - sub _license_1 { - my ($element) = @_; - return 'unknown' unless defined $element; - if ( $license_map_1{lc $element} ) { - return $license_map_1{lc $element}; - } - return 'unknown'; - } - - my @valid_licenses_2 = qw( - agpl_3 - apache_1_1 - apache_2_0 - artistic_1 - artistic_2 - bsd - freebsd - gfdl_1_2 - gfdl_1_3 - gpl_1 - gpl_2 - gpl_3 - lgpl_2_1 - lgpl_3_0 - mit - mozilla_1_0 - mozilla_1_1 - openssl - perl_5 - qpl_1_0 - ssleay - sun - zlib - open_source - restricted - unrestricted - unknown - ); - - # The "old" values were defined by Module::Build, and were often vague. I have - # made the decisions below based on reading Module::Build::API and how clearly - # it specifies the version of the license. - my %license_map_2 = ( - (map { $_ => $_ } @valid_licenses_2), - apache => 'apache_2_0', # clearly stated as 2.0 - artistic => 'artistic_1', # clearly stated as 1 - artistic2 => 'artistic_2', # clearly stated as 2 - gpl => 'open_source', # we don't know which GPL; punt - lgpl => 'open_source', # we don't know which LGPL; punt - mozilla => 'open_source', # we don't know which MPL; punt - perl => 'perl_5', # clearly Perl 5 - restrictive => 'restricted', - ); - - sub _license_2 { - my ($element) = @_; - return [ 'unknown' ] unless defined $element; - $element = [ $element ] unless ref $element eq 'ARRAY'; - my @new_list; - for my $lic ( @$element ) { - next unless defined $lic; - if ( my $new = $license_map_2{lc $lic} ) { - push @new_list, $new; - } - } - return @new_list ? \@new_list : [ 'unknown' ]; - } - - my %license_downgrade_map = qw( - agpl_3 open_source - apache_1_1 apache - apache_2_0 apache - artistic_1 artistic - artistic_2 artistic_2 - bsd bsd - freebsd open_source - gfdl_1_2 open_source - gfdl_1_3 open_source - gpl_1 gpl - gpl_2 gpl - gpl_3 gpl - lgpl_2_1 lgpl - lgpl_3_0 lgpl - mit mit - mozilla_1_0 mozilla - mozilla_1_1 mozilla - openssl open_source - perl_5 perl - qpl_1_0 open_source - ssleay open_source - sun open_source - zlib open_source - open_source open_source - restricted restrictive - unrestricted unrestricted - unknown unknown - ); - - sub _downgrade_license { - my ($element) = @_; - if ( ! defined $element ) { - return "unknown"; - } - elsif( ref $element eq 'ARRAY' ) { - if ( @$element == 1 ) { - return $license_downgrade_map{$element->[0]} || "unknown"; - } - } - elsif ( ! ref $element ) { - return $license_downgrade_map{$element} || "unknown"; - } - return "unknown"; - } - - my $no_index_spec_1_2 = { - 'file' => \&_listify, - 'dir' => \&_listify, - 'package' => \&_listify, - 'namespace' => \&_listify, - }; - - my $no_index_spec_1_3 = { - 'file' => \&_listify, - 'directory' => \&_listify, - 'package' => \&_listify, - 'namespace' => \&_listify, - }; - - my $no_index_spec_2 = { - 'file' => \&_listify, - 'directory' => \&_listify, - 'package' => \&_listify, - 'namespace' => \&_listify, - ':custom' => \&_prefix_custom, - }; - - sub _no_index_1_2 { - my (undef, undef, $meta) = @_; - my $no_index = $meta->{no_index} || $meta->{private}; - return unless $no_index; - - # cleanup wrong format - if ( ! ref $no_index ) { - my $item = $no_index; - $no_index = { dir => [ $item ], file => [ $item ] }; - } - elsif ( ref $no_index eq 'ARRAY' ) { - my $list = $no_index; - $no_index = { dir => [ @$list ], file => [ @$list ] }; - } - - # common mistake: files -> file - if ( exists $no_index->{files} ) { - $no_index->{file} = delete $no_index->{file}; - } - # common mistake: modules -> module - if ( exists $no_index->{modules} ) { - $no_index->{module} = delete $no_index->{module}; - } - return _convert($no_index, $no_index_spec_1_2); - } - - sub _no_index_directory { - my ($element, $key, $meta, $version) = @_; - return unless $element; - - # cleanup wrong format - if ( ! ref $element ) { - my $item = $element; - $element = { directory => [ $item ], file => [ $item ] }; - } - elsif ( ref $element eq 'ARRAY' ) { - my $list = $element; - $element = { directory => [ @$list ], file => [ @$list ] }; - } - - if ( exists $element->{dir} ) { - $element->{directory} = delete $element->{dir}; - } - # common mistake: files -> file - if ( exists $element->{files} ) { - $element->{file} = delete $element->{file}; - } - # common mistake: modules -> module - if ( exists $element->{modules} ) { - $element->{module} = delete $element->{module}; - } - my $spec = $version == 2 ? $no_index_spec_2 : $no_index_spec_1_3; - return _convert($element, $spec); - } - - sub _is_module_name { - my $mod = shift; - return unless defined $mod && length $mod; - return $mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$}; - } - - sub _clean_version { - my ($element, $key, $meta, $to_version) = @_; - return 0 if ! defined $element; - - $element =~ s{^\s*}{}; - $element =~ s{\s*$}{}; - $element =~ s{^\.}{0.}; - - return 0 if ! length $element; - return 0 if ( $element eq 'undef' || $element eq '<undef>' ); - - if ( my $v = eval { version->new($element) } ) { - return $v->is_qv ? $v->normal : $element; - } - else { - return 0; - } - } - - sub _version_map { - my ($element) = @_; - return undef unless defined $element; - if ( ref $element eq 'HASH' ) { - my $new_map = {}; - for my $k ( keys %$element ) { - next unless _is_module_name($k); - my $value = $element->{$k}; - if ( ! ( defined $value && length $value ) ) { - $new_map->{$k} = 0; - } - elsif ( $value eq 'undef' || $value eq '<undef>' ) { - $new_map->{$k} = 0; - } - elsif ( _is_module_name( $value ) ) { # some weird, old META have this - $new_map->{$k} = 0; - $new_map->{$value} = 0; - } - else { - $new_map->{$k} = _clean_version($value); - } - } - return $new_map; - } - elsif ( ref $element eq 'ARRAY' ) { - my $hashref = { map { $_ => 0 } @$element }; - return _version_map($hashref); # cleanup any weird stuff - } - elsif ( ref $element eq '' && length $element ) { - return { $element => 0 } - } - return; - } - - sub _prereqs_from_1 { - my (undef, undef, $meta) = @_; - my $prereqs = {}; - for my $phase ( qw/build configure/ ) { - my $key = "${phase}_requires"; - $prereqs->{$phase}{requires} = _version_map($meta->{$key}) - if $meta->{$key}; - } - for my $rel ( qw/requires recommends conflicts/ ) { - $prereqs->{runtime}{$rel} = _version_map($meta->{$rel}) - if $meta->{$rel}; - } - return $prereqs; - } - - my $prereqs_spec = { - configure => \&_prereqs_rel, - build => \&_prereqs_rel, - test => \&_prereqs_rel, - runtime => \&_prereqs_rel, - develop => \&_prereqs_rel, - ':custom' => \&_prefix_custom, - }; - - my $relation_spec = { - requires => \&_version_map, - recommends => \&_version_map, - suggests => \&_version_map, - conflicts => \&_version_map, - ':custom' => \&_prefix_custom, - }; - - sub _cleanup_prereqs { - my ($prereqs, $key, $meta, $to_version) = @_; - return unless $prereqs && ref $prereqs eq 'HASH'; - return _convert( $prereqs, $prereqs_spec, $to_version ); - } - - sub _prereqs_rel { - my ($relation, $key, $meta, $to_version) = @_; - return unless $relation && ref $relation eq 'HASH'; - return _convert( $relation, $relation_spec, $to_version ); - } - - - BEGIN { - my @old_prereqs = qw( - requires - configure_requires - recommends - conflicts - ); - - for ( @old_prereqs ) { - my $sub = "_get_$_"; - my ($phase,$type) = split qr/_/, $_; - if ( ! defined $type ) { - $type = $phase; - $phase = 'runtime'; - } - no strict 'refs'; - *{$sub} = sub { _extract_prereqs($_[2]->{prereqs},$phase,$type) }; - } - } - - sub _get_build_requires { - my ($data, $key, $meta) = @_; - - my $test_h = _extract_prereqs($_[2]->{prereqs}, qw(test requires)) || {}; - my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {}; - - require Version::Requirements; - my $test_req = Version::Requirements->from_string_hash($test_h); - my $build_req = Version::Requirements->from_string_hash($build_h); - - $test_req->add_requirements($build_req)->as_string_hash; - } - - sub _extract_prereqs { - my ($prereqs, $phase, $type) = @_; - return unless ref $prereqs eq 'HASH'; - return $prereqs->{$phase}{$type}; - } - - sub _downgrade_optional_features { - my (undef, undef, $meta) = @_; - return undef unless exists $meta->{optional_features}; - my $origin = $meta->{optional_features}; - my $features = {}; - for my $name ( keys %$origin ) { - $features->{$name} = { - description => $origin->{$name}{description}, - requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','requires'), - configure_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'), - build_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'), - recommends => _extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'), - conflicts => _extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'), - }; - for my $k (keys %{$features->{$name}} ) { - delete $features->{$name}{$k} unless defined $features->{$name}{$k}; - } - } - return $features; - } - - sub _upgrade_optional_features { - my (undef, undef, $meta) = @_; - return undef unless exists $meta->{optional_features}; - my $origin = $meta->{optional_features}; - my $features = {}; - for my $name ( keys %$origin ) { - $features->{$name} = { - description => $origin->{$name}{description}, - prereqs => _prereqs_from_1(undef, undef, $origin->{$name}), - }; - delete $features->{$name}{prereqs}{configure}; - } - return $features; - } - - my $optional_features_2_spec = { - description => \&_keep, - prereqs => \&_cleanup_prereqs, - ':custom' => \&_prefix_custom, - }; - - sub _feature_2 { - my ($element, $key, $meta, $to_version) = @_; - return unless $element && ref $element eq 'HASH'; - _convert( $element, $optional_features_2_spec, $to_version ); - } - - sub _cleanup_optional_features_2 { - my ($element, $key, $meta, $to_version) = @_; - return unless $element && ref $element eq 'HASH'; - my $new_data = {}; - for my $k ( keys %$element ) { - $new_data->{$k} = _feature_2( $element->{$k}, $k, $meta, $to_version ); - } - return unless keys %$new_data; - return $new_data; - } - - sub _optional_features_1_4 { - my ($element) = @_; - return unless $element; - $element = _optional_features_as_map($element); - for my $name ( keys %$element ) { - for my $drop ( qw/requires_packages requires_os excluded_os/ ) { - delete $element->{$name}{$drop}; - } - } - return $element; - } - - sub _optional_features_as_map { - my ($element) = @_; - return unless $element; - if ( ref $element eq 'ARRAY' ) { - my %map; - for my $feature ( @$element ) { - my (@parts) = %$feature; - $map{$parts[0]} = $parts[1]; - } - $element = \%map; - } - return $element; - } - - sub _is_urlish { defined $_[0] && $_[0] =~ m{\A[-+.a-z0-9]+:.+}i } - - sub _url_or_drop { - my ($element) = @_; - return $element if _is_urlish($element); - return; - } - - sub _url_list { - my ($element) = @_; - return unless $element; - $element = _listify( $element ); - $element = [ grep { _is_urlish($_) } @$element ]; - return unless @$element; - return $element; - } - - sub _author_list { - my ($element) = @_; - return [ 'unknown' ] unless $element; - $element = _listify( $element ); - $element = [ map { defined $_ && length $_ ? $_ : 'unknown' } @$element ]; - return [ 'unknown' ] unless @$element; - return $element; - } - - my $resource2_upgrade = { - license => sub { return _is_urlish($_[0]) ? _listify( $_[0] ) : undef }, - homepage => \&_url_or_drop, - bugtracker => sub { - my ($item) = @_; - return unless $item; - if ( $item =~ m{^mailto:(.*)$} ) { return { mailto => $1 } } - elsif( _is_urlish($item) ) { return { web => $item } } - else { return undef } - }, - repository => sub { return _is_urlish($_[0]) ? { url => $_[0] } : undef }, - ':custom' => \&_prefix_custom, - }; - - sub _upgrade_resources_2 { - my (undef, undef, $meta, $version) = @_; - return undef unless exists $meta->{resources}; - return _convert($meta->{resources}, $resource2_upgrade); - } - - my $bugtracker2_spec = { - web => \&_url_or_drop, - mailto => \&_keep, - ':custom' => \&_prefix_custom, - }; - - sub _repo_type { - my ($element, $key, $meta, $to_version) = @_; - return $element if defined $element; - return unless exists $meta->{url}; - my $repo_url = $meta->{url}; - for my $type ( qw/git svn/ ) { - return $type if $repo_url =~ m{\A$type}; - } - return; - } - - my $repository2_spec = { - web => \&_url_or_drop, - url => \&_url_or_drop, - type => \&_repo_type, - ':custom' => \&_prefix_custom, - }; - - my $resources2_cleanup = { - license => \&_url_list, - homepage => \&_url_or_drop, - bugtracker => sub { ref $_[0] ? _convert( $_[0], $bugtracker2_spec ) : undef }, - repository => sub { my $data = shift; ref $data ? _convert( $data, $repository2_spec ) : undef }, - ':custom' => \&_prefix_custom, - }; - - sub _cleanup_resources_2 { - my ($resources, $key, $meta, $to_version) = @_; - return undef unless $resources && ref $resources eq 'HASH'; - return _convert($resources, $resources2_cleanup, $to_version); - } - - my $resource1_spec = { - license => \&_url_or_drop, - homepage => \&_url_or_drop, - bugtracker => \&_url_or_drop, - repository => \&_url_or_drop, - ':custom' => \&_keep, - }; - - sub _resources_1_3 { - my (undef, undef, $meta, $version) = @_; - return undef unless exists $meta->{resources}; - return _convert($meta->{resources}, $resource1_spec); - } - - *_resources_1_4 = *_resources_1_3; - - sub _resources_1_2 { - my (undef, undef, $meta) = @_; - my $resources = $meta->{resources} || {}; - if ( $meta->{license_url} && ! $resources->{license} ) { - $resources->{license} = $meta->license_url - if _is_urlish($meta->{license_url}); - } - return undef unless keys %$resources; - return _convert($resources, $resource1_spec); - } - - my $resource_downgrade_spec = { - license => sub { return ref $_[0] ? $_[0]->[0] : $_[0] }, - homepage => \&_url_or_drop, - bugtracker => sub { return $_[0]->{web} }, - repository => sub { return $_[0]->{url} || $_[0]->{web} }, - ':custom' => \&_ucfirst_custom, - }; - - sub _downgrade_resources { - my (undef, undef, $meta, $version) = @_; - return undef unless exists $meta->{resources}; - return _convert($meta->{resources}, $resource_downgrade_spec); - } - - sub _release_status { - my ($element, undef, $meta) = @_; - return $element if $element && $element =~ m{\A(?:stable|testing|unstable)\z}; - return _release_status_from_version(undef, undef, $meta); - } - - sub _release_status_from_version { - my (undef, undef, $meta) = @_; - my $version = $meta->{version} || ''; - return ( $version =~ /_/ ) ? 'testing' : 'stable'; - } - - my $provides_spec = { - file => \&_keep, - version => \&_clean_version, - }; - - my $provides_spec_2 = { - file => \&_keep, - version => \&_clean_version, - ':custom' => \&_prefix_custom, - }; - - sub _provides { - my ($element, $key, $meta, $to_version) = @_; - return unless defined $element && ref $element eq 'HASH'; - my $spec = $to_version == 2 ? $provides_spec_2 : $provides_spec; - my $new_data = {}; - for my $k ( keys %$element ) { - $new_data->{$k} = _convert($element->{$k}, $spec, $to_version); - } - return $new_data; - } - - sub _convert { - my ($data, $spec, $to_version) = @_; - - my $new_data = {}; - for my $key ( keys %$spec ) { - next if $key eq ':custom' || $key eq ':drop'; - next unless my $fcn = $spec->{$key}; - die "spec for '$key' is not a coderef" - unless ref $fcn && ref $fcn eq 'CODE'; - my $new_value = $fcn->($data->{$key}, $key, $data, $to_version); - $new_data->{$key} = $new_value if defined $new_value; - } - - my $drop_list = $spec->{':drop'}; - my $customizer = $spec->{':custom'} || \&_keep; - - for my $key ( keys %$data ) { - next if $drop_list && grep { $key eq $_ } @$drop_list; - next if exists $spec->{$key}; # we handled it - $new_data->{ $customizer->($key) } = $data->{$key}; - } - - return $new_data; - } - - #--------------------------------------------------------------------------# - # define converters for each conversion - #--------------------------------------------------------------------------# - - # each converts from prior version - # special ":custom" field is used for keys not recognized in spec - my %up_convert = ( - '2-from-1.4' => { - # PRIOR MANDATORY - 'abstract' => \&_keep_or_unknown, - 'author' => \&_author_list, - 'generated_by' => \&_generated_by, - 'license' => \&_license_2, - 'meta-spec' => \&_change_meta_spec, - 'name' => \&_keep, - 'version' => \&_keep, - # CHANGED TO MANDATORY - 'dynamic_config' => \&_keep_or_one, - # ADDED MANDATORY - 'release_status' => \&_release_status_from_version, - # PRIOR OPTIONAL - 'keywords' => \&_keep, - 'no_index' => \&_no_index_directory, - 'optional_features' => \&_upgrade_optional_features, - 'provides' => \&_provides, - 'resources' => \&_upgrade_resources_2, - # ADDED OPTIONAL - 'description' => \&_keep, - 'prereqs' => \&_prereqs_from_1, - - # drop these deprecated fields, but only after we convert - ':drop' => [ qw( - build_requires - configure_requires - conflicts - distribution_type - license_url - private - recommends - requires - ) ], - - # other random keys need x_ prefixing - ':custom' => \&_prefix_custom, - }, - '1.4-from-1.3' => { - # PRIOR MANDATORY - 'abstract' => \&_keep_or_unknown, - 'author' => \&_author_list, - 'generated_by' => \&_generated_by, - 'license' => \&_license_1, - 'meta-spec' => \&_change_meta_spec, - 'name' => \&_keep, - 'version' => \&_keep, - # PRIOR OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'keywords' => \&_keep, - 'no_index' => \&_no_index_directory, - 'optional_features' => \&_optional_features_1_4, - 'provides' => \&_provides, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - 'resources' => \&_resources_1_4, - # ADDED OPTIONAL - 'configure_requires' => \&_keep, - - # drop these deprecated fields, but only after we convert - ':drop' => [ qw( - license_url - private - )], - - # other random keys are OK if already valid - ':custom' => \&_keep - }, - '1.3-from-1.2' => { - # PRIOR MANDATORY - 'abstract' => \&_keep_or_unknown, - 'author' => \&_author_list, - 'generated_by' => \&_generated_by, - 'license' => \&_license_1, - 'meta-spec' => \&_change_meta_spec, - 'name' => \&_keep, - 'version' => \&_keep, - # PRIOR OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'keywords' => \&_keep, - 'no_index' => \&_no_index_directory, - 'optional_features' => \&_optional_features_as_map, - 'provides' => \&_provides, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - 'resources' => \&_resources_1_3, - - # drop these deprecated fields, but only after we convert - ':drop' => [ qw( - license_url - private - )], - - # other random keys are OK if already valid - ':custom' => \&_keep - }, - '1.2-from-1.1' => { - # PRIOR MANDATORY - 'version' => \&_keep, - # CHANGED TO MANDATORY - 'license' => \&_license_1, - 'name' => \&_keep, - 'generated_by' => \&_generated_by, - # ADDED MANDATORY - 'abstract' => \&_keep_or_unknown, - 'author' => \&_author_list, - 'meta-spec' => \&_change_meta_spec, - # PRIOR OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - # ADDED OPTIONAL - 'keywords' => \&_keep, - 'no_index' => \&_no_index_1_2, - 'optional_features' => \&_optional_features_as_map, - 'provides' => \&_provides, - 'resources' => \&_resources_1_2, - - # drop these deprecated fields, but only after we convert - ':drop' => [ qw( - license_url - private - )], - - # other random keys are OK if already valid - ':custom' => \&_keep - }, - '1.1-from-1.0' => { - # CHANGED TO MANDATORY - 'version' => \&_keep, - # IMPLIED MANDATORY - 'name' => \&_keep, - # PRIOR OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'generated_by' => \&_generated_by, - 'license' => \&_license_1, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - # ADDED OPTIONAL - 'license_url' => \&_url_or_drop, - 'private' => \&_keep, - - # other random keys are OK if already valid - ':custom' => \&_keep - }, - ); - - my %down_convert = ( - '1.4-from-2' => { - # MANDATORY - 'abstract' => \&_keep_or_unknown, - 'author' => \&_author_list, - 'generated_by' => \&_generated_by, - 'license' => \&_downgrade_license, - 'meta-spec' => \&_change_meta_spec, - 'name' => \&_keep, - 'version' => \&_keep, - # OPTIONAL - 'build_requires' => \&_get_build_requires, - 'configure_requires' => \&_get_configure_requires, - 'conflicts' => \&_get_conflicts, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'keywords' => \&_keep, - 'no_index' => \&_no_index_directory, - 'optional_features' => \&_downgrade_optional_features, - 'provides' => \&_provides, - 'recommends' => \&_get_recommends, - 'requires' => \&_get_requires, - 'resources' => \&_downgrade_resources, - - # drop these unsupported fields (after conversion) - ':drop' => [ qw( - description - prereqs - release_status - )], - - # custom keys will be left unchanged - ':custom' => \&_keep - }, - '1.3-from-1.4' => { - # MANDATORY - 'abstract' => \&_keep_or_unknown, - 'author' => \&_author_list, - 'generated_by' => \&_generated_by, - 'license' => \&_license_1, - 'meta-spec' => \&_change_meta_spec, - 'name' => \&_keep, - 'version' => \&_keep, - # OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'keywords' => \&_keep, - 'no_index' => \&_no_index_directory, - 'optional_features' => \&_optional_features_as_map, - 'provides' => \&_provides, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - 'resources' => \&_resources_1_3, - - # drop these unsupported fields, but only after we convert - ':drop' => [ qw( - configure_requires - )], - - # other random keys are OK if already valid - ':custom' => \&_keep, - }, - '1.2-from-1.3' => { - # MANDATORY - 'abstract' => \&_keep_or_unknown, - 'author' => \&_author_list, - 'generated_by' => \&_generated_by, - 'license' => \&_license_1, - 'meta-spec' => \&_change_meta_spec, - 'name' => \&_keep, - 'version' => \&_keep, - # OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'keywords' => \&_keep, - 'no_index' => \&_no_index_1_2, - 'optional_features' => \&_optional_features_as_map, - 'provides' => \&_provides, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - 'resources' => \&_resources_1_3, - - # other random keys are OK if already valid - ':custom' => \&_keep, - }, - '1.1-from-1.2' => { - # MANDATORY - 'version' => \&_keep, - # IMPLIED MANDATORY - 'name' => \&_keep, - 'meta-spec' => \&_change_meta_spec, - # OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'generated_by' => \&_generated_by, - 'license' => \&_license_1, - 'private' => \&_keep, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - - # drop unsupported fields - ':drop' => [ qw( - abstract - author - provides - no_index - keywords - resources - )], - - # other random keys are OK if already valid - ':custom' => \&_keep, - }, - '1.0-from-1.1' => { - # IMPLIED MANDATORY - 'name' => \&_keep, - 'meta-spec' => \&_change_meta_spec, - 'version' => \&_keep, - # PRIOR OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'generated_by' => \&_generated_by, - 'license' => \&_license_1, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - - # other random keys are OK if already valid - ':custom' => \&_keep, - }, - ); - - my %cleanup = ( - '2' => { - # PRIOR MANDATORY - 'abstract' => \&_keep_or_unknown, - 'author' => \&_author_list, - 'generated_by' => \&_generated_by, - 'license' => \&_license_2, - 'meta-spec' => \&_change_meta_spec, - 'name' => \&_keep, - 'version' => \&_keep, - # CHANGED TO MANDATORY - 'dynamic_config' => \&_keep_or_one, - # ADDED MANDATORY - 'release_status' => \&_release_status, - # PRIOR OPTIONAL - 'keywords' => \&_keep, - 'no_index' => \&_no_index_directory, - 'optional_features' => \&_cleanup_optional_features_2, - 'provides' => \&_provides, - 'resources' => \&_cleanup_resources_2, - # ADDED OPTIONAL - 'description' => \&_keep, - 'prereqs' => \&_cleanup_prereqs, - - # drop these deprecated fields, but only after we convert - ':drop' => [ qw( - build_requires - configure_requires - conflicts - distribution_type - license_url - private - recommends - requires - ) ], - - # other random keys need x_ prefixing - ':custom' => \&_prefix_custom, - }, - '1.4' => { - # PRIOR MANDATORY - 'abstract' => \&_keep_or_unknown, - 'author' => \&_author_list, - 'generated_by' => \&_generated_by, - 'license' => \&_license_1, - 'meta-spec' => \&_change_meta_spec, - 'name' => \&_keep, - 'version' => \&_keep, - # PRIOR OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'keywords' => \&_keep, - 'no_index' => \&_no_index_directory, - 'optional_features' => \&_optional_features_1_4, - 'provides' => \&_provides, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - 'resources' => \&_resources_1_4, - # ADDED OPTIONAL - 'configure_requires' => \&_keep, - - # other random keys are OK if already valid - ':custom' => \&_keep - }, - '1.3' => { - # PRIOR MANDATORY - 'abstract' => \&_keep_or_unknown, - 'author' => \&_author_list, - 'generated_by' => \&_generated_by, - 'license' => \&_license_1, - 'meta-spec' => \&_change_meta_spec, - 'name' => \&_keep, - 'version' => \&_keep, - # PRIOR OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'keywords' => \&_keep, - 'no_index' => \&_no_index_directory, - 'optional_features' => \&_optional_features_as_map, - 'provides' => \&_provides, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - 'resources' => \&_resources_1_3, - - # other random keys are OK if already valid - ':custom' => \&_keep - }, - '1.2' => { - # PRIOR MANDATORY - 'version' => \&_keep, - # CHANGED TO MANDATORY - 'license' => \&_license_1, - 'name' => \&_keep, - 'generated_by' => \&_generated_by, - # ADDED MANDATORY - 'abstract' => \&_keep_or_unknown, - 'author' => \&_author_list, - 'meta-spec' => \&_change_meta_spec, - # PRIOR OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - # ADDED OPTIONAL - 'keywords' => \&_keep, - 'no_index' => \&_no_index_1_2, - 'optional_features' => \&_optional_features_as_map, - 'provides' => \&_provides, - 'resources' => \&_resources_1_2, - - # other random keys are OK if already valid - ':custom' => \&_keep - }, - '1.1' => { - # CHANGED TO MANDATORY - 'version' => \&_keep, - # IMPLIED MANDATORY - 'name' => \&_keep, - 'meta-spec' => \&_change_meta_spec, - # PRIOR OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'generated_by' => \&_generated_by, - 'license' => \&_license_1, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - # ADDED OPTIONAL - 'license_url' => \&_url_or_drop, - 'private' => \&_keep, - - # other random keys are OK if already valid - ':custom' => \&_keep - }, - '1.0' => { - # IMPLIED MANDATORY - 'name' => \&_keep, - 'meta-spec' => \&_change_meta_spec, - 'version' => \&_keep, - # IMPLIED OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'generated_by' => \&_generated_by, - 'license' => \&_license_1, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - - # other random keys are OK if already valid - ':custom' => \&_keep, - }, - ); - - #--------------------------------------------------------------------------# - # Code - #--------------------------------------------------------------------------# - - - sub new { - my ($class,$data) = @_; - - # create an attributes hash - my $self = { - 'data' => $data, - 'spec' => $data->{'meta-spec'}{'version'} || "1.0", - }; - - # create the object - return bless $self, $class; - } - - - sub convert { - my ($self, %args) = @_; - my $args = { %args }; - - my $new_version = $args->{version} || $HIGHEST; - - my ($old_version) = $self->{spec}; - my $converted = _dclone($self->{data}); - - if ( $old_version == $new_version ) { - $converted = _convert( $converted, $cleanup{$old_version}, $old_version ); - my $cmv = CPAN::Meta::Validator->new( $converted ); - unless ( $cmv->is_valid ) { - my $errs = join("\n", $cmv->errors); - die "Failed to clean-up $old_version metadata. Errors:\n$errs\n"; - } - return $converted; - } - elsif ( $old_version > $new_version ) { - my @vers = sort { $b <=> $a } keys %known_specs; - for my $i ( 0 .. $#vers-1 ) { - next if $vers[$i] > $old_version; - last if $vers[$i+1] < $new_version; - my $spec_string = "$vers[$i+1]-from-$vers[$i]"; - $converted = _convert( $converted, $down_convert{$spec_string}, $vers[$i+1] ); - my $cmv = CPAN::Meta::Validator->new( $converted ); - unless ( $cmv->is_valid ) { - my $errs = join("\n", $cmv->errors); - die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n"; - } - } - return $converted; - } - else { - my @vers = sort { $a <=> $b } keys %known_specs; - for my $i ( 0 .. $#vers-1 ) { - next if $vers[$i] < $old_version; - last if $vers[$i+1] > $new_version; - my $spec_string = "$vers[$i+1]-from-$vers[$i]"; - $converted = _convert( $converted, $up_convert{$spec_string}, $vers[$i+1] ); - my $cmv = CPAN::Meta::Validator->new( $converted ); - unless ( $cmv->is_valid ) { - my $errs = join("\n", $cmv->errors); - die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n"; - } - } - return $converted; - } - } - - 1; - - - - - __END__ - - + /x_/ix;return$key}sub _ucfirst_custom {my$key=shift;$key=ucfirst$key unless$key =~ /[A-Z]/;return$key}sub _no_prefix_ucfirst_custom {my$key=shift;$key =~ s/^x_//;return _ucfirst_custom($key)}sub _change_meta_spec {my ($element,undef,undef,$version)=@_;$element->{version}=$version;$element->{url}=$known_specs{$version};return$element}my@valid_licenses_1=('perl','gpl','apache','artistic','artistic_2','lgpl','bsd','gpl','mit','mozilla','open_source','unrestricted','restrictive','unknown',);my%license_map_1=((map {$_=>$_}@valid_licenses_1),artistic2=>'artistic_2',);sub _license_1 {my ($element)=@_;return 'unknown' unless defined$element;if ($license_map_1{lc$element}){return$license_map_1{lc$element}}return 'unknown'}my@valid_licenses_2=qw(agpl_3 apache_1_1 apache_2_0 artistic_1 artistic_2 bsd freebsd gfdl_1_2 gfdl_1_3 gpl_1 gpl_2 gpl_3 lgpl_2_1 lgpl_3_0 mit mozilla_1_0 mozilla_1_1 openssl perl_5 qpl_1_0 ssleay sun zlib open_source restricted unrestricted unknown);my%license_map_2=((map {$_=>$_}@valid_licenses_2),apache=>'apache_2_0',artistic=>'artistic_1',artistic2=>'artistic_2',gpl=>'open_source',lgpl=>'open_source',mozilla=>'open_source',perl=>'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;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 ]}}if (exists$no_index->{files}){$no_index->{file}=delete$no_index->{file}}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;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}}if (exists$element->{files}){$element->{file}=delete$element->{file}}if (exists$element->{modules}){$element->{module}=delete$element->{module}}my$spec=$version==2 ? $no_index_spec_2 : $no_index_spec_1_3;return _convert($element,$spec)}sub _is_module_name {my$mod=shift;return unless defined$mod && length$mod;return$mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$}}sub _clean_version {my ($element)=@_;return 0 if!defined$element;$element =~ s{^\s*}{};$element =~ s{\s*$}{};$element =~ s{^\.}{0.};return 0 if!length$element;return 0 if ($element eq 'undef' || $element eq '<undef>');my$v=eval {version->new($element)};if (defined$v){return$v->is_qv ? $v->normal : $element}else {return 0}}sub _bad_version_hook {my ($v)=@_;$v =~ s{[a-z]+$}{};my$vobj=eval {version->parse($v)};return defined($vobj)? $vobj : version->parse(0)}sub _version_map {my ($element)=@_;return unless defined$element;if (ref$element eq 'HASH'){my$new_map=CPAN::Meta::Requirements->new({bad_version_hook=>sub {version->new(0)}});while (my ($k,$v)=each %$element){next unless _is_module_name($k);if (!defined($v)||!length($v)|| $v eq 'undef' || $v eq '<undef>'){$v=0}if (_is_module_name($v)&&!version::is_lax($v)){$new_map->add_minimum($k=>0);$new_map->add_minimum($v=>0)}$new_map->add_string_requirement($k=>$v)}return$new_map->as_string_hash}elsif (ref$element eq 'ARRAY'){my$hashref={map {$_=>0}@$element };return _version_map($hashref)}elsif (ref$element eq '' && length$element){return {$element=>0 }}return}sub _prereqs_from_1 {my (undef,undef,$meta)=@_;my$prereqs={};for my$phase (qw/build configure/){my$key="${phase}_requires";$prereqs->{$phase}{requires}=_version_map($meta->{$key})if$meta->{$key}}for my$rel (qw/requires recommends conflicts/){$prereqs->{runtime}{$rel}=_version_map($meta->{$rel})if$meta->{$rel}}return$prereqs}my$prereqs_spec={configure=>\&_prereqs_rel,build=>\&_prereqs_rel,test=>\&_prereqs_rel,runtime=>\&_prereqs_rel,develop=>\&_prereqs_rel,':custom'=>\&_prefix_custom,};my$relation_spec={requires=>\&_version_map,recommends=>\&_version_map,suggests=>\&_version_map,conflicts=>\&_version_map,':custom'=>\&_prefix_custom,};sub _cleanup_prereqs {my ($prereqs,$key,$meta,$to_version)=@_;return unless$prereqs && ref$prereqs eq 'HASH';return _convert($prereqs,$prereqs_spec,$to_version)}sub _prereqs_rel {my ($relation,$key,$meta,$to_version)=@_;return unless$relation && ref$relation eq 'HASH';return _convert($relation,$relation_spec,$to_version)}BEGIN {my@old_prereqs=qw(requires configure_requires recommends conflicts);for (@old_prereqs){my$sub="_get_$_";my ($phase,$type)=split qr/_/,$_;if (!defined$type){$type=$phase;$phase='runtime'}no strict 'refs';*{$sub}=sub {_extract_prereqs($_[2]->{prereqs},$phase,$type)}}}sub _get_build_requires {my ($data,$key,$meta)=@_;my$test_h=_extract_prereqs($_[2]->{prereqs},qw(test requires))|| {};my$build_h=_extract_prereqs($_[2]->{prereqs},qw(build requires))|| {};my$test_req=CPAN::Meta::Requirements->from_string_hash($test_h);my$build_req=CPAN::Meta::Requirements->from_string_hash($build_h);$test_req->add_requirements($build_req)->as_string_hash}sub _extract_prereqs {my ($prereqs,$phase,$type)=@_;return unless ref$prereqs eq 'HASH';return scalar _version_map($prereqs->{$phase}{$type})}sub _downgrade_optional_features {my (undef,undef,$meta)=@_;return unless exists$meta->{optional_features};my$origin=$meta->{optional_features};my$features={};for my$name (keys %$origin){$features->{$name}={description=>$origin->{$name}{description},requires=>_extract_prereqs($origin->{$name}{prereqs},'runtime','requires'),configure_requires=>_extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'),build_requires=>_extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'),recommends=>_extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'),conflicts=>_extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'),};for my$k (keys %{$features->{$name}}){delete$features->{$name}{$k}unless defined$features->{$name}{$k}}}return$features}sub _upgrade_optional_features {my (undef,undef,$meta)=@_;return unless exists$meta->{optional_features};my$origin=$meta->{optional_features};my$features={};for my$name (keys %$origin){$features->{$name}={description=>$origin->{$name}{description},prereqs=>_prereqs_from_1(undef,undef,$origin->{$name}),};delete$features->{$name}{prereqs}{configure}}return$features}my$optional_features_2_spec={description=>\&_keep,prereqs=>\&_cleanup_prereqs,':custom'=>\&_prefix_custom,};sub _feature_2 {my ($element,$key,$meta,$to_version)=@_;return unless$element && ref$element eq 'HASH';_convert($element,$optional_features_2_spec,$to_version)}sub _cleanup_optional_features_2 {my ($element,$key,$meta,$to_version)=@_;return unless$element && ref$element eq 'HASH';my$new_data={};for my$k (keys %$element){$new_data->{$k}=_feature_2($element->{$k},$k,$meta,$to_version)}return unless keys %$new_data;return$new_data}sub _optional_features_1_4 {my ($element)=@_;return unless$element;$element=_optional_features_as_map($element);for my$name (keys %$element){for my$drop (qw/requires_packages requires_os excluded_os/){delete$element->{$name}{$drop}}}return$element}sub _optional_features_as_map {my ($element)=@_;return unless$element;if (ref$element eq 'ARRAY'){my%map;for my$feature (@$element){my (@parts)=%$feature;$map{$parts[0]}=$parts[1]}$element=\%map}return$element}sub _is_urlish {defined $_[0]&& $_[0]=~ m{\A[-+.a-z0-9]+:.+}i}sub _url_or_drop {my ($element)=@_;return$element if _is_urlish($element);return}sub _url_list {my ($element)=@_;return unless$element;$element=_listify($element);$element=[grep {_is_urlish($_)}@$element ];return unless @$element;return$element}sub _author_list {my ($element)=@_;return ['unknown' ]unless$element;$element=_listify($element);$element=[map {defined $_ && length $_ ? $_ : 'unknown'}@$element ];return ['unknown' ]unless @$element;return$element}my$resource2_upgrade={license=>sub {return _is_urlish($_[0])? _listify($_[0]): undef},homepage=>\&_url_or_drop,bugtracker=>sub {my ($item)=@_;return unless$item;if ($item =~ m{^mailto:(.*)$}){return {mailto=>$1 }}elsif(_is_urlish($item)){return {web=>$item }}else {return}},repository=>sub {return _is_urlish($_[0])? {url=>$_[0]}: undef},':custom'=>\&_prefix_custom,};sub _upgrade_resources_2 {my (undef,undef,$meta,$version)=@_;return unless exists$meta->{resources};return _convert($meta->{resources},$resource2_upgrade)}my$bugtracker2_spec={web=>\&_url_or_drop,mailto=>\&_keep,':custom'=>\&_prefix_custom,};sub _repo_type {my ($element,$key,$meta,$to_version)=@_;return$element if defined$element;return unless exists$meta->{url};my$repo_url=$meta->{url};for my$type (qw/git svn/){return$type if$repo_url =~ m{\A$type}}return}my$repository2_spec={web=>\&_url_or_drop,url=>\&_url_or_drop,type=>\&_repo_type,':custom'=>\&_prefix_custom,};my$resources2_cleanup={license=>\&_url_list,homepage=>\&_url_or_drop,bugtracker=>sub {ref $_[0]? _convert($_[0],$bugtracker2_spec): undef},repository=>sub {my$data=shift;ref$data ? _convert($data,$repository2_spec): undef},':custom'=>\&_prefix_custom,};sub _cleanup_resources_2 {my ($resources,$key,$meta,$to_version)=@_;return unless$resources && ref$resources eq 'HASH';return _convert($resources,$resources2_cleanup,$to_version)}my$resource1_spec={license=>\&_url_or_drop,homepage=>\&_url_or_drop,bugtracker=>\&_url_or_drop,repository=>\&_url_or_drop,':custom'=>\&_keep,};sub _resources_1_3 {my (undef,undef,$meta,$version)=@_;return unless exists$meta->{resources};return _convert($meta->{resources},$resource1_spec)}*_resources_1_4=*_resources_1_3;sub _resources_1_2 {my (undef,undef,$meta)=@_;my$resources=$meta->{resources}|| {};if ($meta->{license_url}&&!$resources->{license}){$resources->{license}=$meta->license_url if _is_urlish($meta->{license_url})}return unless keys %$resources;return _convert($resources,$resource1_spec)}my$resource_downgrade_spec={license=>sub {return ref $_[0]? $_[0]->[0]: $_[0]},homepage=>\&_url_or_drop,bugtracker=>sub {return $_[0]->{web}},repository=>sub {return $_[0]->{url}|| $_[0]->{web}},':custom'=>\&_no_prefix_ucfirst_custom,};sub _downgrade_resources {my (undef,undef,$meta,$version)=@_;return unless exists$meta->{resources};return _convert($meta->{resources},$resource_downgrade_spec)}sub _release_status {my ($element,undef,$meta)=@_;return$element if$element && $element =~ m{\A(?:stable|testing|unstable)\z};return _release_status_from_version(undef,undef,$meta)}sub _release_status_from_version {my (undef,undef,$meta)=@_;my$version=$meta->{version}|| '';return ($version =~ /_/)? 'testing' : 'stable'}my$provides_spec={file=>\&_keep,version=>\&_keep,};my$provides_spec_2={file=>\&_keep,version=>\&_keep,':custom'=>\&_prefix_custom,};sub _provides {my ($element,$key,$meta,$to_version)=@_;return unless defined$element && ref$element eq 'HASH';my$spec=$to_version==2 ? $provides_spec_2 : $provides_spec;my$new_data={};for my$k (keys %$element){$new_data->{$k}=_convert($element->{$k},$spec,$to_version);$new_data->{$k}{version}=_clean_version($element->{$k}{version})if exists$element->{$k}{version}}return$new_data}sub _convert {my ($data,$spec,$to_version)=@_;my$new_data={};for my$key (keys %$spec){next if$key eq ':custom' || $key eq ':drop';next unless my$fcn=$spec->{$key};die "spec for '$key' is not a coderef" unless ref$fcn && ref$fcn eq 'CODE';my$new_value=$fcn->($data->{$key},$key,$data,$to_version);$new_data->{$key}=$new_value if defined$new_value}my$drop_list=$spec->{':drop'};my$customizer=$spec->{':custom'}|| \&_keep;for my$key (keys %$data){next if$drop_list && grep {$key eq $_}@$drop_list;next if exists$spec->{$key};$new_data->{$customizer->($key)}=$data->{$key}}return$new_data}my%up_convert=('2-from-1.4'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_2,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'release_status'=>\&_release_status_from_version,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_upgrade_optional_features,'provides'=>\&_provides,'resources'=>\&_upgrade_resources_2,'description'=>\&_keep,'prereqs'=>\&_prereqs_from_1,':drop'=>[qw(build_requires configure_requires conflicts distribution_type license_url private recommends requires) ],':custom'=>\&_prefix_custom,},'1.4-from-1.3'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'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,'configure_requires'=>\&_keep,':drop'=>[qw(license_url private)],':custom'=>\&_keep },'1.3-from-1.2'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'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'=>[qw(license_url private)],':custom'=>\&_keep },'1.2-from-1.1'=>{'version'=>\&_keep,'license'=>\&_license_1,'name'=>\&_keep,'generated_by'=>\&_generated_by,'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'meta-spec'=>\&_change_meta_spec,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'recommends'=>\&_version_map,'requires'=>\&_version_map,'keywords'=>\&_keep,'no_index'=>\&_no_index_1_2,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'resources'=>\&_resources_1_2,':drop'=>[qw(license_url private)],':custom'=>\&_keep },'1.1-from-1.0'=>{'version'=>\&_keep,'name'=>\&_keep,'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,'license_url'=>\&_url_or_drop,'private'=>\&_keep,':custom'=>\&_keep },);my%down_convert=('1.4-from-2'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_downgrade_license,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'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'=>[qw(description prereqs release_status)],':custom'=>\&_keep },'1.3-from-1.4'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'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'=>[qw(configure_requires)],':custom'=>\&_keep,},'1.2-from-1.3'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'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,':custom'=>\&_keep,},'1.1-from-1.2'=>{'version'=>\&_keep,'name'=>\&_keep,'meta-spec'=>\&_change_meta_spec,'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'=>[qw(abstract author provides no_index keywords resources)],':custom'=>\&_keep,},'1.0-from-1.1'=>{'name'=>\&_keep,'meta-spec'=>\&_change_meta_spec,'version'=>\&_keep,'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,':custom'=>\&_keep,},);my%cleanup=('2'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_2,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'release_status'=>\&_release_status,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_cleanup_optional_features_2,'provides'=>\&_provides,'resources'=>\&_cleanup_resources_2,'description'=>\&_keep,'prereqs'=>\&_cleanup_prereqs,':drop'=>[qw(build_requires configure_requires conflicts distribution_type license_url private recommends requires) ],':custom'=>\&_prefix_custom,},'1.4'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'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,'configure_requires'=>\&_keep,':custom'=>\&_keep },'1.3'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'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,':custom'=>\&_keep },'1.2'=>{'version'=>\&_keep,'license'=>\&_license_1,'name'=>\&_keep,'generated_by'=>\&_generated_by,'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'meta-spec'=>\&_change_meta_spec,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'recommends'=>\&_version_map,'requires'=>\&_version_map,'keywords'=>\&_keep,'no_index'=>\&_no_index_1_2,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'resources'=>\&_resources_1_2,':custom'=>\&_keep },'1.1'=>{'version'=>\&_keep,'name'=>\&_keep,'meta-spec'=>\&_change_meta_spec,'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,'license_url'=>\&_url_or_drop,'private'=>\&_keep,':custom'=>\&_keep },'1.0'=>{'name'=>\&_keep,'meta-spec'=>\&_change_meta_spec,'version'=>\&_keep,'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,':custom'=>\&_keep,},);sub new {my ($class,$data)=@_;my$self={'data'=>$data,'spec'=>$data->{'meta-spec'}{'version'}|| "1.0",};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; 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__ - - - + use 5.006;use strict;use warnings;package CPAN::Meta::Feature;our$VERSION='2.132510';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; 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 - + use 5.006;use strict;use warnings;package CPAN::Meta::History;our$VERSION='2.132510';1; 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__ - - - + use 5.006;use strict;use warnings;package CPAN::Meta::Prereqs;our$VERSION='2.132510';use Carp qw(confess);use Scalar::Util qw(blessed);use CPAN::Meta::Requirements 2.121;sub __legal_phases {qw(configure build test runtime develop)}sub __legal_types {qw(requires recommends suggests conflicts)}sub new {my ($class,$prereq_spec)=@_;$prereq_spec ||={};my%is_legal_phase=map {;$_=>1}$class->__legal_phases;my%is_legal_type=map {;$_=>1}$class->__legal_types;my%guts;PHASE: for my$phase (keys %$prereq_spec){next PHASE unless$phase =~ /\Ax_/i or $is_legal_phase{$phase};my$phase_spec=$prereq_spec->{$phase };next PHASE unless keys %$phase_spec;TYPE: for my$type (keys %$phase_spec){next TYPE unless$type =~ /\Ax_/i or $is_legal_type{$type};my$spec=$phase_spec->{$type };next TYPE unless keys %$spec;$guts{prereqs}{$phase}{$type}=CPAN::Meta::Requirements->from_string_hash($spec)}}return bless \%guts=>$class}sub requirements_for {my ($self,$phase,$type)=@_;confess "requirements_for called without phase" unless defined$phase;confess "requirements_for called without type" unless defined$type;unless ($phase =~ /\Ax_/i or grep {$phase eq $_}$self->__legal_phases){confess "requested requirements for unknown phase: $phase"}unless ($type =~ /\Ax_/i or grep {$type eq $_}$self->__legal_types){confess "requested requirements for unknown type: $type"}my$req=($self->{prereqs}{$phase}{$type}||=CPAN::Meta::Requirements->new);$req->finalize if$self->is_finalized;return$req}sub with_merged_prereqs {my ($self,$other)=@_;my@other=blessed($other)? $other : @$other;my@prereq_objs=($self,@other);my%new_arg;for my$phase ($self->__legal_phases){for my$type ($self->__legal_types){my$req=CPAN::Meta::Requirements->new;for my$prereq (@prereq_objs){my$this_req=$prereq->requirements_for($phase,$type);next unless$this_req->required_modules;$req->add_requirements($this_req)}next unless$req->required_modules;$new_arg{$phase }{$type }=$req->as_string_hash}}return (ref$self)->new(\%new_arg)}sub as_string_hash {my ($self)=@_;my%hash;for my$phase ($self->__legal_phases){for my$type ($self->__legal_types){my$req=$self->requirements_for($phase,$type);next unless$req->required_modules;$hash{$phase }{$type }=$req->as_string_hash}}return \%hash}sub is_finalized {$_[0]{finalized}}sub finalize {my ($self)=@_;$self->{finalized}=1;for my$phase (keys %{$self->{prereqs}}){$_->finalize for values %{$self->{prereqs}{$phase}}}}sub clone {my ($self)=@_;my$clone=(ref$self)->new($self->as_string_hash)}1; CPAN_META_PREREQS +$fatpacked{"CPAN/Meta/Requirements.pm"} = <<'CPAN_META_REQUIREMENTS'; + use strict;use warnings;package CPAN::Meta::Requirements;our$VERSION='2.123';use Carp ();use Scalar::Util ();use version 0.77 ();my@valid_options=qw(bad_version_hook);sub new {my ($class,$options)=@_;$options ||={};Carp::croak "Argument to $class\->new() must be a hash reference" unless ref$options eq 'HASH';my%self=map {;$_=>$options->{$_}}@valid_options;return bless \%self=>$class}sub _version_object {my ($self,$version)=@_;my$vobj;eval {$vobj=(!defined$version)? version->parse(0): (!Scalar::Util::blessed($version))? version->parse($version): $version};if (my$err=$@){my$hook=$self->{bad_version_hook};$vobj=eval {$hook->($version)}if ref$hook eq 'CODE';unless (Scalar::Util::blessed($vobj)&& $vobj->isa("version")){$err =~ s{ at .* line \d+.*$}{};die "Can't convert '$version': $err"}}if ($vobj =~ m{\A\.}){$vobj=version->parse("0$vobj")}if ($vobj->is_qv){$vobj=version->parse($vobj->normal)}return$vobj}BEGIN {for my$type (qw(minimum maximum exclusion exact_version)){my$method="with_$type";my$to_add=$type eq 'exact_version' ? $type : "add_$type";my$code=sub {my ($self,$name,$version)=@_;$version=$self->_version_object($version);$self->__modify_entry_for($name,$method,$version);return$self};no strict 'refs';*$to_add=$code}}sub add_requirements {my ($self,$req)=@_;for my$module ($req->required_modules){my$modifiers=$req->__entry_for($module)->as_modifiers;for my$modifier (@$modifiers){my ($method,@args)=@$modifier;$self->$method($module=>@args)}}return$self}sub accepts_module {my ($self,$module,$version)=@_;$version=$self->_version_object($version);return 1 unless my$range=$self->__entry_for($module);return$range->_accepts($version)}sub clear_requirement {my ($self,$module)=@_;return$self unless$self->__entry_for($module);Carp::confess("can't clear requirements on finalized requirements")if$self->is_finalized;delete$self->{requirements}{$module };return$self}sub requirements_for_module {my ($self,$module)=@_;my$entry=$self->__entry_for($module);return unless$entry;return$entry->as_string}sub required_modules {keys %{$_[0]{requirements}}}sub clone {my ($self)=@_;my$new=(ref$self)->new;return$new->add_requirements($self)}sub __entry_for {$_[0]{requirements}{$_[1]}}sub __modify_entry_for {my ($self,$name,$method,$version)=@_;my$fin=$self->is_finalized;my$old=$self->__entry_for($name);Carp::confess("can't add new requirements to finalized requirements")if$fin and not $old;my$new=($old || 'CPAN::Meta::Requirements::_Range::Range')->$method($version);Carp::confess("can't modify finalized requirements")if$fin and $old->as_string ne $new->as_string;$self->{requirements}{$name }=$new}sub is_simple {my ($self)=@_;for my$module ($self->required_modules){return if$self->__entry_for($module)->as_string =~ /\s/}return 1}sub is_finalized {$_[0]{finalized}}sub finalize {$_[0]{finalized}=1}sub as_string_hash {my ($self)=@_;my%hash=map {;$_=>$self->{requirements}{$_}->as_string}$self->required_modules;return \%hash}my%methods_for_op=('=='=>[qw(exact_version) ],'!='=>[qw(add_exclusion) ],'>='=>[qw(add_minimum) ],'<='=>[qw(add_maximum) ],'>'=>[qw(add_minimum add_exclusion) ],'<'=>[qw(add_maximum add_exclusion) ],);sub add_string_requirement {my ($self,$module,$req)=@_;Carp::confess("No requirement string provided for $module")unless defined$req && length$req;my@parts=split qr{\s*,\s*},$req;for my$part (@parts){my ($op,$ver)=$part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z};if (!defined$op){$self->add_minimum($module=>$part)}else {Carp::confess("illegal requirement string: $req")unless my$methods=$methods_for_op{$op };$self->$_($module=>$ver)for @$methods}}}sub from_string_hash {my ($class,$hash)=@_;my$self=$class->new;for my$module (keys %$hash){my$req=$hash->{$module};unless (defined$req && length$req){$req=0;Carp::carp("Undefined requirement for $module treated as '0'")}$self->add_string_requirement($module,$req)}return$self}{package CPAN::Meta::Requirements::_Range::Exact;sub _new {bless {version=>$_[1]}=>$_[0]}sub _accepts {return $_[0]{version}==$_[1]}sub as_string {return "== $_[0]{version}"}sub as_modifiers {return [[exact_version=>$_[0]{version}]]}sub _clone {(ref $_[0])->_new(version->new($_[0]{version}))}sub with_exact_version {my ($self,$version)=@_;return$self->_clone if$self->_accepts($version);Carp::confess("illegal requirements: unequal exact version specified")}sub with_minimum {my ($self,$minimum)=@_;return$self->_clone if$self->{version}>= $minimum;Carp::confess("illegal requirements: minimum above exact specification")}sub with_maximum {my ($self,$maximum)=@_;return$self->_clone if$self->{version}<= $maximum;Carp::confess("illegal requirements: maximum below exact specification")}sub with_exclusion {my ($self,$exclusion)=@_;return$self->_clone unless$exclusion==$self->{version};Carp::confess("illegal requirements: excluded exact specification")}}{package CPAN::Meta::Requirements::_Range::Range;sub _self {ref($_[0])? $_[0]: (bless {}=>$_[0])}sub _clone {return (bless {}=>$_[0])unless ref $_[0];my ($s)=@_;my%guts=((exists$s->{minimum}? (minimum=>version->new($s->{minimum})): ()),(exists$s->{maximum}? (maximum=>version->new($s->{maximum})): ()),(exists$s->{exclusions}? (exclusions=>[map {version->new($_)}@{$s->{exclusions}}]): ()),);bless \%guts=>ref($s)}sub as_modifiers {my ($self)=@_;my@mods;push@mods,[add_minimum=>$self->{minimum}]if exists$self->{minimum};push@mods,[add_maximum=>$self->{maximum}]if exists$self->{maximum};push@mods,map {;[add_exclusion=>$_ ]}@{$self->{exclusions}|| []};return \@mods}sub as_string {my ($self)=@_;return 0 if!keys %$self;return "$self->{minimum}" if (keys %$self)==1 and exists$self->{minimum};my@exclusions=@{$self->{exclusions}|| []};my@parts;for my$pair ([qw(>= > minimum) ],[qw(<= < maximum) ],){my ($op,$e_op,$k)=@$pair;if (exists$self->{$k}){my@new_exclusions=grep {$_!=$self->{$k }}@exclusions;if (@new_exclusions==@exclusions){push@parts,"$op $self->{ $k }"}else {push@parts,"$e_op $self->{ $k }";@exclusions=@new_exclusions}}}push@parts,map {;"!= $_"}@exclusions;return join q{, },@parts}sub with_exact_version {my ($self,$version)=@_;$self=$self->_clone;Carp::confess("illegal requirements: exact specification outside of range")unless$self->_accepts($version);return CPAN::Meta::Requirements::_Range::Exact->_new($version)}sub _simplify {my ($self)=@_;if (defined$self->{minimum}and defined$self->{maximum}){if ($self->{minimum}==$self->{maximum}){Carp::confess("illegal requirements: excluded all values")if grep {$_==$self->{minimum}}@{$self->{exclusions}|| []};return CPAN::Meta::Requirements::_Range::Exact->_new($self->{minimum})}Carp::confess("illegal requirements: minimum exceeds maximum")if$self->{minimum}> $self->{maximum}}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; +CPAN_META_REQUIREMENTS + $fatpacked{"CPAN/Meta/Spec.pm"} = <<'CPAN_META_SPEC'; - # vi:tw=72 - use 5.006; - use strict; - use warnings; - package CPAN::Meta::Spec; - BEGIN { - $CPAN::Meta::Spec::VERSION = '2.110930'; - } - # ABSTRACT: specification for CPAN distribution metadata - 1; - - - - __END__ - =pod - + use 5.006;use strict;use warnings;package CPAN::Meta::Spec;our$VERSION='2.132510';1; CPAN_META_SPEC $fatpacked{"CPAN/Meta/Validator.pm"} = <<'CPAN_META_VALIDATOR'; - use 5.006; - use strict; - use warnings; - package CPAN::Meta::Validator; - BEGIN { - $CPAN::Meta::Validator::VERSION = '2.110930'; - } - # ABSTRACT: validate CPAN distribution metadata structures - - - #--------------------------------------------------------------------------# - # This code copied and adapted from Test::CPAN::Meta - # by Barbie, <barbie@cpan.org> for Miss Barbell Productions, - # L<http://www.missbarbell.co.uk> - #--------------------------------------------------------------------------# - - #--------------------------------------------------------------------------# - # Specification Definitions - #--------------------------------------------------------------------------# - - my %known_specs = ( - '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html', - '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html', - '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html', - '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html', - '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html' - ); - my %known_urls = map {$known_specs{$_} => $_} keys %known_specs; - - my $module_map1 = { 'map' => { ':key' => { name => \&module, value => \&exversion } } }; - - my $module_map2 = { 'map' => { ':key' => { name => \&module, value => \&version } } }; - - my $no_index_2 = { - 'map' => { file => { list => { value => \&string } }, - directory => { list => { value => \&string } }, - 'package' => { list => { value => \&string } }, - namespace => { list => { value => \&string } }, - ':key' => { name => \&custom_2, value => \&anything }, - } - }; - - my $no_index_1_3 = { - 'map' => { file => { list => { value => \&string } }, - directory => { list => { value => \&string } }, - 'package' => { list => { value => \&string } }, - namespace => { list => { value => \&string } }, - ':key' => { name => \&string, value => \&anything }, - } - }; - - my $no_index_1_2 = { - 'map' => { file => { list => { value => \&string } }, - dir => { list => { value => \&string } }, - 'package' => { list => { value => \&string } }, - namespace => { list => { value => \&string } }, - ':key' => { name => \&string, value => \&anything }, - } - }; - - my $no_index_1_1 = { - 'map' => { ':key' => { name => \&string, list => { value => \&string } }, - } - }; - - my $prereq_map = { - map => { - ':key' => { - name => \&phase, - 'map' => { - ':key' => { - name => \&relation, - %$module_map1, - }, - }, - } - }, - }; - - my %definitions = ( - '2' => { - # REQUIRED - 'abstract' => { mandatory => 1, value => \&string }, - 'author' => { mandatory => 1, lazylist => { value => \&string } }, - 'dynamic_config' => { mandatory => 1, value => \&boolean }, - 'generated_by' => { mandatory => 1, value => \&string }, - 'license' => { mandatory => 1, lazylist => { value => \&license } }, - 'meta-spec' => { - mandatory => 1, - 'map' => { - version => { mandatory => 1, value => \&version}, - url => { value => \&url }, - ':key' => { name => \&custom_2, value => \&anything }, - } - }, - 'name' => { mandatory => 1, value => \&string }, - 'release_status' => { mandatory => 1, value => \&release_status }, - 'version' => { mandatory => 1, value => \&version }, - - # OPTIONAL - 'description' => { value => \&string }, - 'keywords' => { lazylist => { value => \&string } }, - 'no_index' => $no_index_2, - 'optional_features' => { - 'map' => { - ':key' => { - name => \&string, - 'map' => { - description => { value => \&string }, - prereqs => $prereq_map, - ':key' => { name => \&custom_2, value => \&anything }, - } - } - } - }, - 'prereqs' => $prereq_map, - 'provides' => { - 'map' => { - ':key' => { - name => \&module, - 'map' => { - file => { mandatory => 1, value => \&file }, - version => { value => \&version }, - ':key' => { name => \&custom_2, value => \&anything }, - } - } - } - }, - 'resources' => { - 'map' => { - license => { lazylist => { value => \&url } }, - homepage => { value => \&url }, - bugtracker => { - 'map' => { - web => { value => \&url }, - mailto => { value => \&string}, - ':key' => { name => \&custom_2, value => \&anything }, - } - }, - repository => { - 'map' => { - web => { value => \&url }, - url => { value => \&url }, - type => { value => \&string }, - ':key' => { name => \&custom_2, value => \&anything }, - } - }, - ':key' => { value => \&string, name => \&custom_2 }, - } - }, - - # CUSTOM -- additional user defined key/value pairs - # note we can only validate the key name, as the structure is user defined - ':key' => { name => \&custom_2, value => \&anything }, - }, - - '1.4' => { - 'meta-spec' => { - mandatory => 1, - 'map' => { - version => { mandatory => 1, value => \&version}, - url => { mandatory => 1, value => \&urlspec }, - ':key' => { name => \&string, value => \&anything }, - }, - }, - - 'name' => { mandatory => 1, value => \&string }, - 'version' => { mandatory => 1, value => \&version }, - 'abstract' => { mandatory => 1, value => \&string }, - 'author' => { mandatory => 1, list => { value => \&string } }, - 'license' => { mandatory => 1, value => \&license }, - 'generated_by' => { mandatory => 1, value => \&string }, - - 'distribution_type' => { value => \&string }, - 'dynamic_config' => { value => \&boolean }, - - 'requires' => $module_map1, - 'recommends' => $module_map1, - 'build_requires' => $module_map1, - 'configure_requires' => $module_map1, - 'conflicts' => $module_map2, - - 'optional_features' => { - 'map' => { - ':key' => { name => \&string, - 'map' => { description => { value => \&string }, - requires => $module_map1, - recommends => $module_map1, - build_requires => $module_map1, - conflicts => $module_map2, - ':key' => { name => \&string, value => \&anything }, - } - } - } - }, - - 'provides' => { - 'map' => { - ':key' => { name => \&module, - 'map' => { - file => { mandatory => 1, value => \&file }, - version => { value => \&version }, - ':key' => { name => \&string, value => \&anything }, - } - } - } - }, - - 'no_index' => $no_index_1_3, - 'private' => $no_index_1_3, - - 'keywords' => { list => { value => \&string } }, - - 'resources' => { - 'map' => { license => { value => \&url }, - homepage => { value => \&url }, - bugtracker => { value => \&url }, - repository => { value => \&url }, - ':key' => { value => \&string, name => \&custom_1 }, - } - }, - - # additional user defined key/value pairs - # note we can only validate the key name, as the structure is user defined - ':key' => { name => \&string, value => \&anything }, - }, - - '1.3' => { - 'meta-spec' => { - mandatory => 1, - 'map' => { - version => { mandatory => 1, value => \&version}, - url => { mandatory => 1, value => \&urlspec }, - ':key' => { name => \&string, value => \&anything }, - }, - }, - - 'name' => { mandatory => 1, value => \&string }, - 'version' => { mandatory => 1, value => \&version }, - 'abstract' => { mandatory => 1, value => \&string }, - 'author' => { mandatory => 1, list => { value => \&string } }, - 'license' => { mandatory => 1, value => \&license }, - 'generated_by' => { mandatory => 1, value => \&string }, - - 'distribution_type' => { value => \&string }, - 'dynamic_config' => { value => \&boolean }, - - 'requires' => $module_map1, - 'recommends' => $module_map1, - 'build_requires' => $module_map1, - 'conflicts' => $module_map2, - - 'optional_features' => { - 'map' => { - ':key' => { name => \&string, - 'map' => { description => { value => \&string }, - requires => $module_map1, - recommends => $module_map1, - build_requires => $module_map1, - conflicts => $module_map2, - ':key' => { name => \&string, value => \&anything }, - } - } - } - }, - - 'provides' => { - 'map' => { - ':key' => { name => \&module, - 'map' => { - file => { mandatory => 1, value => \&file }, - version => { value => \&version }, - ':key' => { name => \&string, value => \&anything }, - } - } - } - }, - - - 'no_index' => $no_index_1_3, - 'private' => $no_index_1_3, - - 'keywords' => { list => { value => \&string } }, - - 'resources' => { - 'map' => { license => { value => \&url }, - homepage => { value => \&url }, - bugtracker => { value => \&url }, - repository => { value => \&url }, - ':key' => { value => \&string, name => \&custom_1 }, - } - }, - - # additional user defined key/value pairs - # note we can only validate the key name, as the structure is user defined - ':key' => { name => \&string, value => \&anything }, - }, - - # v1.2 is misleading, it seems to assume that a number of fields where created - # within v1.1, when they were created within v1.2. This may have been an - # original mistake, and that a v1.1 was retro fitted into the timeline, when - # v1.2 was originally slated as v1.1. But I could be wrong ;) - '1.2' => { - 'meta-spec' => { - mandatory => 1, - 'map' => { - version => { mandatory => 1, value => \&version}, - url => { mandatory => 1, value => \&urlspec }, - ':key' => { name => \&string, value => \&anything }, - }, - }, - - - 'name' => { mandatory => 1, value => \&string }, - 'version' => { mandatory => 1, value => \&version }, - 'license' => { mandatory => 1, value => \&license }, - 'generated_by' => { mandatory => 1, value => \&string }, - 'author' => { mandatory => 1, list => { value => \&string } }, - 'abstract' => { mandatory => 1, value => \&string }, - - 'distribution_type' => { value => \&string }, - 'dynamic_config' => { value => \&boolean }, - - 'keywords' => { list => { value => \&string } }, - - 'private' => $no_index_1_2, - '$no_index' => $no_index_1_2, - - 'requires' => $module_map1, - 'recommends' => $module_map1, - 'build_requires' => $module_map1, - 'conflicts' => $module_map2, - - 'optional_features' => { - 'map' => { - ':key' => { name => \&string, - 'map' => { description => { value => \&string }, - requires => $module_map1, - recommends => $module_map1, - build_requires => $module_map1, - conflicts => $module_map2, - ':key' => { name => \&string, value => \&anything }, - } - } - } - }, - - 'provides' => { - 'map' => { - ':key' => { name => \&module, - 'map' => { - file => { mandatory => 1, value => \&file }, - version => { value => \&version }, - ':key' => { name => \&string, value => \&anything }, - } - } - } - }, - - 'resources' => { - 'map' => { license => { value => \&url }, - homepage => { value => \&url }, - bugtracker => { value => \&url }, - repository => { value => \&url }, - ':key' => { value => \&string, name => \&custom_1 }, - } - }, - - # additional user defined key/value pairs - # note we can only validate the key name, as the structure is user defined - ':key' => { name => \&string, value => \&anything }, - }, - - # note that the 1.1 spec only specifies 'version' as mandatory - '1.1' => { - 'name' => { value => \&string }, - 'version' => { mandatory => 1, value => \&version }, - 'license' => { value => \&license }, - 'generated_by' => { value => \&string }, - - 'license_uri' => { value => \&url }, - 'distribution_type' => { value => \&string }, - 'dynamic_config' => { value => \&boolean }, - - 'private' => $no_index_1_1, - - 'requires' => $module_map1, - 'recommends' => $module_map1, - 'build_requires' => $module_map1, - 'conflicts' => $module_map2, - - # additional user defined key/value pairs - # note we can only validate the key name, as the structure is user defined - ':key' => { name => \&string, value => \&anything }, - }, - - # note that the 1.0 spec doesn't specify optional or mandatory fields - # but we will treat version as mandatory since otherwise META 1.0 is - # completely arbitrary and pointless - '1.0' => { - 'name' => { value => \&string }, - 'version' => { mandatory => 1, value => \&version }, - 'license' => { value => \&license }, - 'generated_by' => { value => \&string }, - - 'license_uri' => { value => \&url }, - 'distribution_type' => { value => \&string }, - 'dynamic_config' => { value => \&boolean }, - - 'requires' => $module_map1, - 'recommends' => $module_map1, - 'build_requires' => $module_map1, - 'conflicts' => $module_map2, - - # additional user defined key/value pairs - # note we can only validate the key name, as the structure is user defined - ':key' => { name => \&string, value => \&anything }, - }, - ); - - #--------------------------------------------------------------------------# - # Code - #--------------------------------------------------------------------------# - - - sub new { - my ($class,$data) = @_; - - # create an attributes hash - my $self = { - 'data' => $data, - 'spec' => $data->{'meta-spec'}{'version'} || "1.0", - 'errors' => undef, - }; - - # create the object - return bless $self, $class; - } - - - sub is_valid { - my $self = shift; - my $data = $self->{data}; - my $spec_version = $self->{spec}; - $self->check_map($definitions{$spec_version},$data); - return ! $self->errors; - } - - - sub errors { - my $self = shift; - return () unless(defined $self->{errors}); - return @{$self->{errors}}; - } - - - my $spec_error = "Missing validation action in specification. " - . "Must be one of 'map', 'list', 'lazylist', or 'value'"; - - sub check_map { - my ($self,$spec,$data) = @_; - - if(ref($spec) ne 'HASH') { - $self->_error( "Unknown META specification, cannot validate." ); - return; - } - - if(ref($data) ne 'HASH') { - $self->_error( "Expected a map structure from string or file." ); - return; - } - - for my $key (keys %$spec) { - next unless($spec->{$key}->{mandatory}); - next if(defined $data->{$key}); - push @{$self->{stack}}, $key; - $self->_error( "Missing mandatory field, '$key'" ); - pop @{$self->{stack}}; - } - - for my $key (keys %$data) { - push @{$self->{stack}}, $key; - if($spec->{$key}) { - if($spec->{$key}{value}) { - $spec->{$key}{value}->($self,$key,$data->{$key}); - } elsif($spec->{$key}{'map'}) { - $self->check_map($spec->{$key}{'map'},$data->{$key}); - } elsif($spec->{$key}{'list'}) { - $self->check_list($spec->{$key}{'list'},$data->{$key}); - } elsif($spec->{$key}{'lazylist'}) { - $self->check_lazylist($spec->{$key}{'lazylist'},$data->{$key}); - } else { - $self->_error( "$spec_error for '$key'" ); - } - - } elsif ($spec->{':key'}) { - $spec->{':key'}{name}->($self,$key,$key); - if($spec->{':key'}{value}) { - $spec->{':key'}{value}->($self,$key,$data->{$key}); - } elsif($spec->{':key'}{'map'}) { - $self->check_map($spec->{':key'}{'map'},$data->{$key}); - } elsif($spec->{':key'}{'list'}) { - $self->check_list($spec->{':key'}{'list'},$data->{$key}); - } elsif($spec->{':key'}{'lazylist'}) { - $self->check_lazylist($spec->{':key'}{'lazylist'},$data->{$key}); - } else { - $self->_error( "$spec_error for ':key'" ); - } - - - } else { - $self->_error( "Unknown key, '$key', found in map structure" ); - } - pop @{$self->{stack}}; - } - } - - # if it's a string, make it into a list and check the list - sub check_lazylist { - my ($self,$spec,$data) = @_; - - if ( defined $data && ! ref($data) ) { - $data = [ $data ]; - } - - $self->check_list($spec,$data); - } - - sub check_list { - my ($self,$spec,$data) = @_; - - if(ref($data) ne 'ARRAY') { - $self->_error( "Expected a list structure" ); - return; - } - - if(defined $spec->{mandatory}) { - if(!defined $data->[0]) { - $self->_error( "Missing entries from mandatory list" ); - } - } - - for my $value (@$data) { - push @{$self->{stack}}, $value || "<undef>"; - if(defined $spec->{value}) { - $spec->{value}->($self,'list',$value); - } elsif(defined $spec->{'map'}) { - $self->check_map($spec->{'map'},$value); - } elsif(defined $spec->{'list'}) { - $self->check_list($spec->{'list'},$value); - } elsif(defined $spec->{'lazylist'}) { - $self->check_lazylist($spec->{'lazylist'},$value); - } elsif ($spec->{':key'}) { - $self->check_map($spec,$value); - } else { - $self->_error( "$spec_error associated with '$self->{stack}[-2]'" ); - } - pop @{$self->{stack}}; - } - } - - - sub header { - my ($self,$key,$value) = @_; - if(defined $value) { - return 1 if($value && $value =~ /^--- #YAML:1.0/); - } - $self->_error( "file does not have a valid YAML header." ); - return 0; - } - - sub release_status { - my ($self,$key,$value) = @_; - if(defined $value) { - my $version = $self->{data}{version} || ''; - if ( $version =~ /_/ ) { - return 1 if ( $value =~ /\A(?:testing|unstable)\z/ ); - $self->_error( "'$value' for '$key' is invalid for version '$version'" ); - } - else { - return 1 if ( $value =~ /\A(?:stable|testing|unstable)\z/ ); - $self->_error( "'$value' for '$key' is invalid" ); - } - } - else { - $self->_error( "'$key' is not defined" ); - } - return 0; - } - - # _uri_split taken from URI::Split by Gisle Aas, Copyright 2003 - sub _uri_split { - return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,; - } - - sub url { - my ($self,$key,$value) = @_; - if(defined $value) { - my ($scheme, $auth, $path, $query, $frag) = _uri_split($value); - unless ( defined $scheme && length $scheme ) { - $self->_error( "'$value' for '$key' does not have a URL scheme" ); - return 0; - } - unless ( defined $auth && length $auth ) { - $self->_error( "'$value' for '$key' does not have a URL authority" ); - return 0; - } - return 1; - } - $value ||= ''; - $self->_error( "'$value' for '$key' is not a valid URL." ); - return 0; - } - - sub urlspec { - my ($self,$key,$value) = @_; - if(defined $value) { - return 1 if($value && $known_specs{$self->{spec}} eq $value); - if($value && $known_urls{$value}) { - $self->_error( 'META specification URL does not match version' ); - return 0; - } - } - $self->_error( 'Unknown META specification' ); - return 0; - } - - sub anything { return 1 } - - sub string { - my ($self,$key,$value) = @_; - if(defined $value) { - return 1 if($value || $value =~ /^0$/); - } - $self->_error( "value is an undefined string" ); - return 0; - } - - sub string_or_undef { - my ($self,$key,$value) = @_; - return 1 unless(defined $value); - return 1 if($value || $value =~ /^0$/); - $self->_error( "No string defined for '$key'" ); - return 0; - } - - sub file { - my ($self,$key,$value) = @_; - return 1 if(defined $value); - $self->_error( "No file defined for '$key'" ); - return 0; - } - - sub exversion { - my ($self,$key,$value) = @_; - if(defined $value && ($value || $value =~ /0/)) { - my $pass = 1; - for(split(",",$value)) { $self->version($key,$_) or ($pass = 0); } - return $pass; - } - $value = '<undef>' unless(defined $value); - $self->_error( "'$value' for '$key' is not a valid version." ); - return 0; - } - - sub version { - my ($self,$key,$value) = @_; - if(defined $value) { - return 0 unless($value || $value =~ /0/); - return 1 if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/); - } else { - $value = '<undef>'; - } - $self->_error( "'$value' for '$key' is not a valid version." ); - return 0; - } - - sub boolean { - my ($self,$key,$value) = @_; - if(defined $value) { - return 1 if($value =~ /^(0|1|true|false)$/); - } else { - $value = '<undef>'; - } - $self->_error( "'$value' for '$key' is not a boolean value." ); - return 0; - } - - my %v1_licenses = ( - 'perl' => 'http://dev.perl.org/licenses/', - 'gpl' => 'http://www.opensource.org/licenses/gpl-license.php', - 'apache' => 'http://apache.org/licenses/LICENSE-2.0', - 'artistic' => 'http://opensource.org/licenses/artistic-license.php', - 'artistic_2' => 'http://opensource.org/licenses/artistic-license-2.0.php', - 'lgpl' => 'http://www.opensource.org/licenses/lgpl-license.phpt', - 'bsd' => 'http://www.opensource.org/licenses/bsd-license.php', - 'gpl' => 'http://www.opensource.org/licenses/gpl-license.php', - 'mit' => 'http://opensource.org/licenses/mit-license.php', - 'mozilla' => 'http://opensource.org/licenses/mozilla1.1.php', - 'open_source' => undef, - 'unrestricted' => undef, - 'restrictive' => undef, - 'unknown' => undef, - ); - - my %v2_licenses = map { $_ => 1 } qw( - agpl_3 - apache_1_1 - apache_2_0 - artistic_1 - artistic_2 - bsd - freebsd - gfdl_1_2 - gfdl_1_3 - gpl_1 - gpl_2 - gpl_3 - lgpl_2_1 - lgpl_3_0 - mit - mozilla_1_0 - mozilla_1_1 - openssl - perl_5 - qpl_1_0 - ssleay - sun - zlib - open_source - restricted - unrestricted - unknown - ); - - sub license { - my ($self,$key,$value) = @_; - my $licenses = $self->{spec} < 2 ? \%v1_licenses : \%v2_licenses; - if(defined $value) { - return 1 if($value && exists $licenses->{$value}); - } else { - $value = '<undef>'; - } - $self->_error( "License '$value' is invalid" ); - return 0; - } - - sub custom_1 { - my ($self,$key) = @_; - if(defined $key) { - # a valid user defined key should be alphabetic - # and contain at least one capital case letter. - return 1 if($key && $key =~ /^[_a-z]+$/i && $key =~ /[A-Z]/); - } else { - $key = '<undef>'; - } - $self->_error( "Custom resource '$key' must be in CamelCase." ); - return 0; - } - - sub custom_2 { - my ($self,$key) = @_; - if(defined $key) { - return 1 if($key && $key =~ /^x_/i); # user defined - } else { - $key = '<undef>'; - } - $self->_error( "Custom key '$key' must begin with 'x_' or 'X_'." ); - return 0; - } - - sub identifier { - my ($self,$key) = @_; - if(defined $key) { - return 1 if($key && $key =~ /^([a-z][_a-z]+)$/i); # spec 2.0 defined - } else { - $key = '<undef>'; - } - $self->_error( "Key '$key' is not a legal identifier." ); - return 0; - } - - sub module { - my ($self,$key) = @_; - if(defined $key) { - return 1 if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/); - } else { - $key = '<undef>'; - } - $self->_error( "Key '$key' is not a legal module name." ); - return 0; - } - - my @valid_phases = qw/ configure build test runtime develop /; - sub phase { - my ($self,$key) = @_; - if(defined $key) { - return 1 if( length $key && grep { $key eq $_ } @valid_phases ); - return 1 if $key =~ /x_/i; - } else { - $key = '<undef>'; - } - $self->_error( "Key '$key' is not a legal phase." ); - return 0; - } - - my @valid_relations = qw/ requires recommends suggests conflicts /; - sub relation { - my ($self,$key) = @_; - if(defined $key) { - return 1 if( length $key && grep { $key eq $_ } @valid_relations ); - return 1 if $key =~ /x_/i; - } else { - $key = '<undef>'; - } - $self->_error( "Key '$key' is not a legal prereq relationship." ); - return 0; - } - - sub _error { - my $self = shift; - my $mess = shift; - - $mess .= ' ('.join(' -> ',@{$self->{stack}}).')' if($self->{stack}); - $mess .= " [Validation: $self->{spec}]"; - - push @{$self->{errors}}, $mess; - } - - 1; - - - - - __END__ - - - + use 5.006;use strict;use warnings;package CPAN::Meta::Validator;our$VERSION='2.132510';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'=>{'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 },'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 },}},':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 },}},':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 },}},':key'=>{name=>\&string,value=>\&anything },},'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 },}},':key'=>{name=>\&string,value=>\&anything },},'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,':key'=>{name=>\&string,value=>\&anything },},'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,':key'=>{name=>\&string,value=>\&anything },},);sub new {my ($class,$data)=@_;my$self={'data'=>$data,'spec'=>$data->{'meta-spec'}{'version'}|| "1.0",'errors'=>undef,};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}}}}sub check_lazylist {my ($self,$spec,$data)=@_;if (defined$data &&!ref($data)){$data=[$data ]}$self->check_list($spec,$data)}sub check_list {my ($self,$spec,$data)=@_;if(ref($data)ne 'ARRAY'){$self->_error("Expected a list structure");return}if(defined$spec->{mandatory}){if(!defined$data->[0]){$self->_error("Missing entries from mandatory list")}}for my$value (@$data){push @{$self->{stack}},$value || "<undef>";if(defined$spec->{value}){$spec->{value}->($self,'list',$value)}elsif(defined$spec->{'map'}){$self->check_map($spec->{'map'},$value)}elsif(defined$spec->{'list'}){$self->check_list($spec->{'list'},$value)}elsif(defined$spec->{'lazylist'}){$self->check_lazylist($spec->{'lazylist'},$value)}elsif ($spec->{':key'}){$self->check_map($spec,$value)}else {$self->_error("$spec_error associated with '$self->{stack}[-2]'")}pop @{$self->{stack}}}}sub header {my ($self,$key,$value)=@_;if(defined$value){return 1 if($value && $value =~ /^--- #YAML:1.0/)}$self->_error("file does not have a valid YAML header.");return 0}sub release_status {my ($self,$key,$value)=@_;if(defined$value){my$version=$self->{data}{version}|| '';if ($version =~ /_/){return 1 if ($value =~ /\A(?:testing|unstable)\z/);$self->_error("'$value' for '$key' is invalid for version '$version'")}else {return 1 if ($value =~ /\A(?:stable|testing|unstable)\z/);$self->_error("'$value' for '$key' is invalid")}}else {$self->_error("'$key' is not defined")}return 0}sub _uri_split {return $_[0]=~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,}sub url {my ($self,$key,$value)=@_;if(defined$value){my ($scheme,$auth,$path,$query,$frag)=_uri_split($value);unless (defined$scheme && length$scheme){$self->_error("'$value' for '$key' does not have a URL scheme");return 0}unless (defined$auth && length$auth){$self->_error("'$value' for '$key' does not have a URL authority");return 0}return 1}$value ||='';$self->_error("'$value' for '$key' is not a valid URL.");return 0}sub urlspec {my ($self,$key,$value)=@_;if(defined$value){return 1 if($value && $known_specs{$self->{spec}}eq $value);if($value && $known_urls{$value}){$self->_error('META specification URL does not match version');return 0}}$self->_error('Unknown META specification');return 0}sub anything {return 1}sub string {my ($self,$key,$value)=@_;if(defined$value){return 1 if($value || $value =~ /^0$/)}$self->_error("value is an undefined string");return 0}sub string_or_undef {my ($self,$key,$value)=@_;return 1 unless(defined$value);return 1 if($value || $value =~ /^0$/);$self->_error("No string defined for '$key'");return 0}sub file {my ($self,$key,$value)=@_;return 1 if(defined$value);$self->_error("No file defined for '$key'");return 0}sub exversion {my ($self,$key,$value)=@_;if(defined$value && ($value || $value =~ /0/)){my$pass=1;for(split(",",$value)){$self->version($key,$_)or ($pass=0)}return$pass}$value='<undef>' unless(defined$value);$self->_error("'$value' for '$key' is not a valid version.");return 0}sub version {my ($self,$key,$value)=@_;if(defined$value){return 0 unless($value || $value =~ /0/);return 1 if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/)}else {$value='<undef>'}$self->_error("'$value' for '$key' is not a valid version.");return 0}sub boolean {my ($self,$key,$value)=@_;if(defined$value){return 1 if($value =~ /^(0|1|true|false)$/)}else {$value='<undef>'}$self->_error("'$value' for '$key' is not a boolean value.");return 0}my%v1_licenses=('perl'=>'http://dev.perl.org/licenses/','gpl'=>'http://www.opensource.org/licenses/gpl-license.php','apache'=>'http://apache.org/licenses/LICENSE-2.0','artistic'=>'http://opensource.org/licenses/artistic-license.php','artistic_2'=>'http://opensource.org/licenses/artistic-license-2.0.php','lgpl'=>'http://www.opensource.org/licenses/lgpl-license.php','bsd'=>'http://www.opensource.org/licenses/bsd-license.php','gpl'=>'http://www.opensource.org/licenses/gpl-license.php','mit'=>'http://opensource.org/licenses/mit-license.php','mozilla'=>'http://opensource.org/licenses/mozilla1.1.php','open_source'=>undef,'unrestricted'=>undef,'restrictive'=>undef,'unknown'=>undef,);my%v2_licenses=map {$_=>1}qw(agpl_3 apache_1_1 apache_2_0 artistic_1 artistic_2 bsd freebsd gfdl_1_2 gfdl_1_3 gpl_1 gpl_2 gpl_3 lgpl_2_1 lgpl_3_0 mit mozilla_1_0 mozilla_1_1 openssl perl_5 qpl_1_0 ssleay sun zlib open_source restricted unrestricted unknown);sub license {my ($self,$key,$value)=@_;my$licenses=$self->{spec}< 2 ? \%v1_licenses : \%v2_licenses;if(defined$value){return 1 if($value && exists$licenses->{$value})}else {$value='<undef>'}$self->_error("License '$value' is invalid");return 0}sub custom_1 {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^[_a-z]+$/i && $key =~ /[A-Z]/)}else {$key='<undef>'}$self->_error("Custom resource '$key' must be in CamelCase.");return 0}sub custom_2 {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^x_/i)}else {$key='<undef>'}$self->_error("Custom key '$key' must begin with 'x_' or 'X_'.");return 0}sub identifier {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^([a-z][_a-z]+)$/i)}else {$key='<undef>'}$self->_error("Key '$key' is not a legal identifier.");return 0}sub module {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/)}else {$key='<undef>'}$self->_error("Key '$key' is not a legal module name.");return 0}my@valid_phases=qw/configure build test runtime develop/;sub phase {my ($self,$key)=@_;if(defined$key){return 1 if(length$key && grep {$key eq $_}@valid_phases);return 1 if$key =~ /x_/i}else {$key='<undef>'}$self->_error("Key '$key' is not a legal phase.");return 0}my@valid_relations=qw/requires recommends suggests conflicts/;sub relation {my ($self,$key)=@_;if(defined$key){return 1 if(length$key && grep {$key eq $_}@valid_relations);return 1 if$key =~ /x_/i}else {$key='<undef>'}$self->_error("Key '$key' is not a legal prereq relationship.");return 0}sub _error {my$self=shift;my$mess=shift;$mess .= ' ('.join(' -> ',@{$self->{stack}}).')' if($self->{stack});$mess .= " [Validation: $self->{spec}]";push @{$self->{errors}},$mess}1; CPAN_META_VALIDATOR $fatpacked{"CPAN/Meta/YAML.pm"} = <<'CPAN_META_YAML'; - package CPAN::Meta::YAML; - BEGIN { - $CPAN::Meta::YAML::VERSION = '0.003'; - } - - use strict; - - # UTF Support? - sub HAVE_UTF8 () { $] >= 5.007003 } - BEGIN { - if ( HAVE_UTF8 ) { - # The string eval helps hide this from Test::MinimumVersion - eval "require utf8;"; - die "Failed to load UTF-8 support" if $@; - } - - # Class structure - require 5.004; - require Exporter; - require Carp; - @CPAN::Meta::YAML::ISA = qw{ Exporter }; - @CPAN::Meta::YAML::EXPORT = qw{ Load Dump }; - @CPAN::Meta::YAML::EXPORT_OK = qw{ LoadFile DumpFile freeze thaw }; - - # Error storage - $CPAN::Meta::YAML::errstr = ''; - } - - # The character class of all characters we need to escape - # NOTE: Inlined, since it's only used once - # my $RE_ESCAPE = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f\"\n]'; - - # Printed form of the unprintable characters in the lowest range - # of ASCII characters, listed by ASCII ordinal position. - my @UNPRINTABLE = qw( - z x01 x02 x03 x04 x05 x06 a - x08 t n v f r x0e x0f - x10 x11 x12 x13 x14 x15 x16 x17 - x18 x19 x1a e x1c x1d x1e x1f - ); - - # Printable characters for escapes - my %UNESCAPES = ( - z => "\x00", a => "\x07", t => "\x09", - n => "\x0a", v => "\x0b", f => "\x0c", - r => "\x0d", e => "\x1b", '\\' => '\\', - ); - - # Special magic boolean words - my %QUOTE = map { $_ => 1 } qw{ - null Null NULL - y Y yes Yes YES n N no No NO - true True TRUE false False FALSE - on On ON off Off OFF - }; - - - - - - ##################################################################### - # Implementation - - # Create an empty CPAN::Meta::YAML object - sub new { - my $class = shift; - bless [ @_ ], $class; - } - - # Create an object from a file - sub read { - my $class = ref $_[0] ? ref shift : shift; - - # Check the file - my $file = shift or return $class->_error( 'You did not specify a file name' ); - return $class->_error( "File '$file' does not exist" ) unless -e $file; - return $class->_error( "'$file' is a directory, not a file" ) unless -f _; - return $class->_error( "Insufficient permissions to read '$file'" ) unless -r _; - - # Slurp in the file - local $/ = undef; - local *CFG; - unless ( open(CFG, $file) ) { - return $class->_error("Failed to open file '$file': $!"); - } - my $contents = <CFG>; - unless ( close(CFG) ) { - return $class->_error("Failed to close file '$file': $!"); - } - - $class->read_string( $contents ); - } - - # Create an object from a string - sub read_string { - my $class = ref $_[0] ? ref shift : shift; - my $self = bless [], $class; - my $string = $_[0]; - eval { - unless ( defined $string ) { - die \"Did not provide a string to load"; - } - - # Byte order marks - # NOTE: Keeping this here to educate maintainers - # my %BOM = ( - # "\357\273\277" => 'UTF-8', - # "\376\377" => 'UTF-16BE', - # "\377\376" => 'UTF-16LE', - # "\377\376\0\0" => 'UTF-32LE' - # "\0\0\376\377" => 'UTF-32BE', - # ); - if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) { - die \"Stream has a non UTF-8 BOM"; - } else { - # Strip UTF-8 bom if found, we'll just ignore it - $string =~ s/^\357\273\277//; - } - - # Try to decode as utf8 - utf8::decode($string) if HAVE_UTF8; - - # Check for some special cases - return $self unless length $string; - unless ( $string =~ /[\012\015]+\z/ ) { - die \"Stream does not end with newline character"; - } - - # Split the file into lines - my @lines = grep { ! /^\s*(?:\#.*)?\z/ } - split /(?:\015{1,2}\012|\015|\012)/, $string; - - # Strip the initial YAML header - @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines; - - # A nibbling parser - while ( @lines ) { - # Do we have a document header? - if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) { - # Handle scalar documents - shift @lines; - if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) { - push @$self, $self->_read_scalar( "$1", [ undef ], \@lines ); - next; - } - } - - if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) { - # A naked document - push @$self, undef; - while ( @lines and $lines[0] !~ /^---/ ) { - shift @lines; - } - - } elsif ( $lines[0] =~ /^\s*\-/ ) { - # An array at the root - my $document = [ ]; - push @$self, $document; - $self->_read_array( $document, [ 0 ], \@lines ); - - } elsif ( $lines[0] =~ /^(\s*)\S/ ) { - # A hash at the root - my $document = { }; - push @$self, $document; - $self->_read_hash( $document, [ length($1) ], \@lines ); - - } else { - die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'"; - } - } - }; - if ( ref $@ eq 'SCALAR' ) { - return $self->_error(${$@}); - } elsif ( $@ ) { - require Carp; - Carp::croak($@); - } - - return $self; - } - - # Deparse a scalar string to the actual scalar - sub _read_scalar { - my ($self, $string, $indent, $lines) = @_; - - # Trim trailing whitespace - $string =~ s/\s*\z//; - - # Explitic null/undef - return undef if $string eq '~'; - - # Single quote - if ( $string =~ /^\'(.*?)\'(?:\s+\#.*)?\z/ ) { - return '' unless defined $1; - $string = $1; - $string =~ s/\'\'/\'/g; - return $string; - } - - # Double quote. - # The commented out form is simpler, but overloaded the Perl regex - # engine due to recursion and backtracking problems on strings - # larger than 32,000ish characters. Keep it for reference purposes. - # if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) { - if ( $string =~ /^\"([^\\"]*(?:\\.[^\\"]*)*)\"(?:\s+\#.*)?\z/ ) { - # Reusing the variable is a little ugly, - # but avoids a new variable and a string copy. - $string = $1; - $string =~ s/\\"/"/g; - $string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex; - return $string; - } - - # Special cases - if ( $string =~ /^[\'\"!&]/ ) { - die \"CPAN::Meta::YAML does not support a feature in line '$string'"; - } - return {} if $string =~ /^{}(?:\s+\#.*)?\z/; - return [] if $string =~ /^\[\](?:\s+\#.*)?\z/; - - # Regular unquoted string - if ( $string !~ /^[>|]/ ) { - if ( - $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ - or - $string =~ /:(?:\s|$)/ - ) { - die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'"; - } - $string =~ s/\s+#.*\z//; - return $string; - } - - # Error - die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines; - - # Check the indent depth - $lines->[0] =~ /^(\s*)/; - $indent->[-1] = length("$1"); - if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) { - die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"; - } - - # Pull the lines - my @multiline = (); - while ( @$lines ) { - $lines->[0] =~ /^(\s*)/; - last unless length($1) >= $indent->[-1]; - push @multiline, substr(shift(@$lines), length($1)); - } - - my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n"; - my $t = (substr($string, 1, 1) eq '-') ? '' : "\n"; - return join( $j, @multiline ) . $t; - } - - # Parse an array - sub _read_array { - my ($self, $array, $indent, $lines) = @_; - - while ( @$lines ) { - # Check for a new document - if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { - while ( @$lines and $lines->[0] !~ /^---/ ) { - shift @$lines; - } - return 1; - } - - # Check the indent level - $lines->[0] =~ /^(\s*)/; - if ( length($1) < $indent->[-1] ) { - return 1; - } elsif ( length($1) > $indent->[-1] ) { - die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"; - } - - if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) { - # Inline nested hash - my $indent2 = length("$1"); - $lines->[0] =~ s/-/ /; - push @$array, { }; - $self->_read_hash( $array->[-1], [ @$indent, $indent2 ], $lines ); - - } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) { - # Array entry with a value - shift @$lines; - push @$array, $self->_read_scalar( "$2", [ @$indent, undef ], $lines ); - - } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) { - shift @$lines; - unless ( @$lines ) { - push @$array, undef; - return 1; - } - if ( $lines->[0] =~ /^(\s*)\-/ ) { - my $indent2 = length("$1"); - if ( $indent->[-1] == $indent2 ) { - # Null array entry - push @$array, undef; - } else { - # Naked indenter - push @$array, [ ]; - $self->_read_array( $array->[-1], [ @$indent, $indent2 ], $lines ); - } - - } elsif ( $lines->[0] =~ /^(\s*)\S/ ) { - push @$array, { }; - $self->_read_hash( $array->[-1], [ @$indent, length("$1") ], $lines ); - - } else { - die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"; - } - - } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) { - # This is probably a structure like the following... - # --- - # foo: - # - list - # bar: value - # - # ... so lets return and let the hash parser handle it - return 1; - - } else { - die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"; - } - } - - return 1; - } - - # Parse an array - sub _read_hash { - my ($self, $hash, $indent, $lines) = @_; - - while ( @$lines ) { - # Check for a new document - if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { - while ( @$lines and $lines->[0] !~ /^---/ ) { - shift @$lines; - } - return 1; - } - - # Check the indent level - $lines->[0] =~ /^(\s*)/; - if ( length($1) < $indent->[-1] ) { - return 1; - } elsif ( length($1) > $indent->[-1] ) { - die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"; - } - - # Get the key - unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+(?:\#.*)?|$)// ) { - if ( $lines->[0] =~ /^\s*[?\'\"]/ ) { - die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'"; - } - die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"; - } - my $key = $1; - - # Do we have a value? - if ( length $lines->[0] ) { - # Yes - $hash->{$key} = $self->_read_scalar( shift(@$lines), [ @$indent, undef ], $lines ); - } else { - # An indent - shift @$lines; - unless ( @$lines ) { - $hash->{$key} = undef; - return 1; - } - if ( $lines->[0] =~ /^(\s*)-/ ) { - $hash->{$key} = []; - $self->_read_array( $hash->{$key}, [ @$indent, length($1) ], $lines ); - } elsif ( $lines->[0] =~ /^(\s*)./ ) { - my $indent2 = length("$1"); - if ( $indent->[-1] >= $indent2 ) { - # Null hash entry - $hash->{$key} = undef; - } else { - $hash->{$key} = {}; - $self->_read_hash( $hash->{$key}, [ @$indent, length($1) ], $lines ); - } - } - } - } - - return 1; - } - - # Save an object to a file - sub write { - my $self = shift; - my $file = shift or return $self->_error('No file name provided'); - - # Write it to the file - open( CFG, '>' . $file ) or return $self->_error( - "Failed to open file '$file' for writing: $!" - ); - print CFG $self->write_string; - close CFG; - - return 1; - } - - # Save an object to a string - sub write_string { - my $self = shift; - return '' unless @$self; - - # Iterate over the documents - my $indent = 0; - my @lines = (); - foreach my $cursor ( @$self ) { - push @lines, '---'; - - # An empty document - if ( ! defined $cursor ) { - # Do nothing - - # A scalar document - } elsif ( ! ref $cursor ) { - $lines[-1] .= ' ' . $self->_write_scalar( $cursor, $indent ); - - # A list at the root - } elsif ( ref $cursor eq 'ARRAY' ) { - unless ( @$cursor ) { - $lines[-1] .= ' []'; - next; - } - push @lines, $self->_write_array( $cursor, $indent, {} ); - - # A hash at the root - } elsif ( ref $cursor eq 'HASH' ) { - unless ( %$cursor ) { - $lines[-1] .= ' {}'; - next; - } - push @lines, $self->_write_hash( $cursor, $indent, {} ); - - } else { - Carp::croak("Cannot serialize " . ref($cursor)); - } - } - - join '', map { "$_\n" } @lines; - } - - sub _write_scalar { - my $string = $_[1]; - return '~' unless defined $string; - return "''" unless length $string; - if ( $string =~ /[\x00-\x08\x0b-\x0d\x0e-\x1f\"\'\n]/ ) { - $string =~ s/\\/\\\\/g; - $string =~ s/"/\\"/g; - $string =~ s/\n/\\n/g; - $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g; - return qq|"$string"|; - } - if ( $string =~ /(?:^\W|\s)/ or $QUOTE{$string} ) { - return "'$string'"; - } - return $string; - } - - sub _write_array { - my ($self, $array, $indent, $seen) = @_; - if ( $seen->{refaddr($array)}++ ) { - die "CPAN::Meta::YAML does not support circular references"; - } - my @lines = (); - foreach my $el ( @$array ) { - my $line = (' ' x $indent) . '-'; - my $type = ref $el; - if ( ! $type ) { - $line .= ' ' . $self->_write_scalar( $el, $indent + 1 ); - push @lines, $line; - - } elsif ( $type eq 'ARRAY' ) { - if ( @$el ) { - push @lines, $line; - push @lines, $self->_write_array( $el, $indent + 1, $seen ); - } else { - $line .= ' []'; - push @lines, $line; - } - - } elsif ( $type eq 'HASH' ) { - if ( keys %$el ) { - push @lines, $line; - push @lines, $self->_write_hash( $el, $indent + 1, $seen ); - } else { - $line .= ' {}'; - push @lines, $line; - } - - } else { - die "CPAN::Meta::YAML does not support $type references"; - } - } - - @lines; - } - - sub _write_hash { - my ($self, $hash, $indent, $seen) = @_; - if ( $seen->{refaddr($hash)}++ ) { - die "CPAN::Meta::YAML does not support circular references"; - } - my @lines = (); - foreach my $name ( sort keys %$hash ) { - my $el = $hash->{$name}; - my $line = (' ' x $indent) . "$name:"; - my $type = ref $el; - if ( ! $type ) { - $line .= ' ' . $self->_write_scalar( $el, $indent + 1 ); - push @lines, $line; - - } elsif ( $type eq 'ARRAY' ) { - if ( @$el ) { - push @lines, $line; - push @lines, $self->_write_array( $el, $indent + 1, $seen ); - } else { - $line .= ' []'; - push @lines, $line; - } - - } elsif ( $type eq 'HASH' ) { - if ( keys %$el ) { - push @lines, $line; - push @lines, $self->_write_hash( $el, $indent + 1, $seen ); - } else { - $line .= ' {}'; - push @lines, $line; - } - - } else { - die "CPAN::Meta::YAML does not support $type references"; - } - } - - @lines; - } - - # Set error - sub _error { - $CPAN::Meta::YAML::errstr = $_[1]; - undef; - } - - # Retrieve error - sub errstr { - $CPAN::Meta::YAML::errstr; - } - - - - - - ##################################################################### - # YAML Compatibility - - sub Dump { - CPAN::Meta::YAML->new(@_)->write_string; - } - - sub Load { - my $self = CPAN::Meta::YAML->read_string(@_); - unless ( $self ) { - Carp::croak("Failed to load YAML document from string"); - } - if ( wantarray ) { - return @$self; - } else { - # To match YAML.pm, return the last document - return $self->[-1]; - } - } - - BEGIN { - *freeze = *Dump; - *thaw = *Load; - } - - sub DumpFile { - my $file = shift; - CPAN::Meta::YAML->new(@_)->write($file); - } - - sub LoadFile { - my $self = CPAN::Meta::YAML->read($_[0]); - unless ( $self ) { - Carp::croak("Failed to load YAML document from '" . ($_[0] || '') . "'"); - } - if ( wantarray ) { - return @$self; - } else { - # Return only the last document to match YAML.pm, - return $self->[-1]; - } - } - - - - - - ##################################################################### - # Use Scalar::Util if possible, otherwise emulate it - - BEGIN { - eval { - require Scalar::Util; - *refaddr = *Scalar::Util::refaddr; - }; - eval <<'END_PERL' if $@; - # Failed to load Scalar::Util + package CPAN::Meta::YAML;{$CPAN::Meta::YAML::VERSION='0.008'}use strict;sub HAVE_UTF8 () {$] >= 5.007003}BEGIN {if (HAVE_UTF8){eval "require utf8;";die "Failed to load UTF-8 support" if $@}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};$CPAN::Meta::YAML::errstr=''}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);my%UNESCAPES=(z=>"\x00",a=>"\x07",t=>"\x09",n=>"\x0a",v=>"\x0b",f=>"\x0c",r=>"\x0d",e=>"\x1b",'\\'=>'\\',);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};sub new {my$class=shift;bless [@_ ],$class}sub read {my$class=ref $_[0]? ref shift : shift;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 _;local $/=undef;local*CFG;unless (open(CFG,$file)){return$class->_error("Failed to open file '$file': $!")}my$contents=<CFG>;unless (close(CFG)){return$class->_error("Failed to close file '$file': $!")}$class->read_string($contents)}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"}if ($string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/){die \"Stream has a non UTF-8 BOM"}else {$string =~ s/^\357\273\277//}utf8::decode($string)if HAVE_UTF8;return$self unless length$string;unless ($string =~ /[\012\015]+\z/){die \"Stream does not end with newline character"}my@lines=grep {!/^\s*(?:\#.*)?\z/}split /(?:\015{1,2}\012|\015|\012)/,$string;@lines and $lines[0]=~ /^\%YAML[: ][\d\.]+.*\z/ and shift@lines;while (@lines){if ($lines[0]=~ /^---\s*(?:(.+)\s*)?\z/){shift@lines;if (defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/){push @$self,$self->_read_scalar("$1",[undef ],\@lines);next}}if (!@lines or $lines[0]=~ /^(?:---|\.\.\.)/){push @$self,undef;while (@lines and $lines[0]!~ /^---/){shift@lines}}elsif ($lines[0]=~ /^\s*\-/){my$document=[];push @$self,$document;$self->_read_array($document,[0 ],\@lines)}elsif ($lines[0]=~ /^(\s*)\S/){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}sub _read_scalar {my ($self,$string,$indent,$lines)=@_;$string =~ s/\s*\z//;return undef if$string eq '~';if ($string =~ /^\'(.*?)\'(?:\s+\#.*)?\z/){return '' unless defined $1;$string=$1;$string =~ s/\'\'/\'/g;return$string}if ($string =~ /^\"([^\\"]*(?:\\.[^\\"]*)*)\"(?:\s+\#.*)?\z/){$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}if ($string =~ /^[\'\"!&]/){die \"CPAN::Meta::YAML does not support a feature in line '$string'"}return {}if$string =~ /^{}(?:\s+\#.*)?\z/;return []if$string =~ /^\[\](?:\s+\#.*)?\z/;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}die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines;$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]'"}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}sub _read_array {my ($self,$array,$indent,$lines)=@_;while (@$lines){if ($lines->[0]=~ /^(?:---|\.\.\.)/){while (@$lines and $lines->[0]!~ /^---/){shift @$lines}return 1}$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+|$)/){my$indent2=length("$1");$lines->[0]=~ s/-/ /;push @$array,{};$self->_read_hash($array->[-1],[@$indent,$indent2 ],$lines)}elsif ($lines->[0]=~ /^\s*\-(\s*)(.+?)\s*\z/){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){push @$array,undef}else {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]){return 1}else {die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"}}return 1}sub _read_hash {my ($self,$hash,$indent,$lines)=@_;while (@$lines){if ($lines->[0]=~ /^(?:---|\.\.\.)/){while (@$lines and $lines->[0]!~ /^---/){shift @$lines}return 1}$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]'"}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;if (length$lines->[0]){$hash->{$key}=$self->_read_scalar(shift(@$lines),[@$indent,undef ],$lines)}else {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){$hash->{$key}=undef}else {$hash->{$key}={};$self->_read_hash($hash->{$key},[@$indent,length($1)],$lines)}}}}return 1}sub write {my$self=shift;my$file=shift or return$self->_error('No file name provided');open(CFG,'>' .$file)or return$self->_error("Failed to open file '$file' for writing: $!");print CFG$self->write_string;close CFG;return 1}sub write_string {my$self=shift;return '' unless @$self;my$indent=0;my@lines=();for my$cursor (@$self){push@lines,'---';if (!defined$cursor){}elsif (!ref$cursor){$lines[-1].= ' ' .$self->_write_scalar($cursor,$indent)}elsif (ref$cursor eq 'ARRAY'){unless (@$cursor){$lines[-1].= ' []';next}push@lines,$self->_write_array($cursor,$indent,{})}elsif (ref$cursor eq 'HASH'){unless (%$cursor){$lines[-1].= ' {}';next}push@lines,$self->_write_hash($cursor,$indent,{})}else {Carp::croak("Cannot serialize " .ref($cursor))}}join '',map {"$_\n"}@lines}sub _write_scalar {my$string=$_[1];return '~' unless defined$string;return "''" unless length$string;if ($string =~ /[\x00-\x08\x0b-\x0d\x0e-\x1f\"\'\n]/){$string =~ s/\\/\\\\/g;$string =~ s/"/\\"/g;$string =~ s/\n/\\n/g;$string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;return qq|"$string"|}if ($string =~ /(?:^\W|\s|:\z)/ or $QUOTE{$string}){return "'$string'"}return$string}sub _write_array {my ($self,$array,$indent,$seen)=@_;if ($seen->{refaddr($array)}++){die "CPAN::Meta::YAML does not support circular references"}my@lines=();for 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=();for 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}sub _error {$CPAN::Meta::YAML::errstr=$_[1];undef}sub errstr {$CPAN::Meta::YAML::errstr}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 {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$self->[-1]}}BEGIN {local $@;eval {require Scalar::Util};my$v=eval("$Scalar::Util::VERSION")|| 0;if ($@ or $v < 1.18){eval <<'END_PERL'}else {*refaddr=*Scalar::Util::refaddr}}1; + # Scalar::Util failed to load or too old sub refaddr { my $pkg = ref($_[0]) or return undef; if ( !! UNIVERSAL::can($_[0], 'can') ) { @@ -5703,847 +228,33 @@ $fatpacked{"CPAN/Meta/YAML.pm"} = <<'CPAN_META_YAML'; $i; } END_PERL - - } - - 1; - - - - - __END__ - - - # ABSTRACT: Read and write a subset of YAML for CPAN Meta files - - CPAN_META_YAML +$fatpacked{"Exporter.pm"} = <<'EXPORTER'; + package Exporter;require 5.006;our$Debug=0;our$ExportLevel=0;our$Verbose ||=0;our$VERSION='5.68';our (%Cache);sub as_heavy {require Exporter::Heavy;my$c=(caller(1))[3];$c =~ s/.*:://;\&{"Exporter::Heavy::heavy_$c"}}sub export {goto &{as_heavy()}}sub import {my$pkg=shift;my$callpkg=caller($ExportLevel);if ($pkg eq "Exporter" and @_ and $_[0]eq "import"){*{$callpkg."::import"}=\&import;return}my$exports=\@{"$pkg\::EXPORT"};my$fail=${$pkg .'::'}{EXPORT_FAIL}&& \@{"$pkg\::EXPORT_FAIL"};return export$pkg,$callpkg,@_ if$Verbose or $Debug or $fail && @$fail > 1;my$export_cache=($Cache{$pkg}||={});my$args=@_ or @_=@$exports;if ($args and not %$export_cache){s/^&//,$export_cache->{$_}=1 foreach (@$exports,@{"$pkg\::EXPORT_OK"})}my$heavy;if ($args or $fail){($heavy=(/\W/ or $args and not exists$export_cache->{$_}or $fail and @$fail and $_ eq $fail->[0]))and last foreach (@_)}else {($heavy=/\W/)and last foreach (@_)}return export$pkg,$callpkg,($args ? @_ : ())if$heavy;local$SIG{__WARN__}=sub {require Carp;&Carp::carp}if not $SIG{__WARN__};*{"$callpkg\::$_"}=\&{"$pkg\::$_"}foreach @_}sub export_fail {my$self=shift;@_}sub export_to_level {goto &{as_heavy()}}sub export_tags {goto &{as_heavy()}}sub export_ok_tags {goto &{as_heavy()}}sub require_version {goto &{as_heavy()}}1; +EXPORTER + +$fatpacked{"Exporter/Heavy.pm"} = <<'EXPORTER_HEAVY'; + package Exporter::Heavy;use strict;no strict 'refs';require Exporter;our$VERSION=$Exporter::VERSION;sub _rebuild_cache {my ($pkg,$exports,$cache)=@_;s/^&// foreach @$exports;@{$cache}{@$exports}=(1)x @$exports;my$ok=\@{"${pkg}::EXPORT_OK"};if (@$ok){s/^&// foreach @$ok;@{$cache}{@$ok}=(1)x @$ok}}sub heavy_export {local$SIG{__WARN__}=sub {my$text=shift;if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//){require Carp;local$Carp::CarpLevel=1;Carp::carp($text)}else {warn$text}};local$SIG{__DIE__}=sub {require Carp;local$Carp::CarpLevel=1;Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")if $_[0]=~ /^Unable to create sub named "(.*?)::"/};my($pkg,$callpkg,@imports)=@_;my($type,$sym,$cache_is_current,$oops);my($exports,$export_cache)=(\@{"${pkg}::EXPORT"},$Exporter::Cache{$pkg}||={});if (@imports){if (!%$export_cache){_rebuild_cache ($pkg,$exports,$export_cache);$cache_is_current=1}if (grep m{^[/!:]},@imports){my$tagsref=\%{"${pkg}::EXPORT_TAGS"};my$tagdata;my%imports;my($remove,$spec,@names,@allexports);unshift@imports,':DEFAULT' if$imports[0]=~ m/^!/;for$spec (@imports){$remove=$spec =~ s/^!//;if ($spec =~ s/^://){if ($spec eq 'DEFAULT'){@names=@$exports}elsif ($tagdata=$tagsref->{$spec}){@names=@$tagdata}else {warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];++$oops;next}}elsif ($spec =~ m:^/(.*)/$:){my$patn=$1;@allexports=keys %$export_cache unless@allexports;@names=grep(/$patn/,@allexports)}else {@names=($spec)}warn "Import ".($remove ? "del":"add").": @names " if$Exporter::Verbose;if ($remove){for$sym (@names){delete$imports{$sym}}}else {@imports{@names}=(1)x @names}}@imports=keys%imports}my@carp;for$sym (@imports){if (!$export_cache->{$sym}){if ($sym =~ m/^\d/){$pkg->VERSION($sym);if (@imports==1){@imports=@$exports;last}if (@imports==2 and!$imports[1]){@imports=();last}}elsif ($sym !~ s/^&// ||!$export_cache->{$sym}){unless ($cache_is_current){%$export_cache=();_rebuild_cache ($pkg,$exports,$export_cache);$cache_is_current=1}if (!$export_cache->{$sym}){push@carp,qq["$sym" is not exported by the $pkg module\n];$oops++}}}}if ($oops){require Carp;Carp::croak("@{carp}Can't continue after import errors")}}else {@imports=@$exports}my($fail,$fail_cache)=(\@{"${pkg}::EXPORT_FAIL"},$Exporter::FailCache{$pkg}||={});if (@$fail){if (!%$fail_cache){my@expanded=map {/^\w/ ? ($_,'&'.$_): $_}@$fail;warn "${pkg}::EXPORT_FAIL cached: @expanded" if$Exporter::Verbose;@{$fail_cache}{@expanded}=(1)x @expanded}my@failed;for$sym (@imports){push(@failed,$sym)if$fail_cache->{$sym}}if (@failed){@failed=$pkg->export_fail(@failed);for$sym (@failed){require Carp;Carp::carp(qq["$sym" is not implemented by the $pkg module ],"on this architecture")}if (@failed){require Carp;Carp::croak("Can't continue after import errors")}}}warn "Importing into $callpkg from $pkg: ",join(", ",sort@imports)if$Exporter::Verbose;for$sym (@imports){(*{"${callpkg}::$sym"}=\&{"${pkg}::$sym"},next)unless$sym =~ s/^(\W)//;$type=$1;no warnings 'once';*{"${callpkg}::$sym"}=$type eq '&' ? \&{"${pkg}::$sym"}: $type eq '$' ? \${"${pkg}::$sym"}: $type eq '@' ? \@{"${pkg}::$sym"}: $type eq '%' ? \%{"${pkg}::$sym"}: $type eq '*' ? *{"${pkg}::$sym"}: do {require Carp;Carp::croak("Can't export symbol: $type$sym")}}}sub heavy_export_to_level {my$pkg=shift;my$level=shift;(undef)=shift;my$callpkg=caller($level);$pkg->export($callpkg,@_)}sub _push_tags {my($pkg,$var,$syms)=@_;my@nontag=();my$export_tags=\%{"${pkg}::EXPORT_TAGS"};push(@{"${pkg}::$var"},map {$export_tags->{$_}? @{$export_tags->{$_}}: scalar(push(@nontag,$_),$_)}(@$syms)? @$syms : keys %$export_tags);if (@nontag and $^W){require Carp;Carp::carp(join(", ",@nontag)." are not tags of $pkg")}}sub heavy_require_version {my($self,$wanted)=@_;my$pkg=ref$self || $self;return ${pkg}->VERSION($wanted)}sub heavy_export_tags {_push_tags((caller)[0],"EXPORT",\@_)}sub heavy_export_ok_tags {_push_tags((caller)[0],"EXPORT_OK",\@_)}1; +EXPORTER_HEAVY + +$fatpacked{"File/pushd.pm"} = <<'FILE_PUSHD'; + use strict;use warnings;package File::pushd;our$VERSION='1.005';our@EXPORT=qw(pushd tempd);our@ISA=qw(Exporter);use Exporter;use Carp;use Cwd qw(getcwd abs_path);use File::Path qw(rmtree);use File::Temp qw();use File::Spec;use overload q{""}=>sub {File::Spec->canonpath($_[0]->{_pushd})},fallback=>1;sub pushd {my ($target_dir,$options)=@_;$options->{untaint_pattern}||=qr{^([-+@\w./]+)$};$target_dir="." unless defined$target_dir;croak "Can't locate directory $target_dir" unless -d $target_dir;my$tainted_orig=getcwd;my$orig;if ($tainted_orig =~ $options->{untaint_pattern}){$orig=$1}else {$orig=$tainted_orig}my$tainted_dest;eval {$tainted_dest=$target_dir ? abs_path($target_dir): $orig};croak "Can't locate absolute path for $target_dir: $@" if $@;my$dest;if ($tainted_dest =~ $options->{untaint_pattern}){$dest=$1}else {$dest=$tainted_dest}if ($dest ne $orig){chdir$dest or croak "Can't chdir to $dest\: $!"}my$self=bless {_pushd=>$dest,_original=>$orig },__PACKAGE__;return$self}sub tempd {my ($options)=@_;my$dir;eval {$dir=pushd(File::Temp::tempdir(CLEANUP=>0),$options)};croak $@ if $@;$dir->{_tempd}=1;return$dir}sub preserve {my$self=shift;return 1 if!$self->{"_tempd"};if (@_==0){return$self->{_preserve}=1}else {return$self->{_preserve}=$_[0]? 1 : 0}}sub DESTROY {my ($self)=@_;my$orig=$self->{_original};chdir$orig if$orig;if ($self->{_tempd}&& !$self->{_preserve}){my$err=do {local $@;eval {rmtree($self->{_pushd})};$@};carp$err if$err}}1; +FILE_PUSHD + $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 - + package HTTP::Tiny;use strict;use warnings;our$VERSION='0.034';use Carp ();my@attributes;BEGIN {@attributes=qw(cookie_jar default_headers local_address max_redirect max_size proxy no_proxy timeout SSL_options verify_SSL);no strict 'refs';for my$accessor (@attributes){*{$accessor}=sub {@_ > 1 ? $_[0]->{$accessor}=$_[1]: $_[0]->{$accessor}}}}sub agent {my($self,$agent)=@_;if(@_ > 1){$self->{agent}=(defined$agent && $agent =~ / $/)? $agent .$self->_agent : $agent}return$self->{agent}}sub new {my($class,%args)=@_;my$self={max_redirect=>5,timeout=>60,verify_SSL=>$args{verify_SSL}|| $args{verify_ssl}|| 0,no_proxy=>$ENV{no_proxy},};bless$self,$class;$class->_validate_cookie_jar($args{cookie_jar})if$args{cookie_jar};for my$key (@attributes){$self->{$key}=$args{$key}if exists$args{$key}}$self->agent(exists$args{agent}? $args{agent}: $class->_agent);if (!exists$self->{proxy}&& (my$http_proxy=$ENV{http_proxy})){if ($http_proxy =~ m{\Ahttp://[^/?#:@]+:\d+/?\z}){$self->{proxy}=$http_proxy}else {Carp::croak(qq{Environment 'http_proxy' must be in format http://<host>:<port>/\n})}}unless (ref$self->{no_proxy}eq 'ARRAY'){$self->{no_proxy}=(defined$self->{no_proxy})? [split /\s*,\s*/,$self->{no_proxy}]: []}return$self}for my$sub_name (qw/get head put post delete/){my$req_method=uc$sub_name;no strict 'refs';eval <<"HERE"}sub post_form {my ($self,$url,$data,$args)=@_;(@_==3 || @_==4 && ref$args eq 'HASH')or Carp::croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ ."\n");my$headers={};while (my ($key,$value)=each %{$args->{headers}|| {}}){$headers->{lc$key}=$value}delete$args->{headers};return$self->request('POST',$url,{%$args,content=>$self->www_form_urlencode($data),headers=>{%$headers,'content-type'=>'application/x-www-form-urlencoded' },})}sub mirror {my ($self,$url,$file,$args)=@_;@_==3 || (@_==4 && ref$args eq 'HASH')or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ ."\n");if (-e $file and my$mtime=(stat($file))[9]){$args->{headers}{'if-modified-since'}||=$self->_http_date($mtime)}my$tempfile=$file .int(rand(2**31));open my$fh,">",$tempfile or Carp::croak(qq/Error: Could not open temporary file $tempfile for downloading: $!\n/);binmode$fh;$args->{data_callback}=sub {print {$fh}$_[0]};my$response=$self->request('GET',$url,$args);close$fh or Carp::croak(qq/Error: Could not close temporary file $tempfile: $!\n/);if ($response->{success}){rename$tempfile,$file or Carp::croak(qq/Error replacing $file with $tempfile: $!\n/);my$lm=$response->{headers}{'last-modified'};if ($lm and my$mtime=$self->_parse_http_date($lm)){utime$mtime,$mtime,$file}}$response->{success}||=$response->{status}eq '304';unlink$tempfile;return$response}my%idempotent=map {$_=>1}qw/GET HEAD PUT DELETE OPTIONS TRACE/;sub request {my ($self,$method,$url,$args)=@_;@_==3 || (@_==4 && ref$args eq 'HASH')or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ ."\n");$args ||={};my$response;for (0 .. 1){$response=eval {$self->_request($method,$url,$args)};last unless $@ && $idempotent{$method}&& $@ =~ m{^(?:Socket closed|Unexpected end)}}if (my$e="$@"){$response={url=>$url,success=>q{},status=>599,reason=>'Internal Exception',content=>$e,headers=>{'content-type'=>'text/plain','content-length'=>length$e,}}}return$response}sub www_form_urlencode {my ($self,$data)=@_;(@_==2 && ref$data)or Carp::croak(q/Usage: $http->www_form_urlencode(DATAREF)/ ."\n");(ref$data eq 'HASH' || ref$data eq 'ARRAY')or Carp::croak("form data must be a hash or array reference\n");my@params=ref$data eq 'HASH' ? %$data : @$data;@params % 2==0 or Carp::croak("form data reference must have an even number of terms\n");my@terms;while(@params){my ($key,$value)=splice(@params,0,2);if (ref$value eq 'ARRAY'){unshift@params,map {$key=>$_}@$value}else {push@terms,join("=",map {$self->_uri_escape($_)}$key,$value)}}return join("&",sort@terms)}my%DefaultPort=(http=>80,https=>443,);sub _agent {my$class=ref($_[0])|| $_[0];(my$default_agent=$class)=~ s{::}{-}g;return$default_agent ."/" .($class->VERSION || 0)}sub _request {my ($self,$method,$url,$args)=@_;my ($scheme,$host,$port,$path_query,$auth)=$self->_split_url($url);my$request={method=>$method,scheme=>$scheme,host_port=>($port==$DefaultPort{$scheme}? $host : "$host:$port"),uri=>$path_query,headers=>{},};my$handle=HTTP::Tiny::Handle->new(timeout=>$self->{timeout},SSL_options=>$self->{SSL_options},verify_SSL=>$self->{verify_SSL},local_address=>$self->{local_address},);if ($self->{proxy}&&!grep {$host =~ /\Q$_\E$/}@{$self->{no_proxy}}){$request->{uri}="$scheme://$request->{host_port}$path_query";die(qq/HTTPS via proxy is not supported\n/)if$request->{scheme}eq 'https';$handle->connect(($self->_split_url($self->{proxy}))[0..2])}else {$handle->connect($scheme,$host,$port)}$self->_prepare_headers_and_cb($request,$args,$url,$auth);$handle->write_request($request);my$response;do {$response=$handle->read_response_header}until (substr($response->{status},0,1)ne '1');$self->_update_cookie_jar($url,$response)if$self->{cookie_jar};if (my@redir_args=$self->_maybe_redirect($request,$response,$args)){$handle->close;return$self->_request(@redir_args,$args)}if ($method eq 'HEAD' || $response->{status}=~ /^[23]04/){}else {my$data_cb=$self->_prepare_data_cb($response,$args);$handle->read_body($data_cb,$response)}$handle->close;$response->{success}=substr($response->{status},0,1)eq '2';$response->{url}=$url;return$response}sub _prepare_headers_and_cb {my ($self,$request,$args,$url,$auth)=@_;for ($self->{default_headers},$args->{headers}){next unless defined;while (my ($k,$v)=each %$_){$request->{headers}{lc$k}=$v}}$request->{headers}{'host'}=$request->{host_port};$request->{headers}{'connection'}="close";$request->{headers}{'user-agent'}||=$self->{agent};if (defined$args->{content}){if (ref$args->{content}eq 'CODE'){$request->{headers}{'content-type'}||="application/octet-stream";$request->{headers}{'transfer-encoding'}='chunked' unless$request->{headers}{'content-length'}|| $request->{headers}{'transfer-encoding'};$request->{cb}=$args->{content}}elsif (length$args->{content}){my$content=$args->{content};if ($] ge '5.008'){utf8::downgrade($content,1)or die(qq/Wide character in request message body\n/)}$request->{headers}{'content-type'}||="application/octet-stream";$request->{headers}{'content-length'}=length$content unless$request->{headers}{'content-length'}|| $request->{headers}{'transfer-encoding'};$request->{cb}=sub {substr$content,0,length$content,''}}$request->{trailer_cb}=$args->{trailer_callback}if ref$args->{trailer_callback}eq 'CODE'}if ($self->{cookie_jar}){my$cookies=$self->cookie_jar->cookie_header($url);$request->{headers}{cookie}=$cookies if length$cookies}if (length$auth &&!defined$request->{headers}{authentication}){require MIME::Base64;$request->{headers}{authorization}="Basic " .MIME::Base64::encode_base64($auth,"")}return}sub _prepare_data_cb {my ($self,$response,$args)=@_;my$data_cb=$args->{data_callback};$response->{content}='';if (!$data_cb || $response->{status}!~ /^2/){if (defined$self->{max_size}){$data_cb=sub {$_[1]->{content}.= $_[0];die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/)if length $_[1]->{content}> $self->{max_size}}}else {$data_cb=sub {$_[1]->{content}.= $_[0]}}}return$data_cb}sub _update_cookie_jar {my ($self,$url,$response)=@_;my$cookies=$response->{headers}->{'set-cookie'};return unless defined$cookies;my@cookies=ref$cookies ? @$cookies : $cookies;$self->cookie_jar->add($url,$_)for@cookies;return}sub _validate_cookie_jar {my ($class,$jar)=@_;for my$method (qw/add cookie_header/){Carp::croak(qq/Cookie jar must provide the '$method' method\n/)unless ref($jar)&& ref($jar)->can($method)}return}sub _maybe_redirect {my ($self,$request,$response,$args)=@_;my$headers=$response->{headers};my ($status,$method)=($response->{status},$request->{method});if (($status eq '303' or ($status =~ /^30[127]/ && $method =~ /^GET|HEAD$/))and $headers->{location}and ++$args->{redirects}<= $self->{max_redirect}){my$location=($headers->{location}=~ /^\//)? "$request->{scheme}://$request->{host_port}$headers->{location}" : $headers->{location};return (($status eq '303' ? 'GET' : $method),$location)}return}sub _split_url {my$url=pop;my ($scheme,$authority,$path_query)=$url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)> or die(qq/Cannot parse URL: '$url'\n/);$scheme=lc$scheme;$path_query="/$path_query" unless$path_query =~ m<\A/>;my ($auth,$host);$authority=(length($authority))? $authority : 'localhost';if ($authority =~ /@/){($auth,$host)=$authority =~ m/\A([^@]*)@(.*)\z/}else {$host=$authority;$auth=''}$host=lc$host;my$port=do {$host =~ s/:([0-9]*)\z// && length $1 ? $1 : ($scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef)};return ($scheme,$host,$port,$path_query,$auth)}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}}my%escapes=map {chr($_)=>sprintf("%%%02X",$_)}0..255;$escapes{' '}="+";my$unsafe_char=qr/[^A-Za-z0-9\-\._~]/;sub _uri_escape {my ($self,$str)=@_;if ($] ge '5.008'){utf8::encode($str)}else {$str=pack("U*",unpack("C*",$str))if (length$str==do {use bytes;length$str});$str=pack("C*",unpack("C*",$str))}$str =~ s/($unsafe_char)/$escapes{$1}/ge;return$str}package HTTP::Tiny::Handle;use strict;use warnings;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,verify_SSL=>0,SSL_options=>{},%args },$class}sub connect {@_==4 || die(q/Usage: $handle->connect(scheme, host, port)/ ."\n");my ($self,$scheme,$host,$port)=@_;if ($scheme eq 'https'){die(qq/IO::Socket::SSL 1.42 must be installed for https support\n/)unless eval {require IO::Socket::SSL;IO::Socket::SSL->VERSION(1.42)};die(qq/Net::SSLeay 1.49 must be installed for https support\n/)unless eval {require Net::SSLeay;Net::SSLeay->VERSION(1.49)}}elsif ($scheme ne 'http'){die(qq/Unsupported URL scheme '$scheme'\n/)}$self->{fh}='IO::Socket::INET'->new(PeerHost=>$host,PeerPort=>$port,$self->{local_address}? (LocalAddr=>$self->{local_address}): (),Proto=>'tcp',Type=>SOCK_STREAM,Timeout=>$self->{timeout})or die(qq/Could not connect to '$host:$port': $@\n/);binmode($self->{fh})or die(qq/Could not binmode() socket: '$!'\n/);if ($scheme eq 'https'){my$ssl_args=$self->_ssl_args($host);IO::Socket::SSL->start_SSL($self->{fh},%$ssl_args,SSL_create_ctx_callback=>sub {my$ctx=shift;Net::SSLeay::CTX_set_mode($ctx,Net::SSLeay::MODE_AUTO_RETRY())},);unless (ref($self->{fh})eq 'IO::Socket::SSL'){my$ssl_err=IO::Socket::SSL->errstr;die(qq/SSL connection failed for $host: $ssl_err\n/)}}$self->{host}=$host;$self->{port}=$port;return$self}sub close {@_==1 || die(q/Usage: $handle->close()/ ."\n");my ($self)=@_;CORE::close($self->{fh})or die(qq/Could not close socket: '$!'\n/)}sub write {@_==2 || die(q/Usage: $handle->write(buf)/ ."\n");my ($self,$buf)=@_;if ($] ge '5.008'){utf8::downgrade($buf,1)or die(qq/Wide character in write()\n/)}my$len=length$buf;my$off=0;local$SIG{PIPE}='IGNORE';while (){$self->can_write or die(qq/Timed out while waiting for socket to become ready for writing\n/);my$r=syswrite($self->{fh},$buf,$len,$off);if (defined$r){$len -= $r;$off += $r;last unless$len > 0}elsif ($!==EPIPE){die(qq/Socket closed by remote server: $!\n/)}elsif ($!!=EINTR){if ($self->{fh}->can('errstr')){my$err=$self->{fh}->errstr();die (qq/Could not write to SSL socket: '$err'\n /)}else {die(qq/Could not write to socket: '$!'\n/)}}}return$off}sub read {@_==2 || @_==3 || die(q/Usage: $handle->read(len [, allow_partial])/ ."\n");my ($self,$len,$allow_partial)=@_;my$buf='';my$got=length$self->{rbuf};if ($got){my$take=($got < $len)? $got : $len;$buf=substr($self->{rbuf},0,$take,'');$len -= $take}while ($len > 0){$self->can_read or die(q/Timed out while waiting for socket to become ready for reading/ ."\n");my$r=sysread($self->{fh},$buf,$len,length$buf);if (defined$r){last unless$r;$len -= $r}elsif ($!!=EINTR){if ($self->{fh}->can('errstr')){my$err=$self->{fh}->errstr();die (qq/Could not read from SSL socket: '$err'\n /)}else {die(qq/Could not read from socket: '$!'\n/)}}}if ($len &&!$allow_partial){die(qq/Unexpected end of stream\n/)}return$buf}sub readline {@_==1 || die(q/Usage: $handle->readline()/ ."\n");my ($self)=@_;while (){if ($self->{rbuf}=~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x){return $1}if (length$self->{rbuf}>= $self->{max_line_size}){die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/)}$self->can_read or die(qq/Timed out while waiting for socket to become ready for reading\n/);my$r=sysread($self->{fh},$self->{rbuf},BUFSIZE,length$self->{rbuf});if (defined$r){last unless$r}elsif ($!!=EINTR){if ($self->{fh}->can('errstr')){my$err=$self->{fh}->errstr();die (qq/Could not read from SSL socket: '$err'\n /)}else {die(qq/Could not read from socket: '$!'\n/)}}}die(qq/Unexpected end of stream while looking for line\n/)}sub read_header_lines {@_==1 || @_==2 || die(q/Usage: $handle->read_header_lines([headers])/ ."\n");my ($self,$headers)=@_;$headers ||={};my$lines=0;my$val;while (){my$line=$self->readline;if (++$lines >= $self->{max_header_lines}){die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/)}elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x){my ($field_name)=lc $1;if (exists$headers->{$field_name}){for ($headers->{$field_name}){$_=[$_]unless ref $_ eq "ARRAY";push @$_,$2;$val=\$_->[-1]}}else {$val=\($headers->{$field_name}=$2)}}elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x){$val or die(qq/Unexpected header continuation line\n/);next unless length $1;$$val .= ' ' if length $$val;$$val .= $1}elsif ($line =~ /\A \x0D?\x0A \z/x){last}else {die(q/Malformed header line: / .$Printable->($line)."\n")}}return$headers}sub write_request {@_==2 || die(q/Usage: $handle->write_request(request)/ ."\n");my($self,$request)=@_;$self->write_request_header(@{$request}{qw/method uri headers/});$self->write_body($request)if$request->{cb};return}my%HeaderCase=('content-md5'=>'Content-MD5','etag'=>'ETag','te'=>'TE','www-authenticate'=>'WWW-Authenticate','x-xss-protection'=>'X-XSS-Protection',);sub write_header_lines {(@_==2 && ref $_[1]eq 'HASH')|| die(q/Usage: $handle->write_header_lines(headers)/ ."\n");my($self,$headers)=@_;my$buf='';while (my ($k,$v)=each %$headers){my$field_name=lc$k;if (exists$HeaderCase{$field_name}){$field_name=$HeaderCase{$field_name}}else {$field_name =~ /\A $Token+ \z/xo or die(q/Invalid HTTP header field name: / .$Printable->($field_name)."\n");$field_name =~ s/\b(\w)/\u$1/g;$HeaderCase{lc$field_name}=$field_name}for (ref$v eq 'ARRAY' ? @$v : $v){/[^\x0D\x0A]/ or die(qq/Invalid HTTP header field value ($field_name): / .$Printable->($_)."\n");$buf .= "$field_name: $_\x0D\x0A"}}$buf .= "\x0D\x0A";return$self->write($buf)}sub read_body {@_==3 || die(q/Usage: $handle->read_body(callback, response)/ ."\n");my ($self,$cb,$response)=@_;my$te=$response->{headers}{'transfer-encoding'}|| '';if (grep {/chunked/i}(ref$te eq 'ARRAY' ? @$te : $te)){$self->read_chunked_body($cb,$response)}else {$self->read_content_body($cb,$response)}return}sub write_body {@_==2 || die(q/Usage: $handle->write_body(request)/ ."\n");my ($self,$request)=@_;if ($request->{headers}{'content-length'}){return$self->write_content_body($request)}else {return$self->write_chunked_body($request)}}sub read_content_body {@_==3 || @_==4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ ."\n");my ($self,$cb,$response,$content_length)=@_;$content_length ||=$response->{headers}{'content-length'};if (defined$content_length){my$len=$content_length;while ($len > 0){my$read=($len > BUFSIZE)? BUFSIZE : $len;$cb->($self->read($read,0),$response);$len -= $read}}else {my$chunk;$cb->($chunk,$response)while length($chunk=$self->read(BUFSIZE,1))}return}sub write_content_body {@_==2 || die(q/Usage: $handle->write_content_body(request)/ ."\n");my ($self,$request)=@_;my ($len,$content_length)=(0,$request->{headers}{'content-length'});while (){my$data=$request->{cb}->();defined$data && length$data or last;if ($] ge '5.008'){utf8::downgrade($data,1)or die(qq/Wide character in write_content()\n/)}$len += $self->write($data)}$len==$content_length or die(qq/Content-Length missmatch (got: $len expected: $content_length)\n/);return$len}sub read_chunked_body {@_==3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ ."\n");my ($self,$cb,$response)=@_;while (){my$head=$self->readline;$head =~ /\A ([A-Fa-f0-9]+)/x or die(q/Malformed chunk head: / .$Printable->($head)."\n");my$len=hex($1)or last;$self->read_content_body($cb,$response,$len);$self->read(2)eq "\x0D\x0A" or die(qq/Malformed chunk: missing CRLF after chunk data\n/)}$self->read_header_lines($response->{headers});return}sub write_chunked_body {@_==2 || die(q/Usage: $handle->write_chunked_body(request)/ ."\n");my ($self,$request)=@_;my$len=0;while (){my$data=$request->{cb}->();defined$data && length$data or last;if ($] ge '5.008'){utf8::downgrade($data,1)or die(qq/Wide character in write_chunked_body()\n/)}$len += length$data;my$chunk=sprintf '%X',length$data;$chunk .= "\x0D\x0A";$chunk .= $data;$chunk .= "\x0D\x0A";$self->write($chunk)}$self->write("0\x0D\x0A");$self->write_header_lines($request->{trailer_cb}->())if ref$request->{trailer_cb}eq 'CODE';return$len}sub read_response_header {@_==1 || die(q/Usage: $handle->read_response_header()/ ."\n");my ($self)=@_;my$line=$self->readline;$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x or die(q/Malformed Status-Line: / .$Printable->($line)."\n");my ($protocol,$version,$status,$reason)=($1,$2,$3,$4);die (qq/Unsupported HTTP protocol: $protocol\n/)unless$version =~ /0*1\.0*[01]/;return {status=>$status,reason=>$reason,headers=>$self->read_header_lines,protocol=>$protocol,}}sub write_request_header {@_==4 || die(q/Usage: $handle->write_request_header(method, request_uri, headers)/ ."\n");my ($self,$method,$request_uri,$headers)=@_;return$self->write("$method $request_uri HTTP/1.1\x0D\x0A")+ $self->write_header_lines($headers)}sub _do_timeout {my ($self,$type,$timeout)=@_;$timeout=$self->{timeout}unless defined$timeout && $timeout >= 0;my$fd=fileno$self->{fh};defined$fd && $fd >= 0 or die(qq/select(2): 'Bad file descriptor'\n/);my$initial=time;my$pending=$timeout;my$nfound;vec(my$fdset='',$fd,1)=1;while (){$nfound=($type eq 'read')? select($fdset,undef,undef,$pending): select(undef,$fdset,undef,$pending);if ($nfound==-1){$!==EINTR or die(qq/select(2): '$!'\n/);redo if!$timeout || ($pending=$timeout - (time - $initial))> 0;$nfound=0}last}$!=0;return$nfound}sub can_read {@_==1 || @_==2 || die(q/Usage: $handle->can_read([timeout])/ ."\n");my$self=shift;return$self->_do_timeout('read',@_)}sub can_write {@_==1 || @_==2 || die(q/Usage: $handle->can_write([timeout])/ ."\n");my$self=shift;return$self->_do_timeout('write',@_)}sub _find_CA_file {my$self=shift();return$self->{SSL_options}->{SSL_ca_file}if$self->{SSL_options}->{SSL_ca_file}and -e $self->{SSL_options}->{SSL_ca_file};return Mozilla::CA::SSL_ca_file()if eval {require Mozilla::CA};for my$ca_bundle (qw{/etc/ssl/certs/ca-certificates.crt /etc/pki/tls/certs/ca-bundle.crt /etc/ssl/ca-bundle.pem}){return$ca_bundle if -e $ca_bundle}die qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/ .qq/Try installing Mozilla::CA from CPAN\n/}sub _ssl_args {my ($self,$host)=@_;my%ssl_args;if (Net::SSLeay::OPENSSL_VERSION_NUMBER()>= 0x01000000){$ssl_args{SSL_hostname}=$host,}if ($self->{verify_SSL}){$ssl_args{SSL_verifycn_scheme}='http';$ssl_args{SSL_verifycn_name}=$host;$ssl_args{SSL_verify_mode}=0x01;$ssl_args{SSL_ca_file}=$self->_find_CA_file}else {$ssl_args{SSL_verifycn_scheme}='none';$ssl_args{SSL_verify_mode}=0x00}for my$k (keys %{$self->{SSL_options}}){$ssl_args{$k}=$self->{SSL_options}{$k}if$k =~ m/^SSL_/}return \%ssl_args}1; + sub $sub_name { + my (\$self, \$url, \$args) = \@_; + \@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH') + or Carp::croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n"); + return \$self->request('$req_method', \$url, \$args || {}); + } + HERE 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/ + package JSON::PP;use 5.005;use strict;use base qw(Exporter);use overload ();use Carp ();use B ();$JSON::PP::VERSION='2.27202';@JSON::PP::EXPORT=qw(encode_json decode_json from_json to_json);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);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; @@ -6560,1090 +271,7 @@ $fatpacked{"JSON/PP.pm"} = <<'JSON_PP'; sub get_$name { \$_[0]->{PROPS}->[$flag_name] ? 1 : ''; } - /; - } - - } - - - - # Functions - - my %encode_allow_method - = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash - allow_blessed convert_blessed indent indent_length allow_bignum - as_nonblessed - /; - my %decode_allow_method - = map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum - allow_barekey max_size relaxed/; - - - my $JSON; # cache - - sub encode_json ($) { # encode - ($JSON ||= __PACKAGE__->new->utf8)->encode(@_); - } - - - sub decode_json { # decode - ($JSON ||= __PACKAGE__->new->utf8)->decode(@_); - } - - # Obsoleted - - sub to_json($) { - Carp::croak ("JSON::PP::to_json has been renamed to encode_json."); - } - - - sub from_json($) { - Carp::croak ("JSON::PP::from_json has been renamed to decode_json."); - } - - - # Methods - - sub new { - my $class = shift; - my $self = { - max_depth => 512, - max_size => 0, - indent => 0, - FLAGS => 0, - fallback => sub { encode_error('Invalid value. JSON can only reference.') }, - indent_length => 3, - }; - - bless $self, $class; - } - - - sub encode { - return $_[0]->PP_encode_json($_[1]); - } - - - sub decode { - return $_[0]->PP_decode_json($_[1], 0x00000000); - } - - - sub decode_prefix { - return $_[0]->PP_decode_json($_[1], 0x00000001); - } - - - # accessor - - - # pretty printing - - sub pretty { - my ($self, $v) = @_; - my $enable = defined $v ? $v : 1; - - if ($enable) { # indent_length(3) for JSON::XS compatibility - $self->indent(1)->indent_length(3)->space_before(1)->space_after(1); - } - else { - $self->indent(0)->space_before(0)->space_after(0); - } - - $self; - } - - # etc - - sub max_depth { - my $max = defined $_[1] ? $_[1] : 0x80000000; - $_[0]->{max_depth} = $max; - $_[0]; - } - - - sub get_max_depth { $_[0]->{max_depth}; } - - - sub max_size { - my $max = defined $_[1] ? $_[1] : 0; - $_[0]->{max_size} = $max; - $_[0]; - } - - - sub get_max_size { $_[0]->{max_size}; } - - - sub filter_json_object { - $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0; - $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; - $_[0]; - } - - sub filter_json_single_key_object { - if (@_ > 1) { - $_[0]->{cb_sk_object}->{$_[1]} = $_[2]; - } - $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; - $_[0]; - } - - sub indent_length { - if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) { - Carp::carp "The acceptable range of indent_length() is 0 to 15."; - } - else { - $_[0]->{indent_length} = $_[1]; - } - $_[0]; - } - - sub get_indent_length { - $_[0]->{indent_length}; - } - - sub sort_by { - $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1; - $_[0]; - } - - sub allow_bigint { - Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted."); - } - - ############################### - - ### - ### Perl => JSON - ### - - - { # Convert - - my $max_depth; - my $indent; - my $ascii; - my $latin1; - my $utf8; - my $space_before; - my $space_after; - my $canonical; - my $allow_blessed; - my $convert_blessed; - - my $indent_length; - my $escape_slash; - my $bignum; - my $as_nonblessed; - - my $depth; - my $indent_count; - my $keysort; - - - sub PP_encode_json { - my $self = shift; - my $obj = shift; - - $indent_count = 0; - $depth = 0; - - my $idx = $self->{PROPS}; - - ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed, - $convert_blessed, $escape_slash, $bignum, $as_nonblessed) - = @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED, - P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED]; - - ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/}; - - $keysort = $canonical ? sub { $a cmp $b } : undef; - - if ($self->{sort_by}) { - $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by} - : $self->{sort_by} =~ /\D+/ ? $self->{sort_by} - : sub { $a cmp $b }; - } - - encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)") - if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]); - - my $str = $self->object_to_json($obj); - - $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible - - unless ($ascii or $latin1 or $utf8) { - utf8::upgrade($str); - } - - if ($idx->[ P_SHRINK ]) { - utf8::downgrade($str, 1); - } - - return $str; - } - - - sub object_to_json { - my ($self, $obj) = @_; - my $type = ref($obj); - - if($type eq 'HASH'){ - return $self->hash_to_json($obj); - } - elsif($type eq 'ARRAY'){ - return $self->array_to_json($obj); - } - elsif ($type) { # blessed object? - if (blessed($obj)) { - - return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') ); - - if ( $convert_blessed and $obj->can('TO_JSON') ) { - my $result = $obj->TO_JSON(); - if ( defined $result and ref( $result ) ) { - if ( refaddr( $obj ) eq refaddr( $result ) ) { - encode_error( sprintf( - "%s::TO_JSON method returned same object as was passed instead of a new one", - ref $obj - ) ); - } - } - - return $self->object_to_json( $result ); - } - - return "$obj" if ( $bignum and _is_bignum($obj) ); - return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed. - - encode_error( sprintf("encountered object '%s', but neither allow_blessed " - . "nor convert_blessed settings are enabled", $obj) - ) unless ($allow_blessed); - - return 'null'; - } - else { - return $self->value_to_json($obj); - } - } - else{ - return $self->value_to_json($obj); - } - } - - - sub hash_to_json { - my ($self, $obj) = @_; - my @res; - - encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") - if (++$depth > $max_depth); - - my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); - my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : ''); - - for my $k ( _sort( $obj ) ) { - if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized - push @res, string_to_json( $self, $k ) - . $del - . ( $self->object_to_json( $obj->{$k} ) || $self->value_to_json( $obj->{$k} ) ); - } - - --$depth; - $self->_down_indent() if ($indent); - - return '{' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . '}'; - } - - - sub array_to_json { - my ($self, $obj) = @_; - my @res; - - encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") - if (++$depth > $max_depth); - - my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); - - for my $v (@$obj){ - push @res, $self->object_to_json($v) || $self->value_to_json($v); - } - - --$depth; - $self->_down_indent() if ($indent); - - return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']'; - } - - - sub value_to_json { - my ($self, $value) = @_; - - return 'null' if(!defined $value); - - my $b_obj = B::svref_2object(\$value); # for round trip problem - my $flags = $b_obj->FLAGS; - - return $value # as is - if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV? - - my $type = ref($value); - - if(!$type){ - return string_to_json($self, $value); - } - elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){ - return $$value == 1 ? 'true' : 'false'; - } - elsif ($type) { - if ((overload::StrVal($value) =~ /=(\w+)/)[0]) { - return $self->value_to_json("$value"); - } - - if ($type eq 'SCALAR' and defined $$value) { - return $$value eq '1' ? 'true' - : $$value eq '0' ? 'false' - : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null' - : encode_error("cannot encode reference to scalar"); - } - - if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) { - return 'null'; - } - else { - if ( $type eq 'SCALAR' or $type eq 'REF' ) { - encode_error("cannot encode reference to scalar"); - } - else { - encode_error("encountered $value, but JSON can only represent references to arrays or hashes"); - } - } - - } - else { - return $self->{fallback}->($value) - if ($self->{fallback} and ref($self->{fallback}) eq 'CODE'); - return 'null'; - } - - } - - - my %esc = ( - "\n" => '\n', - "\r" => '\r', - "\t" => '\t', - "\f" => '\f', - "\b" => '\b', - "\"" => '\"', - "\\" => '\\\\', - "\'" => '\\\'', - ); - - - sub string_to_json { - my ($self, $arg) = @_; - - $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g; - $arg =~ s/\//\\\//g if ($escape_slash); - $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg; - - if ($ascii) { - $arg = JSON_PP_encode_ascii($arg); - } - - if ($latin1) { - $arg = JSON_PP_encode_latin1($arg); - } - - if ($utf8) { - utf8::encode($arg); - } - - return '"' . $arg . '"'; - } - - - sub blessed_to_json { - my $reftype = reftype($_[1]) || ''; - if ($reftype eq 'HASH') { - return $_[0]->hash_to_json($_[1]); - } - elsif ($reftype eq 'ARRAY') { - return $_[0]->array_to_json($_[1]); - } - else { - return 'null'; - } - } - - - sub encode_error { - my $error = shift; - Carp::croak "$error"; - } - - - sub _sort { - defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]}; - } - - - sub _up_indent { - my $self = shift; - my $space = ' ' x $indent_length; - - my ($pre,$post) = ('',''); - - $post = "\n" . $space x $indent_count; - - $indent_count++; - - $pre = "\n" . $space x $indent_count; - - return ($pre,$post); - } - - - sub _down_indent { $indent_count--; } - - - sub PP_encode_box { - { - depth => $depth, - indent_count => $indent_count, - }; - } - - } # Convert - - - sub _encode_ascii { - join('', - map { - $_ <= 127 ? - chr($_) : - $_ <= 65535 ? - sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); - } unpack('U*', $_[0]) - ); - } - - - sub _encode_latin1 { - join('', - map { - $_ <= 255 ? - chr($_) : - $_ <= 65535 ? - sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); - } unpack('U*', $_[0]) - ); - } - - - sub _encode_surrogates { # from perlunicode - my $uni = $_[0] - 0x10000; - return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00); - } - - - sub _is_bignum { - $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat'); - } - - - - # - # JSON => Perl - # - - my $max_intsize; - - BEGIN { - my $checkint = 1111; - for my $d (5..64) { - $checkint .= 1; - my $int = eval qq| $checkint |; - if ($int =~ /[eE]/) { - $max_intsize = $d - 1; - last; - } - } - } - - { # PARSE - - my %escapes = ( # by Jeremy Muhlich <jmuhlich [at] bitflood.org> - b => "\x8", - t => "\x9", - n => "\xA", - f => "\xC", - r => "\xD", - '\\' => '\\', - '"' => '"', - '/' => '/', - ); - - my $text; # json data - my $at; # offset - my $ch; # 1chracter - my $len; # text length (changed according to UTF8 or NON UTF8) - # INTERNAL - my $depth; # nest counter - my $encoding; # json text encoding - my $is_valid_utf8; # temp variable - my $utf8_len; # utf8 byte length - # FLAGS - my $utf8; # must be utf8 - my $max_depth; # max nest nubmer of objects and arrays - my $max_size; - my $relaxed; - my $cb_object; - my $cb_sk_object; - - my $F_HOOK; - - my $allow_bigint; # using Math::BigInt - my $singlequote; # loosely quoting - my $loose; # - my $allow_barekey; # bareKey - - # $opt flag - # 0x00000001 .... decode_prefix - # 0x10000000 .... incr_parse - - sub PP_decode_json { - my ($self, $opt); # $opt is an effective flag during this decode_json. - - ($self, $text, $opt) = @_; - - ($at, $ch, $depth) = (0, '', 0); - - if ( !defined $text or ref $text ) { - decode_error("malformed JSON string, neither array, object, number, string or atom"); - } - - my $idx = $self->{PROPS}; - - ($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote) - = @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE]; - - if ( $utf8 ) { - utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry"); - } - else { - utf8::upgrade( $text ); - } - - $len = length $text; - - ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK) - = @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/}; - - if ($max_size > 1) { - use bytes; - my $bytes = length $text; - decode_error( - sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s" - , $bytes, $max_size), 1 - ) if ($bytes > $max_size); - } - - # Currently no effect - # should use regexp - my @octets = unpack('C4', $text); - $encoding = ( $octets[0] and $octets[1]) ? 'UTF-8' - : (!$octets[0] and $octets[1]) ? 'UTF-16BE' - : (!$octets[0] and !$octets[1]) ? 'UTF-32BE' - : ( $octets[2] ) ? 'UTF-16LE' - : (!$octets[2] ) ? 'UTF-32LE' - : 'unknown'; - - white(); # remove head white space - - my $valid_start = defined $ch; # Is there a first character for JSON structure? - - my $result = value(); - - return undef if ( !$result && ( $opt & 0x10000000 ) ); # for incr_parse - - decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start; - - if ( !$idx->[ P_ALLOW_NONREF ] and !ref $result ) { - decode_error( - 'JSON text must be an object or array (but found number, string, true, false or null,' - . ' use allow_nonref to allow this)', 1); - } - - Carp::croak('something wrong.') if $len < $at; # we won't arrive here. - - my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length - - white(); # remove tail white space - - if ( $ch ) { - return ( $result, $consumed ) if ($opt & 0x00000001); # all right if decode_prefix - decode_error("garbage after JSON object"); - } - - ( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result; - } - - - sub next_chr { - return $ch = undef if($at >= $len); - $ch = substr($text, $at++, 1); - } - - - sub value { - white(); - return if(!defined $ch); - return object() if($ch eq '{'); - return array() if($ch eq '['); - return string() if($ch eq '"' or ($singlequote and $ch eq "'")); - return number() if($ch =~ /[0-9]/ or $ch eq '-'); - return word(); - } - - sub string { - my ($i, $s, $t, $u); - my $utf16; - my $is_utf8; - - ($is_valid_utf8, $utf8_len) = ('', 0); - - $s = ''; # basically UTF8 flag on - - if($ch eq '"' or ($singlequote and $ch eq "'")){ - my $boundChar = $ch; - - OUTER: while( defined(next_chr()) ){ - - if($ch eq $boundChar){ - next_chr(); - - if ($utf16) { - decode_error("missing low surrogate character in surrogate pair"); - } - - utf8::decode($s) if($is_utf8); - - return $s; - } - elsif($ch eq '\\'){ - next_chr(); - if(exists $escapes{$ch}){ - $s .= $escapes{$ch}; - } - elsif($ch eq 'u'){ # UNICODE handling - my $u = ''; - - for(1..4){ - $ch = next_chr(); - last OUTER if($ch !~ /[0-9a-fA-F]/); - $u .= $ch; - } - - # U+D800 - U+DBFF - if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate? - $utf16 = $u; - } - # U+DC00 - U+DFFF - elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate? - unless (defined $utf16) { - decode_error("missing high surrogate character in surrogate pair"); - } - $is_utf8 = 1; - $s .= JSON_PP_decode_surrogates($utf16, $u) || next; - $utf16 = undef; - } - else { - if (defined $utf16) { - decode_error("surrogate pair expected"); - } - - if ( ( my $hex = hex( $u ) ) > 127 ) { - $is_utf8 = 1; - $s .= JSON_PP_decode_unicode($u) || next; - } - else { - $s .= chr $hex; - } - } - - } - else{ - unless ($loose) { - $at -= 2; - decode_error('illegal backslash escape sequence in string'); - } - $s .= $ch; - } - } - else{ - - if ( ord $ch > 127 ) { - if ( $utf8 ) { - unless( $ch = is_valid_utf8($ch) ) { - $at -= 1; - decode_error("malformed UTF-8 character in JSON string"); - } - else { - $at += $utf8_len - 1; - } - } - else { - utf8::encode( $ch ); - } - - $is_utf8 = 1; - } - - if (!$loose) { - if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok - $at--; - decode_error('invalid character encountered while parsing JSON string'); - } - } - - $s .= $ch; - } - } - } - - decode_error("unexpected end of string while parsing JSON string"); - } - - - sub white { - while( defined $ch ){ - if($ch le ' '){ - next_chr(); - } - elsif($ch eq '/'){ - next_chr(); - if(defined $ch and $ch eq '/'){ - 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r"); - } - elsif(defined $ch and $ch eq '*'){ - next_chr(); - while(1){ - if(defined $ch){ - if($ch eq '*'){ - if(defined(next_chr()) and $ch eq '/'){ - next_chr(); - last; - } - } - else{ - next_chr(); - } - } - else{ - decode_error("Unterminated comment"); - } - } - next; - } - else{ - $at--; - decode_error("malformed JSON string, neither array, object, number, string or atom"); - } - } - else{ - if ($relaxed and $ch eq '#') { # correctly? - pos($text) = $at; - $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g; - $at = pos($text); - next_chr; - next; - } - - last; - } - } - } - - - sub array { - my $a = $_[0] || []; # you can use this code to use another array ref object. - - decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') - if (++$depth > $max_depth); - - next_chr(); - white(); - - if(defined $ch and $ch eq ']'){ - --$depth; - next_chr(); - return $a; - } - else { - while(defined($ch)){ - push @$a, value(); - - white(); - - if (!defined $ch) { - last; - } - - if($ch eq ']'){ - --$depth; - next_chr(); - return $a; - } - - if($ch ne ','){ - last; - } - - next_chr(); - white(); - - if ($relaxed and $ch eq ']') { - --$depth; - next_chr(); - return $a; - } - - } - } - - decode_error(", or ] expected while parsing array"); - } - - - sub object { - my $o = $_[0] || {}; # you can use this code to use another hash ref object. - my $k; - - decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') - if (++$depth > $max_depth); - next_chr(); - white(); - - if(defined $ch and $ch eq '}'){ - --$depth; - next_chr(); - if ($F_HOOK) { - return _json_object_hook($o); - } - return $o; - } - else { - while (defined $ch) { - $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string(); - white(); - - if(!defined $ch or $ch ne ':'){ - $at--; - decode_error("':' expected"); - } - - next_chr(); - $o->{$k} = value(); - white(); - - last if (!defined $ch); - - if($ch eq '}'){ - --$depth; - next_chr(); - if ($F_HOOK) { - return _json_object_hook($o); - } - return $o; - } - - if($ch ne ','){ - last; - } - - next_chr(); - white(); - - if ($relaxed and $ch eq '}') { - --$depth; - next_chr(); - if ($F_HOOK) { - return _json_object_hook($o); - } - return $o; - } - - } - - } - - $at--; - decode_error(", or } expected while parsing object/hash"); - } - - - sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition - my $key; - while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){ - $key .= $ch; - next_chr(); - } - return $key; - } - - - sub word { - my $word = substr($text,$at-1,4); - - if($word eq 'true'){ - $at += 3; - next_chr; - return $JSON::PP::true; - } - elsif($word eq 'null'){ - $at += 3; - next_chr; - return undef; - } - elsif($word eq 'fals'){ - $at += 3; - if(substr($text,$at,1) eq 'e'){ - $at++; - next_chr; - return $JSON::PP::false; - } - } - - $at--; # for decode_error report - - decode_error("'null' expected") if ($word =~ /^n/); - decode_error("'true' expected") if ($word =~ /^t/); - decode_error("'false' expected") if ($word =~ /^f/); - decode_error("malformed JSON string, neither array, object, number, string or atom"); - } - - - sub number { - my $n = ''; - my $v; - - # According to RFC4627, hex or oct digts are invalid. - if($ch eq '0'){ - my $peek = substr($text,$at,1); - my $hex = $peek =~ /[xX]/; # 0 or 1 - - if($hex){ - decode_error("malformed number (leading zero must not be followed by another digit)"); - ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/); - } - else{ # oct - ($n) = ( substr($text, $at) =~ /^([0-7]+)/); - if (defined $n and length $n > 1) { - decode_error("malformed number (leading zero must not be followed by another digit)"); - } - } - - if(defined $n and length($n)){ - if (!$hex and length($n) == 1) { - decode_error("malformed number (leading zero must not be followed by another digit)"); - } - $at += length($n) + $hex; - next_chr; - return $hex ? hex($n) : oct($n); - } - } - - if($ch eq '-'){ - $n = '-'; - next_chr; - if (!defined $ch or $ch !~ /\d/) { - decode_error("malformed number (no digits after initial minus)"); - } - } - - while(defined $ch and $ch =~ /\d/){ - $n .= $ch; - next_chr; - } - - if(defined $ch and $ch eq '.'){ - $n .= '.'; - - next_chr; - if (!defined $ch or $ch !~ /\d/) { - decode_error("malformed number (no digits after decimal point)"); - } - else { - $n .= $ch; - } - - while(defined(next_chr) and $ch =~ /\d/){ - $n .= $ch; - } - } - - if(defined $ch and ($ch eq 'e' or $ch eq 'E')){ - $n .= $ch; - next_chr; - - if(defined($ch) and ($ch eq '+' or $ch eq '-')){ - $n .= $ch; - next_chr; - if (!defined $ch or $ch =~ /\D/) { - decode_error("malformed number (no digits after exp sign)"); - } - $n .= $ch; - } - elsif(defined($ch) and $ch =~ /\d/){ - $n .= $ch; - } - else { - decode_error("malformed number (no digits after exp sign)"); - } - - while(defined(next_chr) and $ch =~ /\d/){ - $n .= $ch; - } - - } - - $v .= $n; - - if ($v !~ /[.eE]/ and length $v > $max_intsize) { - if ($allow_bigint) { # from Adam Sussman - require Math::BigInt; - return Math::BigInt->new($v); - } - else { - return "$v"; - } - } - elsif ($allow_bigint) { - require Math::BigFloat; - return Math::BigFloat->new($v); - } - - return 0+$v; - } - - - sub is_valid_utf8 { - - $utf8_len = $_[0] =~ /[\x00-\x7F]/ ? 1 - : $_[0] =~ /[\xC2-\xDF]/ ? 2 - : $_[0] =~ /[\xE0-\xEF]/ ? 3 - : $_[0] =~ /[\xF0-\xF4]/ ? 4 - : 0 - ; - - return unless $utf8_len; - - my $is_valid_utf8 = substr($text, $at - 1, $utf8_len); - - return ( $is_valid_utf8 =~ /^(?: + /}}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;sub encode_json ($) {($JSON ||=__PACKAGE__->new->utf8)->encode(@_)}sub decode_json {($JSON ||=__PACKAGE__->new->utf8)->decode(@_)}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.")}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)}sub pretty {my ($self,$v)=@_;my$enable=defined$v ? $v : 1;if ($enable){$self->indent(1)->indent_length(3)->space_before(1)->space_after(1)}else {$self->indent(0)->space_before(0)->space_after(0)}$self}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.")}{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);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){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);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)}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);my$flags=$b_obj->FLAGS;return$value if$flags & (B::SVp_IOK | B::SVp_NOK)and!($flags & B::SVp_POK);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,}}}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 {my$uni=$_[0]- 0x10000;return ($uni / 0x400 + 0xD800,$uni % 0x400 + 0xDC00)}sub _is_bignum {$_[0]->isa('Math::BigInt')or $_[0]->isa('Math::BigFloat')}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}}}{my%escapes=(b=>"\x8",t=>"\x9",n=>"\xA",f=>"\xC",r=>"\xD",'\\'=>'\\','"'=>'"','/'=>'/',);my$text;my$at;my$ch;my$len;my$depth;my$encoding;my$is_valid_utf8;my$utf8_len;my$utf8;my$max_depth;my$max_size;my$relaxed;my$cb_object;my$cb_sk_object;my$F_HOOK;my$allow_bigint;my$singlequote;my$loose;my$allow_barekey;sub PP_decode_json {my ($self,$opt);($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)}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();my$valid_start=defined$ch;my$result=value();return undef if (!$result && ($opt & 0x10000000));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;my$consumed=defined$ch ? $at - 1 : $at;white();if ($ch){return ($result,$consumed)if ($opt & 0x00000001);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='';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'){my$u='';for(1..4){$ch=next_chr();last OUTER if($ch !~ /[0-9a-fA-F]/);$u .= $ch}if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/){$utf16=$u}elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/){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]/){$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 '#'){pos($text)=$at;$text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;$at=pos($text);next_chr;next}last}}}sub array {my$a=$_[0]|| [];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]|| {};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 {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--;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;if($ch eq '0'){my$peek=substr($text,$at,1);my$hex=$peek =~ /[xX]/;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{($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){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] @@ -7653,122 +281,7 @@ $fatpacked{"JSON/PP.pm"} = <<'JSON_PP'; |[\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| + )$/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*' : 'C*' ;for my$c (unpack($type,$str)){$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,}}}sub _decode_surrogates {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}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){package JSON::PP;require subs;subs->import('join');eval q| sub join { return '' if (@_ < 2); my $j = shift; @@ -7776,26 +289,7 @@ $fatpacked{"JSON/PP.pm"} = <<'JSON_PP'; 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_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; @@ -7804,334 +298,68 @@ $fatpacked{"JSON/PP.pm"} = <<'JSON_PP'; } $_[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 - + } if ($] >= 5.006)}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{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;hex($1)}}}$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;use constant INCR_M_STR=>1;use constant INCR_M_BS=>2;use constant INCR_M_JSON=>3;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 {$self->{incr_parsing}=1;my$obj=$self->_incr_parse($coder,$self->{incr_text});$self->{incr_parsing}=0 if defined$obj;return$obj ? $obj : undef}}}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; JSON_PP $fatpacked{"JSON/PP/Boolean.pm"} = <<'JSON_PP_BOOLEAN'; - use JSON::PP (); - use strict; - - 1; - + 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); +$fatpacked{"Module/CPANfile.pm"} = <<'MODULE_CPANFILE'; + package Module::CPANfile;use strict;use warnings;use Cwd;use Carp ();use Module::CPANfile::Environment;use Module::CPANfile::Result;our$VERSION='1.0002';sub new {my($class,$file)=@_;bless {},$class}sub load {my($proto,$file)=@_;my$self=ref$proto ? $proto : $proto->new;$self->parse($file || Cwd::abs_path('cpanfile'));$self}sub save {my($self,$path)=@_;open my$out,">",$path or die "$path: $!";print {$out}$self->to_string}sub parse {my($self,$file)=@_;my$code=do {open my$fh,"<",$file or die "$file: $!";join '',<$fh>};my$env=Module::CPANfile::Environment->new($file);$self->{result}=$env->parse($code)or die $@}sub from_prereqs {my($proto,$prereqs)=@_;my$self=$proto->new;$self->{result}=Module::CPANfile::Result->from_prereqs($prereqs);$self}sub features {my$self=shift;map$self->feature($_),keys %{$self->{result}{features}}}sub feature {my($self,$identifier)=@_;my$data=$self->{result}{features}{$identifier}or Carp::croak("Unknown feature '$identifier'");require CPAN::Meta::Feature;CPAN::Meta::Feature->new($data->{identifier},{description=>$data->{description},prereqs=>$data->{spec},})}sub prereq {shift->prereqs}sub prereqs {my$self=shift;require CPAN::Meta::Prereqs;CPAN::Meta::Prereqs->new($self->prereq_specs)}sub effective_prereqs {my($self,$features)=@_;$self->prereqs_with(@{$features || []})}sub prereqs_with {my($self,@feature_identifiers)=@_;my$prereqs=$self->prereqs;my@others=map {$self->feature($_)->prereqs}@feature_identifiers;$prereqs->with_merged_prereqs(\@others)}sub prereq_specs {my$self=shift;$self->{result}{spec}}sub merge_meta {my($self,$file,$version)=@_;require CPAN::Meta;$version ||=$file =~ /\.yml$/ ? '1.4' : '2';my$prereq=$self->prereqs;my$meta=CPAN::Meta->load_file($file);my$prereqs_hash=$prereq->with_merged_prereqs($meta->effective_prereqs)->as_string_hash;my$struct={%{$meta->as_struct},prereqs=>$prereqs_hash };CPAN::Meta->new($struct)->save($file,{version=>$version })}sub _dump {my$str=shift;require Data::Dumper;chomp(my$value=Data::Dumper->new([$str])->Terse(1)->Dump);$value}sub to_string {my($self,$include_empty)=@_;my$prereqs=$self->{result}{spec};my$code='';$code .= $self->_dump_prereqs($self->{result}{spec},$include_empty);for my$feature (values %{$self->{result}{features}}){$code .= sprintf "feature %s, %s => sub {\n",_dump($feature->{identifier}),_dump($feature->{description});$code .= $self->_dump_prereqs($feature->{spec},$include_empty,4);$code .= "}\n\n"}$code =~ s/\n+$/\n/s;$code}sub _dump_prereqs {my($self,$prereqs,$include_empty,$base_indent)=@_;my$code='';for my$phase (qw(runtime configure build test develop)){my$indent=$phase eq 'runtime' ? '' : ' ';$indent=(' ' x ($base_indent || 0)).$indent;my($phase_code,$requirements);$phase_code .= "on $phase => sub {\n" unless$phase eq 'runtime';for my$type (qw(requires recommends suggests conflicts)){for my$mod (sort keys %{$prereqs->{$phase}{$type}}){my$ver=$prereqs->{$phase}{$type}{$mod};$phase_code .= $ver eq '0' ? "${indent}$type '$mod';\n" : "${indent}$type '$mod', '$ver';\n";$requirements++}}$phase_code .= "\n" unless$requirements;$phase_code .= "};\n" unless$phase eq 'runtime';$code .= $phase_code ."\n" if$requirements or $include_empty}$code =~ s/\n+$/\n/s;$code}1; +MODULE_CPANFILE + +$fatpacked{"Module/CPANfile/Environment.pm"} = <<'MODULE_CPANFILE_ENVIRONMENT'; + package Module::CPANfile::Environment;use strict;use warnings;use Module::CPANfile::Result;use Carp ();my@bindings=qw(on requires recommends suggests conflicts feature osname configure_requires build_requires test_requires author_requires);my$file_id=1;sub new {my($class,$file)=@_;bless {file=>$file,},$class}sub bind {my$class=shift;my$pkg=caller;my$result=Module::CPANfile::Result->new;for my$binding (@bindings){no strict 'refs';*{"$pkg\::$binding"}=sub {$result->$binding(@_)}}return$result}sub parse {my($self,$code)=@_;my($res,$err);{local $@;$file_id++;$res=eval <<EVAL;$err=$@}if ($err){die "Parsing $self->{file} failed: $err"};return$res}1; + package Module::CPANfile::Sandbox$file_id; + no warnings; + my \$_result; + BEGIN { \$_result = Module::CPANfile::Environment->bind } - my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal + # line 1 "$self->{file}" + $code; - my $PKG_REGEXP = qr{ # match a package declaration + \$_result; + EVAL +MODULE_CPANFILE_ENVIRONMENT + +$fatpacked{"Module/CPANfile/Result.pm"} = <<'MODULE_CPANFILE_RESULT'; + package Module::CPANfile::Result;use strict;sub from_prereqs {my($class,$spec)=@_;bless {phase=>'runtime',spec=>$spec,},$class}sub new {bless {phase=>'runtime',features=>{},feature=>undef,spec=>{},},shift}sub on {my($self,$phase,$code)=@_;local$self->{phase}=$phase;$code->()}sub feature {my($self,$identifier,$description,$code)=@_;if (@_==3 && ref($description)eq 'CODE'){$code=$description;$description=$identifier}unless (ref$description eq '' && ref$code eq 'CODE'){Carp::croak("Usage: feature 'identifier', 'Description' => sub { ... }")}local$self->{feature}=$self->{features}{$identifier}={identifier=>$identifier,description=>$description,spec=>{}};$code->()}sub osname {die "TODO"}sub requires {my($self,$module,$requirement)=@_;($self->{feature}? $self->{feature}{spec}: $self->{spec})->{$self->{phase}}{requires}{$module}=$requirement || 0}sub recommends {my($self,$module,$requirement)=@_;($self->{feature}? $self->{feature}{spec}: $self->{spec})->{$self->{phase}}{recommends}{$module}=$requirement || 0}sub suggests {my($self,$module,$requirement)=@_;($self->{feature}? $self->{feature}{spec}: $self->{spec})->{$self->{phase}}{suggests}{$module}=$requirement || 0}sub conflicts {my($self,$module,$requirement)=@_;($self->{feature}? $self->{feature}{spec}: $self->{spec})->{$self->{phase}}{conflicts}{$module}=$requirement || 0}sub configure_requires {my($self,@args)=@_;$self->on(configure=>sub {$self->requires(@args)})}sub build_requires {my($self,@args)=@_;$self->on(build=>sub {$self->requires(@args)})}sub test_requires {my($self,@args)=@_;$self->on(test=>sub {$self->requires(@args)})}sub author_requires {my($self,@args)=@_;$self->on(develop=>sub {$self->requires(@args)})}1; +MODULE_CPANFILE_RESULT + +$fatpacked{"Module/Metadata.pm"} = <<'MODULE_METADATA'; + package Module::Metadata;use strict;use vars qw($VERSION);$VERSION='1.000016';$VERSION=eval$VERSION;use Carp qw/croak/;use File::Spec;use IO::File;use version 0.87;BEGIN {if ($INC{'Log/Contextual.pm'}){Log::Contextual->import('log_info')}else {*log_info=sub (&) {warn $_[0]->()}}}use File::Find qw(find);my$V_NUM_REGEXP=qr{v?[0-9._]+};my$PKG_FIRST_WORD_REGEXP=qr{ # the FIRST word in a package name + [a-zA-Z_] # the first word CANNOT start with a digit + (?: + [\w']? # can contain letters, digits, _, or ticks + \w # But, NO multi-ticks or trailing ticks + )* + }x;my$PKG_ADDL_WORD_REGEXP=qr{ # the 2nd+ word in a package name + \w # the 2nd+ word CAN start with digits + (?: + [\w']? # and can contain letters or ticks + \w # But, NO multi-ticks or trailing ticks + )* + }x;my$PKG_NAME_REGEXP=qr{ # match a package name + (?: :: )? # a pkg name can start with aristotle + $PKG_FIRST_WORD_REGEXP # a package word + (?: + (?: :: )+ ### aristotle (allow one or many times) + $PKG_ADDL_WORD_REGEXP ### a package word + )* # ^ zero, one or many times + (?: + :: # allow trailing aristotle + )? + }x;my$PKG_REGEXP=qr{ # match a package declaration ^[\s\{;]* # intro chars on a line package # the word 'package' \s+ # whitespace - ([\w:]+) # a package name + ($PKG_NAME_REGEXP) # a package name \s* # optional whitespace ($V_NUM_REGEXP)? # optional version number \s* # optional whitesapce [;\{] # semicolon line terminator or block start (since 5.16) - }x; - - my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name + }x;my$VARNAME_REGEXP=qr{ # match fully-qualified VERSION name ([\$*]) # sigil - $ or * ( ( # optional leading package name @@ -8140,9 +368,7 @@ $fatpacked{"Module/Metadata.pm"} = <<'MODULE_METADATA'; )? VERSION )\b - }x; - - my $VERS_REGEXP = qr{ # match a VERSION definition + }x;my$VERS_REGEXP=qr{ # match a VERSION definition (?: \(\s*$VARNAME_REGEXP\s*\) # with parens | @@ -8150,478 +376,7 @@ $fatpacked{"Module/Metadata.pm"} = <<'MODULE_METADATA'; ) \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() + }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 =~ /[=<>!,]/){}elsif (ref$version eq 'version'){$version=$version->is_qv ? $version->normal : $version->stringify}elsif ($version =~ /^[^v][^.]*\.[^.]+\./){$version="v$version"}else {}return$version};my$resolve_module_versions=sub {my$packages=shift;my($file,$version);my$err='';for my$p (@$packages){if (defined($p->{version})){if (defined($version)){if ($compare_versions->($version,'!=',$p->{version})){$err .= " $p->{file} ($p->{version})\n"}else {}}else {$file=$p->{file};$version=$p->{version}}}$file ||=$p->{file}if defined($p->{file})}if ($err){$err=" $file ($version)\n" .$err}my%result=(file=>$file,version=>$version,err=>$err);return \%result};sub provides {my$class=shift;croak "provides() requires key/value pairs \n" if @_ % 2;my%args=@_;croak "provides() takes only one of 'dir' or 'files'\n" if$args{dir}&& $args{files};croak "provides() requires a 'version' argument" unless defined$args{version};croak "provides() does not support version '$args{version}' metadata" unless grep {$args{version}eq $_}qw/1.4 2/;$args{prefix}='lib' unless defined$args{prefix};my$p;if ($args{dir}){$p=$class->package_versions_from_directory($args{dir})}else {croak "provides() requires 'files' to be an array reference\n" unless ref$args{files}eq 'ARRAY';$p=$class->package_versions_from_directory($args{files})}if (length$args{prefix}){$args{prefix}=~ s{/$}{};for my$v (values %$p){$v->{file}="$args{prefix}/$v->{file}"}}return$p}sub package_versions_from_directory {my ($class,$dir,$files)=@_;my@files;if ($files){@files=@$files}else {find({wanted=>sub {push@files,$_ if -f $_ && /\.pm$/},no_chdir=>1,},$dir)}my(%prime,%alt);for my$file (@files){my$mapped_filename=File::Spec::Unix->abs2rel($file,$dir);my@path=split(/\//,$mapped_filename);(my$prime_package=join('::',@path))=~ s/\.pm$//;my$pm_info=$class->new_from_file($file);for my$package ($pm_info->packages_inside){next if$package eq 'main';next if$package eq 'DB';next if grep /^_/,split(/::/,$package);my$version=$pm_info->version($package);$prime_package=$package if lc($prime_package)eq lc($package);if ($package eq $prime_package){if (exists($prime{$package})){croak "Unexpected conflict in '$package'; multiple versions found.\n"}else {$mapped_filename="$package.pm" if lc("$package.pm")eq lc($mapped_filename);$prime{$package}{file}=$mapped_filename;$prime{$package}{version}=$version if defined($version)}}else {push(@{$alt{$package}},{file=>$mapped_filename,version=>$version,})}}}for my$package (keys(%alt)){my$result=$resolve_module_versions->($alt{$package});if (exists($prime{$package})){if ($result->{err}){log_info {"Found conflicting versions for package '$package'\n" ." $prime{$package}{file} ($prime{$package}{version})\n" .$result->{err}}}elsif (defined($result->{version})){if (exists($prime{$package}{version})&& defined($prime{$package}{version})){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 {$prime{$package}{file}=$result->{file};$prime{$package}{version}=$result->{version}}}else {}}else {if ($result->{err}){log_info {"Found conflicting versions for package '$package'\n" .$result->{err}}}$prime{$package}{file}=$result->{file};$prime{$package}{version}=$result->{version}if defined($result->{version})}}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)}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}sub _do_find_module {my$class=shift;my$module=shift || croak 'find_module_by_name() requires a package name';my$dirs=shift || \@INC;my$file=File::Spec->catfile(split(/::/,$module));for my$dir (@$dirs){my$testfile=File::Spec->catfile($dir,$file);return [File::Spec->rel2abs($testfile),$dir ]if -e $testfile and!-d _;return [File::Spec->rel2abs("$testfile.pm"),$dir ]if -e "$testfile.pm"}return}sub find_module_by_name {my$found=shift()->_do_find_module(@_)or return;return$found->[0]}sub find_module_dir_by_name {my$found=shift()->_do_find_module(@_)or return;return$found->[1]}sub _parse_version_expression {my$self=shift;my$line=shift;my($sig,$var,$pkg);if ($line =~ /$VERS_REGEXP/o){($sig,$var,$pkg)=$2 ? ($1,$2,$3): ($4,$5,$6);if ($pkg){$pkg=($pkg eq '::')? 'main' : $pkg;$pkg =~ s/::$//}}return ($sig,$var,$pkg)}sub _parse_file {my$self=shift;my$filename=$self->{filename};my$fh=IO::File->new($filename)or croak("Can't open '$filename': $!");$self->_handle_bom($fh,$filename);$self->_parse_fh($fh)}sub _handle_bom {my ($self,$fh,$filename)=@_;my$pos=$fh->getpos;return unless defined$pos;my$buf=' ' x 2;my$count=$fh->read($buf,length$buf);return unless defined$count and $count >= 2;my$encoding;if ($buf eq "\x{FE}\x{FF}"){$encoding='UTF-16BE'}elsif ($buf eq "\x{FF}\x{FE}"){$encoding='UTF-16LE'}elsif ($buf eq "\x{EF}\x{BB}"){$buf=' ';$count=$fh->read($buf,length$buf);if (defined$count and $count >= 1 and $buf eq "\x{BF}"){$encoding='UTF-8'}}if (defined$encoding){if ("$]" >= 5.008){binmode($fh,":encoding($encoding)")}}else {$fh->setpos($pos)or croak(sprintf "Can't reset position to the top of '$filename'")}return$encoding}sub _parse_fh {my ($self,$fh)=@_;my($in_pod,$seen_end,$need_vers)=(0,0,0);my(@pkgs,%vers,%pod,@pod);my$pkg='main';my$pod_sect='';my$pod_data='';my$in_end=0;while (defined(my$line=<$fh>)){my$line_num=$.;chomp($line);my$is_cut;if ($line =~ /^=([a-zA-Z].*)/){my$cmd=$1;$is_cut=$cmd =~ /^cut(?:[^a-zA-Z]|$)/;$in_pod=!$is_cut}if ($in_pod){if ($line =~ /^=head[1-4]\s+(.+)\s*$/){push(@pod,$1);if ($self->{collect_pod}&& length($pod_data)){$pod{$pod_sect}=$pod_data;$pod_data=''}$pod_sect=$1}elsif ($self->{collect_pod}){$pod_data .= "$line\n"}}elsif ($is_cut){if ($self->{collect_pod}&& length($pod_data)){$pod{$pod_sect}=$pod_data;$pod_data=''}$pod_sect=''}else {next if$in_end;next if$line =~ /^\s*#/;if ($line eq '__END__'){$in_end++;next}last if$line eq '__DATA__';my($vers_sig,$vers_fullname,$vers_pkg)=($line =~ /VERSION/)? $self->_parse_version_expression($line): ();if ($line =~ /$PKG_REGEXP/o){$pkg=$1;push(@pkgs,$pkg)unless grep($pkg eq $_,@pkgs);$vers{$pkg}=$2 unless exists($vers{$pkg});$need_vers=defined $2 ? 0 : 1}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)}}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')}elsif (!exists($vers{main})&& $pkg eq 'main' && $line =~ /\w+/){$need_vers=1;$vers{main}='';push(@pkgs,'main')}elsif ($vers_fullname && $need_vers){$need_vers=0;my$v=$self->_evaluate_version_line($vers_sig,$vers_fullname,$line);unless (defined$vers{$pkg}&& length$vers{$pkg}){$vers{$pkg}=$v}}}}if ($self->{collect_pod}&& length($pod_data)){$pod{$pod_sect}=$pod_data}$self->{versions}=\%vers;$self->{packages}=\@pkgs;$self->{pod}=\%pod;$self->{pod_headings}=\@pod}{my$pn=0;sub _evaluate_version_line {my$self=shift;my($sigil,$var,$line)=@_;my$vsub;$pn++;my$eval=qq{BEGIN { q# Hide from _packages_inside() #; package Module::Metadata::_version::p$pn; use version; no strict; @@ -8632,455 +387,27 @@ $fatpacked{"Module/Metadata.pm"} = <<'MODULE_METADATA'; $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; - + }};local $^W;eval$eval;if ($@ =~ /Can't locate/ && -d 'lib'){local@INC=('lib',@INC);eval$eval}warn "Error evaling version line '$eval' in $self->{filename}: $@\n" if $@;(ref($vsub)eq 'CODE')or croak "failed to build version sub for $self->{filename}";my$result=eval {$vsub->()};croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n" if $@;my$version=eval {_dwim_version($result)};croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n" unless defined$version;return$version}}{my@version_prep=(sub {return shift},sub {my$v=shift;$v =~ s{([0-9])[a-z-].*$}{$1}i;return$v},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},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 $@;last if defined$version}croak$error unless defined$version;return$version}}sub name {$_[0]->{module}}sub filename {$_[0]->{filename}}sub packages_inside {@{$_[0]->{packages}}}sub pod_inside {@{$_[0]->{pod_headings}}}sub contains_pod {0+@{$_[0]->{pod_headings}}}sub version {my$self=shift;my$mod=shift || $self->{module};my$vers;if (defined($mod)&& length($mod)&& exists($self->{versions}{$mod})){return$self->{versions}{$mod}}else {return undef}}sub pod {my$self=shift;my$sect=shift;if (defined($sect)&& length($sect)&& exists($self->{pod}{$sect})){return$self->{pod}{$sect}}else {return undef}}1; 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__
-
+ use strict;package Parse::CPAN::Meta;our$VERSION='1.4407';use Carp 'croak';sub HAVE_UTF8 () {$] >= 5.007003}sub IO_LAYER () {$] >= 5.008001 ? ":utf8" : ""}BEGIN {if (HAVE_UTF8){eval "require utf8;";die "Failed to load UTF-8 support" if $@}require 5.004;require Exporter;@Parse::CPAN::Meta::ISA=qw{Exporter};@Parse::CPAN::Meta::EXPORT_OK=qw{Load LoadFile}}sub load_file {my ($class,$filename)=@_;if ($filename =~ /\.ya?ml$/){return$class->load_yaml_string(_slurp($filename))}if ($filename =~ /\.json$/){return$class->load_json_string(_slurp($filename))}croak("file type cannot be determined by filename")}sub load_yaml_string {my ($class,$string)=@_;my$backend=$class->yaml_backend();my$data=eval {no strict 'refs';&{"$backend\::Load"}($string)};if ($@){croak$backend->can('errstr')? $backend->errstr : $@}return$data || {}}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};eval {require$file;1}or return 0;if (defined$version){eval {$module->VERSION($version);1}or return 0}return 1}sub LoadFile ($) {require CPAN::Meta::YAML;my$object=CPAN::Meta::YAML::LoadFile(shift)or die CPAN::Meta::YAML->errstr;return$object}sub Load ($) {require CPAN::Meta::YAML;my$object=CPAN::Meta::YAML::Load(shift)or die CPAN::Meta::YAML->errstr;return$object}1; PARSE_CPAN_META -$fatpacked{"Try/Tiny.pm"} = <<'TRY_TINY'; - package Try::Tiny; - - use strict; - #use warnings; - - use vars qw(@EXPORT @EXPORT_OK $VERSION @ISA); - - BEGIN { - require Exporter; - @ISA = qw(Exporter); - } - - $VERSION = "0.09"; - - $VERSION = eval $VERSION; - - @EXPORT = @EXPORT_OK = qw(try catch finally); - - $Carp::Internal{+__PACKAGE__}++; - - # Need to prototype as @ not $$ because of the way Perl evaluates the prototype. - # Keeping it at $$ means you only ever get 1 sub because we need to eval in a list - # context & not a scalar one - - sub try (&;@) { - my ( $try, @code_refs ) = @_; - - # we need to save this here, the eval block will be in scalar context due - # to $failed - my $wantarray = wantarray; - - my ( $catch, @finally ); - - # find labeled blocks in the argument list. - # catch and finally tag the blocks by blessing a scalar reference to them. - foreach my $code_ref (@code_refs) { - next unless $code_ref; - - my $ref = ref($code_ref); - - if ( $ref eq 'Try::Tiny::Catch' ) { - $catch = ${$code_ref}; - } elsif ( $ref eq 'Try::Tiny::Finally' ) { - push @finally, ${$code_ref}; - } else { - use Carp; - confess("Unknown code ref type given '${ref}'. Check your usage & try again"); - } - } - - # save the value of $@ so we can set $@ back to it in the beginning of the eval - my $prev_error = $@; - - my ( @ret, $error, $failed ); - - # FIXME consider using local $SIG{__DIE__} to accumulate all errors. It's - # not perfect, but we could provide a list of additional errors for - # $catch->(); - - { - # localize $@ to prevent clobbering of previous value by a successful - # eval. - local $@; - - # failed will be true if the eval dies, because 1 will not be returned - # from the eval body - $failed = not eval { - $@ = $prev_error; - - # evaluate the try block in the correct context - if ( $wantarray ) { - @ret = $try->(); - } elsif ( defined $wantarray ) { - $ret[0] = $try->(); - } else { - $try->(); - }; - - return 1; # properly set $fail to false - }; - - # copy $@ to $error; when we leave this scope, local $@ will revert $@ - # back to its previous value - $error = $@; - } - - # set up a scope guard to invoke the finally block at the end - my @guards = - map { Try::Tiny::ScopeGuard->_new($_, $failed ? $error : ()) } - @finally; - - # at this point $failed contains a true value if the eval died, even if some - # destructor overwrote $@ as the eval was unwinding. - if ( $failed ) { - # if we got an error, invoke the catch block. - if ( $catch ) { - # This works like given($error), but is backwards compatible and - # sets $_ in the dynamic scope for the body of C<$catch> - for ($error) { - return $catch->($error); - } - - # in case when() was used without an explicit return, the C<for> - # loop will be aborted and there's no useful return value - } - - return; - } else { - # no failure, $@ is back to what it was, everything is fine - return $wantarray ? @ret : $ret[0]; - } - } - - sub catch (&;@) { - my ( $block, @rest ) = @_; - - return ( - bless(\$block, 'Try::Tiny::Catch'), - @rest, - ); - } - - sub finally (&;@) { - my ( $block, @rest ) = @_; - - return ( - bless(\$block, 'Try::Tiny::Finally'), - @rest, - ); - } - - { - package # hide from PAUSE - Try::Tiny::ScopeGuard; - - sub _new { - shift; - bless [ @_ ]; - } - - sub DESTROY { - my @guts = @{ shift() }; - my $code = shift @guts; - $code->(@guts); - } - } - - __PACKAGE__ - - __END__ - -TRY_TINY +$fatpacked{"String/ShellQuote.pm"} = <<'STRING_SHELLQUOTE'; + package String::ShellQuote;use strict;use vars qw($VERSION @ISA @EXPORT);require Exporter;$VERSION='1.04';@ISA=qw(Exporter);@EXPORT=qw(shell_quote shell_quote_best_effort shell_comment_quote);sub croak {require Carp;goto&Carp::croak}sub _shell_quote_backend {my@in=@_;my@err=();if (0){require RS::Handy;print RS::Handy::data_dump(\@in)}return \@err,'' unless@in;my$ret='';my$saw_non_equal=0;for (@in){if (!defined $_ or $_ eq ''){$_="''";next}if (s/\x00//g){push@err,"No way to quote string containing null (\\000) bytes"}my$escape=0;if (/=/){if (!$saw_non_equal){$escape=1}}else {$saw_non_equal=1}if (m|[^\w!%+,\-./:=@^]|){$escape=1}if ($escape || (!$saw_non_equal && /=/)){s/'/'\\''/g;s|((?:'\\''){2,})|q{'"} . (q{'} x (length($1) / 4)) . q{"'}|ge;$_="'$_'";s/^''//;s/''$//}}continue {$ret .= "$_ "}chop$ret;return \@err,$ret}sub shell_quote {my ($rerr,$s)=_shell_quote_backend @_;if (@$rerr){my%seen;@$rerr=grep {!$seen{$_}++}@$rerr;my$s=join '',map {"shell_quote(): $_\n"}@$rerr;chomp$s;croak$s}return$s}sub shell_quote_best_effort {my ($rerr,$s)=_shell_quote_backend @_;return$s}sub shell_comment_quote {return '' unless @_;unless (@_==1){croak "Too many arguments to shell_comment_quote " ."(got " .@_ ." expected 1)"}local $_=shift;s/\n/\n#/g;return $_}1; +STRING_SHELLQUOTE + +$fatpacked{"aliased.pm"} = <<'ALIASED'; + package aliased;our$VERSION='0.31';$VERSION=eval$VERSION;require Exporter;@ISA=qw(Exporter);@EXPORT=qw(alias prefix);use strict;sub _croak {require Carp;Carp::croak(@_)}sub import {my ($class,$package,$alias,@import)=@_;if (@_ <= 1){$class->export_to_level(1);return}my$callpack=caller(0);_load_alias($package,$callpack,@import);_make_alias($package,$callpack,$alias)}sub _get_alias {my$package=shift;$package =~ s/.*(?:::|')//;return$package}sub _make_alias {my ($package,$callpack,$alias)=@_;$alias ||=_get_alias($package);my$destination=$alias =~ /::/ ? $alias : "$callpack\::$alias";no strict 'refs';*{$destination}=sub () {$package}}sub _load_alias {my ($package,$callpack,@import)=@_;my$sigdie=$SIG{__DIE__};{my$code=@import==0 ? "package $callpack; use $package;" : "package $callpack; use $package (\@import)";eval$code;if (my$error=$@){$SIG{__DIE__}=$sigdie;_croak($error)}$sigdie=$SIG{__DIE__}if defined$SIG{__DIE__}}$SIG{__DIE__}=$sigdie if defined$sigdie;return$package}sub alias {my ($package,@import)=@_;my$callpack=scalar caller(0);return _load_alias($package,$callpack,@import)}sub prefix {my ($class)=@_;return sub {my ($name)=@_;my$callpack=caller(0);if (not @_){return _load_alias($class,$callpack)}elsif (@_==1 && defined$name){return _load_alias("${class}::$name",$callpack)}else {_croak("Too many arguments to prefix('$class')")}}}1; +ALIASED $fatpacked{"lib/core/only.pm"} = <<'LIB_CORE_ONLY'; - package lib::core::only; - - use strict; - use warnings FATAL => 'all'; - use Config; - - sub import { - @INC = @Config{qw(privlibexp archlibexp)}; - return - } - - 1; + 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'; + use strict;use warnings;package local::lib;use 5.008001;use File::Spec ();use File::Path ();use Config;our$VERSION='1.008011';our@KNOWN_FLAGS=qw(--self-contained --deactivate --deactivate-all);sub DEACTIVATE_ONE () {1}sub DEACTIVATE_ALL () {2}sub INTERPOLATE_ENV () {1}sub LITERAL_ENV () {0}sub import {my ($class,@args)=@_;my$perl5lib=$ENV{PERL5LIB}|| '';my%arg_store;for my$arg (@args){if ($arg =~ /−/){die <<'DEATH'}elsif(grep {$arg eq $_}@KNOWN_FLAGS){(my$flag=$arg)=~ s/--//;$arg_store{$flag}=1}elsif($arg =~ /^--/){die "Unknown import argument: $arg"}else {$arg_store{path}=$arg}}if($arg_store{'self-contained'}){die "FATAL: The local::lib --self-contained flag has never worked reliably and the original author, Mark Stosberg, was unable or unwilling to maintain it. As such, this flag has been removed from the local::lib codebase in order to prevent misunderstandings and potentially broken builds. The local::lib authors recommend that you look at the lib::core::only module shipped with this distribution in order to create a more robust environment that is equivalent to what --self-contained provided (although quite possibly not what you originally thought it provided due to the poor quality of the documentation, for which we apologise).\n"}my$deactivating=0;if ($arg_store{deactivate}){$deactivating=DEACTIVATE_ONE}if ($arg_store{'deactivate-all'}){$deactivating=DEACTIVATE_ALL}$arg_store{path}=$class->resolve_path($arg_store{path});$class->setup_local_lib_for($arg_store{path},$deactivating);for (@INC){next if ref;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 =~ /^~([^\/]+)/);my$tried_file_homedir;my$homedir=do {if (eval {require File::HomeDir}&& $File::HomeDir::VERSION >= 0.65){$tried_file_homedir=1;if (defined$user){File::HomeDir->users_home($user)}else {File::HomeDir->my_home}}else {if (defined$user){(getpwnam$user)[7]}else {if (defined$ENV{HOME}){$ENV{HOME}}else {(getpwuid $<)[7]}}}};unless (defined$homedir){require Carp;Carp::croak("Couldn't resolve homedir for " .(defined$user ? $user : 'current user').($tried_file_homedir ? '' : ' - consider installing File::HomeDir'))}$path =~ s/^~[^\/]*/$homedir/;$path}sub resolve_relative_path {my ($class,$path)=@_;$path=File::Spec->rel2abs($path)}sub setup_local_lib_for {my ($class,$path,$deactivating)=@_;my$interpolate=LITERAL_ENV;my@active_lls=$class->active_paths;$class->ensure_dir_structure_for($path);$path=Win32::GetShortPathName($path)if $^O eq 'MSWin32';if (!$deactivating){if (@active_lls && $active_lls[-1]eq $path){exit 0 if $0 eq '-';return}elsif (grep {$_ eq $path}@active_lls){$class->setup_env_hash_for($path,DEACTIVATE_ONE);$interpolate=INTERPOLATE_ENV}}if ($0 eq '-'){$class->print_environment_vars_for($path,$deactivating,$interpolate);exit 0}else {$class->setup_env_hash_for($path,$deactivating);my$arch_dir=$Config{archname};@INC=_uniq((map {(File::Spec->catdir($_,$arch_dir),$_)}split($Config{path_sep},$ENV{PERL5LIB})),@INC)}}sub install_base_bin_path {my ($class,$path)=@_;File::Spec->catdir($path,'bin')}sub install_base_perl_path {my ($class,$path)=@_;File::Spec->catdir($path,'lib','perl5')}sub install_base_arch_path {my ($class,$path)=@_;File::Spec->catdir($class->install_base_perl_path($path),$Config{archname})}sub ensure_dir_structure_for {my ($class,$path)=@_;unless (-d $path){warn "Attempting to create directory ${path}\n"}File::Path::mkpath($path);return}sub guess_shelltype {my$shellbin='sh';if(defined$ENV{'SHELL'}){my@shell_bin_path_parts=File::Spec->splitpath($ENV{'SHELL'});$shellbin=$shell_bin_path_parts[-1]}my$shelltype=do {local $_=$shellbin;if(/csh/){'csh'}else {'bourne'}};if (defined$ENV{'COMSPEC'}&& $^O ne 'cygwin'){my@shell_bin_path_parts=File::Spec->splitpath($ENV{'COMSPEC'});$shellbin=$shell_bin_path_parts[-1];$shelltype=do {local $_=$shellbin;if(/command\.com/){'win32'}elsif(/cmd\.exe/){'win32'}elsif(/4nt\.exe/){'win32'}else {$shelltype}}}return$shelltype}sub print_environment_vars_for {my ($class,$path,$deactivating,$interpolate)=@_;print$class->environment_vars_string_for($path,$deactivating,$interpolate)}sub environment_vars_string_for {my ($class,$path,$deactivating,$interpolate)=@_;my@envs=$class->build_environment_vars_for($path,$deactivating,$interpolate);my$out='';my$shelltype=$class->guess_shelltype;while (@envs){my ($name,$value)=(shift(@envs),shift(@envs));$value =~ s/(\\")/\\$1/g if defined$value;$out .= $class->${\"build_${shelltype}_env_declaration"}($name,$value)}return$out}sub build_bourne_env_declaration {my$class=shift;my($name,$value)=@_;return defined($value)? qq{export ${name}="${value}";\n} : qq{unset ${name};\n}}sub build_csh_env_declaration {my$class=shift;my($name,$value)=@_;return defined($value)? qq{setenv ${name} "${value}"\n} : qq{unsetenv ${name}\n}}sub build_win32_env_declaration {my$class=shift;my($name,$value)=@_;return defined($value)? qq{set ${name}=${value}\n} : qq{set ${name}=\n}}sub setup_env_hash_for {my ($class,$path,$deactivating)=@_;my%envs=$class->build_environment_vars_for($path,$deactivating,INTERPOLATE_ENV);@ENV{keys%envs}=values%envs}sub build_environment_vars_for {my ($class,$path,$deactivating,$interpolate)=@_;if ($deactivating==DEACTIVATE_ONE){return$class->build_deactivate_environment_vars_for($path,$interpolate)}elsif ($deactivating==DEACTIVATE_ALL){return$class->build_deact_all_environment_vars_for($path,$interpolate)}else {return$class->build_activate_environment_vars_for($path,$interpolate)}}my%ENV_LIST_VALUE_DEFAULTS=(interpolate=>INTERPOLATE_ENV,exists=>undef,filter=>sub {1},empty=>undef,);sub _env_list_value {my$options=shift;die(sprintf "unknown option '$_' at %s line %u\n",(caller)[1..2])for grep {!exists$ENV_LIST_VALUE_DEFAULTS{$_}}keys %$options;my%options=(%ENV_LIST_VALUE_DEFAULTS,%{$options});$options{exists}=$options{interpolate}==INTERPOLATE_ENV unless defined$options{exists};my%seen;my$value=join($Config{path_sep},map {ref $_ ? ($^O eq 'MSWin32' ? "%${$_}%" : "\$${$_}"): $_}grep {ref $_ || (defined $_ && length($_)> 0 &&!$seen{$_}++ && $options{filter}->($_)&& (!$options{exists}|| -e $_))}map {if (ref $_ eq 'SCALAR' && $options{interpolate}==INTERPOLATE_ENV){defined$ENV{${$_}}? (split /\Q$Config{path_sep}/,$ENV{${$_}}): ()}else {$_}}@_);return length($value)? $value : $options{empty}}sub build_activate_environment_vars_for {my ($class,$path,$interpolate)=@_;return (PERL_LOCAL_LIB_ROOT=>_env_list_value({interpolate=>$interpolate,exists=>0,empty=>'' },\'PERL_LOCAL_LIB_ROOT',$path,),PERL_MB_OPT=>"--install_base ${path}",PERL_MM_OPT=>"INSTALL_BASE=${path}",PERL5LIB=>_env_list_value({interpolate=>$interpolate,exists=>0,empty=>'' },$class->install_base_perl_path($path),\'PERL5LIB',),PATH=>_env_list_value({interpolate=>$interpolate,exists=>0,empty=>'' },$class->install_base_bin_path($path),\'PATH',),)}sub active_paths {my ($class)=@_;return ()unless defined$ENV{PERL_LOCAL_LIB_ROOT};return grep {$_ ne ''}split /\Q$Config{path_sep}/,$ENV{PERL_LOCAL_LIB_ROOT}}sub build_deactivate_environment_vars_for {my ($class,$path,$interpolate)=@_;my@active_lls=$class->active_paths;if (!grep {$_ eq $path}@active_lls){warn "Tried to deactivate inactive local::lib '$path'\n";return ()}my$perl_path=$class->install_base_perl_path($path);my$arch_path=$class->install_base_arch_path($path);my$bin_path=$class->install_base_bin_path($path);my%env=(PERL_LOCAL_LIB_ROOT=>_env_list_value({exists=>0,},grep {$_ ne $path}@active_lls),PERL5LIB=>_env_list_value({exists=>0,filter=>sub {$_ ne $perl_path && $_ ne $arch_path},},\'PERL5LIB',),PATH=>_env_list_value({exists=>0,filter=>sub {$_ ne $bin_path},},\'PATH',),);if ($active_lls[-1]eq $path){my$new_top=$active_lls[-2];$env{PERL_MB_OPT}=defined($new_top)? "--install_base ${new_top}" : undef;$env{PERL_MM_OPT}=defined($new_top)? "INSTALL_BASE=${new_top}" : undef}return%env}sub build_deact_all_environment_vars_for {my ($class,$path,$interpolate)=@_;my@active_lls=$class->active_paths;my%perl_paths=map {($class->install_base_perl_path($_)=>1,$class->install_base_arch_path($_)=>1)}@active_lls;my%bin_paths=map {($class->install_base_bin_path($_)=>1,)}@active_lls;my%env=(PERL_LOCAL_LIB_ROOT=>undef,PERL_MM_OPT=>undef,PERL_MB_OPT=>undef,PERL5LIB=>_env_list_value({exists=>0,filter=>sub {!scalar grep {exists$perl_paths{$_}}$_[0]},},\'PERL5LIB'),PATH=>_env_list_value({exists=>0,filter=>sub {!scalar grep {exists$bin_paths{$_}}$_[0]},},\'PATH'),);return%env}1; 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 @@ -9088,1855 +415,40 @@ $fatpacked{"local/lib.pm"} = <<'LOCAL_LIB'; 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? )? + package version;use 5.005_04;use strict;use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);$VERSION=0.9902;$CLASS='version';my$FRACTION_PART=qr/\.[0-9]+/;my$STRICT_INTEGER_PART=qr/0|[1-9][0-9]*/;my$LAX_INTEGER_PART=qr/[0-9]+/;my$STRICT_DOTTED_DECIMAL_PART=qr/\.[0-9]{1,3}/;my$LAX_DOTTED_DECIMAL_PART=qr/\.[0-9]+/;my$LAX_ALPHA_PART=qr/_[0-9]+/;my$STRICT_DECIMAL_VERSION=qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x;my$STRICT_DOTTED_DECIMAL_VERSION=qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x;$STRICT=qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x;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/ + /x;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; + /x;$LAX=qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x;{local$SIG{'__DIE__'};eval "use version::vxs $VERSION";if ($@){eval "use version::vpp $VERSION";die "$@" if ($@);push@ISA,"version::vpp";local $^W;*version::qv=\&version::vpp::qv;*version::declare=\&version::vpp::declare;*version::_VERSION=\&version::vpp::_VERSION;*version::vcmp=\&version::vpp::vcmp;*version::new=\&version::vpp::new;if ($] >= 5.009000){no strict 'refs';*version::stringify=\&version::vpp::stringify;*{'version::(""'}=\&version::vpp::stringify;*{'version::(<=>'}=\&version::vpp::vcmp;*version::parse=\&version::vpp::parse}}else {push@ISA,"version::vxs";local $^W;*version::declare=\&version::vxs::declare;*version::qv=\&version::vxs::qv;*version::_VERSION=\&version::vxs::_VERSION;*version::vcmp=\&version::vxs::VCMP;*version::new=\&version::vxs::new;if ($] >= 5.009000){no strict 'refs';*version::stringify=\&version::vxs::stringify;*{'version::(""'}=\&version::vxs::stringify;*{'version::(<=>'}=\&version::vxs::VCMP;*version::parse=\&version::vxs::parse}}}sub import {no strict 'refs';my ($class)=shift;unless ($class eq 'version'){local $^W;*{$class.'::declare'}=\&version::declare;*{$class.'::qv'}=\&version::qv}my%args;if (@_){map {$args{$_}=1}@_}else {%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; + package charstar;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)){$right=$left->new($right)}return$left->{current}<=> $right->{current}}sub cmp {my ($left,$right,$swapped)=@_;unless (ref($right)){if (length($right)==1){return$left->thischar cmp $right}$right=$left->new($right)}return$left->currstr cmp $right->currstr}sub bool {my ($self)=@_;my$char=$self->thischar;return ($char ne '')}sub clone {my ($left,$right,$swapped)=@_;$right={string=>[@{$left->{string}}],current=>$left->{current},};return bless$right,ref($left)}sub currstr {my ($self,$s)=@_;my$curr=$self->{current};my$last=$#{$self->{string}};if (defined($s)&& $s->{current}< $last){$last=$s->{current}}my$string=join('',@{$self->{string}}[$curr..$last]);return$string}package version::vpp;use strict;use POSIX qw/locale_h/;use locale;use vars qw ($VERSION @ISA @REGEXS);$VERSION=0.9902;use overload ('""'=>\&stringify,'0+'=>\&numify,'cmp'=>\&vcmp,'<=>'=>\&vcmp,'bool'=>\&vbool,'+'=>\&vnoop,'-'=>\&vnoop,'*'=>\&vnoop,'/'=>\&vnoop,'+='=>\&vnoop,'-='=>\&vnoop,'*='=>\&vnoop,'/='=>\&vnoop,'abs'=>\&vnoop,);eval "use warnings";if ($@){eval ' + package + warnings; sub enabled {return $^W;} 1; - '; - } - - my $VERSION_MAX = 0x7FFFFFFF; - - # implement prescan_version as closely to the C version as possible - use constant TRUE => 1; - use constant FALSE => 0; - - sub isDIGIT { - my ($char) = shift->thischar(); - return ($char =~ /\d/); - } - - sub isALPHA { - my ($char) = shift->thischar(); - return ($char =~ /[a-zA-Z]/); - } - - sub isSPACE { - my ($char) = shift->thischar(); - return ($char =~ /\s/); - } - - sub BADVERSION { - my ($s, $errstr, $error) = @_; - if ($errstr) { - $$errstr = $error; - } - return $s; - } - - sub prescan_version { - my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_; - my $qv = defined $sqv ? $$sqv : FALSE; - my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0; - my $width = defined $swidth ? $$swidth : 3; - my $alpha = defined $salpha ? $$salpha : FALSE; - - my $d = $s; - - if ($qv && isDIGIT($d)) { - goto dotted_decimal_version; - } - - if ($d eq 'v') { # explicit v-string - $d++; - if (isDIGIT($d)) { - $qv = TRUE; - } - else { # degenerate v-string - # requires v1.2.3 - return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); - } - - dotted_decimal_version: - if ($strict && $d eq '0' && isDIGIT($d+1)) { - # no leading zeros allowed - return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); - } - - while (isDIGIT($d)) { # integer part - $d++; - } - - if ($d eq '.') - { - $saw_decimal++; - $d++; # decimal point - } - else - { - if ($strict) { - # require v1.2.3 - return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); - } - else { - goto version_prescan_finish; - } - } - - { - my $i = 0; - my $j = 0; - while (isDIGIT($d)) { # just keep reading - $i++; - while (isDIGIT($d)) { - $d++; $j++; - # maximum 3 digits between decimal - if ($strict && $j > 3) { - return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)"); - } - } - if ($d eq '_') { - if ($strict) { - return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); - } - if ( $alpha ) { - return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); - } - $d++; - $alpha = TRUE; - } - elsif ($d eq '.') { - if ($alpha) { - return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); - } - $saw_decimal++; - $d++; - } - elsif (!isDIGIT($d)) { - last; - } - $j = 0; - } - - if ($strict && $i < 2) { - # requires v1.2.3 - return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); - } - } - } # end if dotted-decimal - else - { # decimal versions - # 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 + '}my$VERSION_MAX=0x7FFFFFFF;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'){$d++;if (isDIGIT($d)){$qv=TRUE}else {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)){return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)")}while (isDIGIT($d)){$d++}if ($d eq '.'){$saw_decimal++;$d++}else {if ($strict){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)){$i++;while (isDIGIT($d)){$d++;$j++;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){return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)")}}}else {my$j=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)")}}if ($d eq '-'){return BADVERSION($s,$errstr,"Invalid version format (negative version number)")}while (isDIGIT($d)){$d++}if ($d eq '.'){$saw_decimal++;$d++}elsif (!$d || $d eq ';' || isSPACE($d)|| $d eq '}'){if ($d==$s){return BADVERSION($s,$errstr,"Invalid version format (version required)")}goto version_prescan_finish}elsif ($d==$s){return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)")}elsif ($d eq '_'){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){return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)")}if ($d &&!isDIGIT($d)&& ($strict ||!($d eq ';' || isSPACE($d)|| $d eq '}'))){return BADVERSION($s,$errstr,"Invalid version format (fractional part required)")}while (isDIGIT($d)){$d++;$j++;if ($d eq '.' && isDIGIT($d-1)){if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)")}if ($strict){return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')")}$d=$s;$qv=TRUE;goto dotted_decimal_version}if ($d eq '_'){if ($strict){return BADVERSION($s,$errstr,"Invalid version format (no underscores)")}if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)")}if (!isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)")}$width=$j;$d++;$alpha=TRUE}}}version_prescan_finish: while (isSPACE($d)){$d++}if ($d &&!isDIGIT($d)&& (!($d eq ';' || $d eq '}'))){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)){$s++}$last=prescan_version($s,FALSE,\$errstr,\$qv,\$saw_decimal,\$width,\$alpha);if ($errstr){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;{my$end=$pos;my$mult=1;my$orev;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}}}}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){my$len=$#av;$len=2 - $len;while ($len-- > 0){push@av,0}}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'){$$rv->{original}='v' .$$rv->{original}}}else {$$rv->{original}='0';push(@av,0)}$$rv->{version}=\@av;if ($s eq 'undef'){$s += 5}return$s}sub new {my ($class,$value)=@_;unless (defined$class){require Carp;Carp::croak('Usage: version::new(class, version)')}my$self=bless ({},ref ($class)|| $class);my$qv=FALSE;if (ref($value)&& eval('$value->isa("version")')){$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 (localeconv()->{decimal_point}eq ','){$value =~ tr/,/./}if (not defined$value or $value =~ /^undef$/){push @{$self->{version}},0;$self->{original}="0";return ($self)}if ($#_==2){$value=$_[2];$qv=TRUE}$value=_un_vstring($value);if ($value =~ /\d+.?\d*e[-+]?\d+/){$value=sprintf("%.9f",$value);$value =~ s/(0+)$//}my$s=scan_version($value,\$self,$qv);if ($s){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 {$string .= sprintf("000")}return$string}sub normal {my ($self)=@_;unless (_verify($self)){require Carp;Carp::croak("Invalid version object")}my$alpha=$self->{alpha}|| "";my$len=$#{$self->{version}};my$digit=$self->{version}[0];my$string=sprintf("v%d",$digit);for (my$i=1 ;$i < $len ;$i++ ){$digit=$self->{version}[$i];$string .= sprintf(".%d",$digit)}if ($len > 0){$digit=$self->{version}[$len];if ($alpha){$string .= sprintf("_%0d",$digit)}else {$string .= sprintf(".%0d",$digit)}}if ($len <= 2){for ($len=2 - $len;$len!=0;$len-- ){$string .= sprintf(".%0d",0)}}return$string}sub stringify {my ($self)=@_;unless (_verify($self)){require Carp;Carp::croak("Invalid version object")}return exists$self->{original}? $self->{original}: exists$self->{qv}? $self->normal : $self->numify}sub vcmp {require UNIVERSAL;my ($left,$right,$swap)=@_;my$class=ref($left);unless (UNIVERSAL::isa($right,$class)){$right=$class->new($right)}if ($swap){($left,$right)=($right,$left)}unless (_verify($left)){require Carp;Carp::croak("Invalid version object")}unless (_verify($right)){require Carp;Carp::croak("Invalid version format")}my$l=$#{$left->{version}};my$r=$#{$right->{version}};my$m=$l < $r ? $l : $r;my$lalpha=$left->is_alpha;my$ralpha=$right->is_alpha;my$retval=0;my$i=0;while ($i <= $m && $retval==0){$retval=$left->{version}[$i]<=> $right->{version}[$i];$i++}if ($retval==0 && $l==$r && $left->{version}[$m]==$right->{version}[$m]&& ($lalpha || $ralpha)){if ($lalpha &&!$ralpha){$retval=-1}elsif ($ralpha &&!$lalpha){$retval=+1}}if ($retval==0 && $l!=$r){if ($l < $r){while ($i <= $r && $retval==0){if ($right->{version}[$i]!=0){$retval=-1}$i++}}else {while ($i <= $l && $retval==0){if ($left->{version}[$i]!=0){$retval=+1}$i++}}}return$retval}sub vbool {my ($self)=@_;return vcmp($self,$self->new("0"),1)}sub vnoop {require Carp;Carp::croak("operation not supported with version object")}sub is_alpha {my ($self)=@_;return (exists$self->{alpha})}sub qv {my$value=shift;my$class='version';if (@_){$class=ref($value)|| $value;$value=shift}$value=_un_vstring($value);$value='v'.$value unless$value =~ /(^v|\d+\.\d+\.\d)/;my$obj=version->new($value);return bless$obj,$class}*declare=\&qv;sub is_qv {my ($self)=@_;return (exists$self->{qv})}sub _verify {my ($self)=@_;if (ref($self)&& eval {exists$self->{version}}&& ref($self->{version})eq 'ARRAY'){return 1}else {return 0}}sub _is_non_alphanumeric {my$s=shift;$s=new charstar$s;while ($s){return 0 if isSPACE($s);return 1 unless (isALPHA($s)|| isDIGIT($s)|| $s =~ /[.-]/);$s++}return 0}sub _un_vstring {my$value=shift;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,}$/){$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){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; VERSION_VPP s/^ //mg for values %fatpacked; unshift @INC, sub { if (my $fat = $fatpacked{$_[1]}) { + if ($] < 5.008) { + return sub { + return 0 unless length $fat; + $fat =~ s/^([^\n]*\n?)//; + $_ = $1; + return 1; + }; + } open my $fh, '<', \$fat or die "FatPacker error loading $_[1] (could be a perl installation issue?)"; return $fh; @@ -10946,13 +458,16 @@ unshift @INC, sub { } # 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); + exit $app->doit; } __END__ @@ -10963,21 +478,53 @@ 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 + cpanm Test::More # install Test::More + cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution path + cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz # install from URL + cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz # install from a local file + cpanm --interactive Task::Kensho # Configure interactively + cpanm . # install from local directory + cpanm --installdeps . # install all the deps for the current directory + cpanm -L extlib Plack # install Plack and all non-core deps into extlib + cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror =head1 COMMANDS =over 4 +=item (arguments) + +Command line arguments can be either a module name, distribution file, +local file path, HTTP URL or git repository URL. Following commands +will all work as you expect. + + cpanm Plack + cpanm Plack/Request.pm + cpanm MIYAGAWA/Plack-1.0000.tar.gz + cpanm /path/to/Plack-1.0000.tar.gz + cpanm http://cpan.metacpan.org/authors/id/M/MI/MIYAGAWA/Plack-0.9990.tar.gz + cpanm git://github.com/plack/Plack.git + +Additionally, you can use the notation using C<~> and C<@> to specify +version for a given module. C<~> specifies the version requirement in +the L<CPAN::Meta::Spec> format, while C<@> pins the exact version, and +is a shortcut for C<~"== VERSION">. + + cpanm Plack~1.0000 # 1.0000 or later + cpanm Plack~">= 1.0000, < 2.0000" # latest of 1.xxxx + cpanm Plack@0.9990 # specific version. same as Plack~"== 0.9990" + +The version query including specific version or range will be sent to +L<MetaCPAN> to search for previous releases. The query will search for +BackPAN archives by default, unless you specify C<--dev> option, in +which case, archived versions will be filtered out. + +For a git repository, you can specify a branch, tag, or commit SHA to +build. The default is C<master> + + cpanm git://github.com/plack/Plack.git@1.0000 # tag + cpanm git://github.com/plack/Plack.git@devel # branch + =item -i, --install Installs the modules. This is a default behavior and this is just a @@ -11008,6 +555,23 @@ Download and unpack the distribution and then open the directory with your shell. Handy to poke around the source code or do manual testing. +=item -U, --uninstall + +B<EXPERIMENTAL>: Uninstalls the modules. Will remove the distribution +files from your library path using the C<.packlist> file. + +When used with C<-l> or C<-L>, only the files under the local::lib +directory will be removed. + +B<NOTE>: If you have the "dual-life" module in multiple locations +(i.e. C<site_perl> and C<perl> library path, with perl 5.12 or later), +only the files in C<site_perl> will be deleted. + +If the distribution has bin scripts and man, they will be kept in case +the core installation still references that, although there's no +guarantee that the script will continue working as expected with the +older version of .pm files. + =item -h, --help Displays the help message. @@ -11037,6 +601,16 @@ architecture you've already tested to make sure it builds fine. Defaults to false, and you can say C<--no-notest> to override when it is set in the default options in C<PERL_CPANM_OPT>. +=item --test-only + +Run the tests only, and do not install the specified module or +distributions. Handy if you want to verify the new (or even old) +releases pass its unit tests without installing the module. + +Note that if you specify this option with a module or distribution +that has dependencies, these dependencies will be installed if you +don't currently have them. + =item -S, --sudo Switch to the root user with C<sudo> when installing modules. Use this @@ -11052,8 +626,8 @@ configuration. (See --interactive) =item -q, --quiet -Makes the output even more quiet than the default. It doesn't print -anything to the STDERR. +Makes the output even more quiet than the default. It only shows the +successful/failed dependencies to the output. =item -l, --local-lib @@ -11064,10 +638,9 @@ 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. +Same with C<--local-lib> but with L<--self-contained> set. All +non-core dependencies will be installed even if they're already +installed. For instance, @@ -11078,19 +651,34 @@ directory C<extlib>, which can be loaded from your application with: use local::lib '/path/to/extlib'; +=item --self-contained + +When examining the dependencies, assume no non-core modules are +installed on the system. Handy if you want to bundle application +dependencies in one directory so you can distribute to other machines. + =item --mirror Specifies the base URL for the CPAN mirror to use, such as C<http://cpan.cpantesters.org/> (you can omit the trailing slash). You can specify multiple mirror URLs by repeating the command line option. -Defaults to C<http://search.cpan.org/CPAN> which is a geo location -aware redirector. +You can use a local directory that has a CPAN mirror structure +(created by tools such as L<OrePAN> or L<Pinto>) by using a special +URL scheme C<file://>. If the given URL begins with `/` (without any +scheme), it is considered as a file scheme as well. + + cpanm --mirror file:///path/to/mirror + cpanm --mirror ~/minicpan # Because shell expands ~ to /home/user + +Defaults to C<http://www.cpan.org/>. =item --mirror-only Download the mirror's 02packages.details.txt.gz index file instead of -querying the CPAN Meta DB. +querying the CPAN Meta DB. This will also effectively opt out sending +your local perl versions to backend database servers such as CPAN Meta +DB and MetaCPAN. Select this option if you are using a local mirror of CPAN, such as minicpan when you're offline, or your own CPAN index (a.k.a darkpan). @@ -11106,11 +694,15 @@ shell aliases, like: B<EXPERIMENTAL>: Specifies the file path to C<02packages.details.txt> for module search index. -=item --metacpan +=item --cpanmetadb + +B<EXPERIMENTAL>: Specifies an alternate URI for CPAN MetaDB index lookups. + +=item --cpanfile + +B<EXPERIMENTAL>: Specified an alternate path for cpanfile to search for, +when C<--installdeps> command is in use. Defaults to C<cpanfile>. -B<EXPERIMENTAL>: Use L<http://api.metacpan.org/> API for module lookup instead of -L<http://cpanmetadb.plackperl.org/>. - =item --prompt Prompts when a test fails so that you can skip, force install, retry @@ -11120,6 +712,10 @@ one of the dependency failed if you want to proceed the installation. Defaults to false, and you can say C<--no-prompt> to override if it's set in the default options in C<PERL_CPANM_OPT>. +=item --dev + +B<EXPERIMENTAL>: search for a newer developer release as well. Defaults to false. + =item --reinstall cpanm, when given a module name in the command line (i.e. C<cpanm @@ -11143,10 +739,67 @@ requires custom configuration or Task:: distributions. Defaults to false, and you can say C<--no-interactive> to override when it's set in the default options in C<PERL_CPANM_OPT>. +=item --pp, --pureperl + +Prefer Pure perl build of modules by setting C<PUREPERL_ONLY=1> for +MakeMaker and C<--pureperl-only> for Build.PL based +distributions. Note that not all of the CPAN modules support this +convention yet. + +=item --with-recommends, --with-suggests + +B<EXPERIMENTAL>: Installs dependencies declared as C<recommends> and +C<suggests> respectively, per META spec. When these dependencies fail +to install, cpanm continues the installation, since they're just +recommendation/suggestion. + +Enabling this could potentially make a circular dependency for a few +modules on CPAN, when C<recommends> adds a module that C<recommends> +back the module in return. + +There's also C<--without-recommend> and C<--without-suggests> to +override the default decision made earlier in C<PERL_CPANM_OPT>. + +Defaults to false for both. + +=item --with-develop + +B<EXPERIMENTAL>: Installs develop phase dependencies in META files or +C<cpanfile> when used with C<--installdeps>. Defaults to false. + +=item --with-feature, --without-feature, --with-all-features + +B<EXPERIMENTAL>: Specifies the feature to enable, if a module supports +optional features per META spec 2.0. + + cpanm --with-feature=opt_csv Spreadsheet::Read + +the features can also be interactively chosen when C<--interactive> +option is enabled. + +C<--with-all-features> enables all the optional features, and +C<--without-feature> can select a feature to disable. + +=item --configure-timeout, --build-timeout, --test-timeout + +Specify the timeout length (in seconds) to wait for the configure, +build and test process. Current default values are: 60 for configure, +3600 for build and 1800 for test. + +=item --configure-args, --build-args, --test-args, --install-args + +B<EXPERIMENTAL>: Pass arguments for configure/build/test/install +commands respectively, for a given module to install. + + cpanm DBD::mysql --configure-args="--cflags=... --libs=..." + +The argument is only enabled for the module passed as a command line +argument, not dependencies. + =item --scandeps -Scans the depencencies of given modules and output the tree in a text -format. (See C<--format> below for more options) +B<DEPRECATED>: Scans the depencencies of given modules and output the +tree in a text format. (See C<--format> below for more options) Because this command doesn't actually install any distributions, it will be useful that by typing: @@ -11162,8 +815,9 @@ combine it with C<-L> option. =item --format -Determines what format to display the scanned dependency -tree. Available options are C<tree>, C<json>, C<yaml> and C<dists>. +B<DEPRECATED>: Determines what format to display the scanned +dependency tree. Available options are C<tree>, C<json>, C<yaml> and +C<dists>. =over 8 @@ -11207,6 +861,10 @@ Specifies the optional directory path to copy downloaded tarballs in the CPAN mirror compatible directory structure i.e. I<authors/id/A/AU/AUTHORS/Foo-Bar-version.tar.gz> +If the distro tarball did not come from CPAN, for example from a local +file or from GitHub, then it will be saved under +I<vendor/Foo-Bar-version.tar.gz>. + =item --uninst-shadows Uninstalls the shadow files of the distribution that you're @@ -11229,19 +887,36 @@ I<before> the perl core library path, and uninstalling shadows is not necessary anymore and does more harm by deleting files from the core library path. +=item --uninstall, -U + +Uninstalls a module from the library path. It finds a packlist for +given modules, and removes all the files included in the same +distribution. + +If you enable local::lib, it only removes files from the local::lib +directory. + +If you try to uninstall a module in C<perl> directory (i.e. core +module), an error will be thrown. + +A dialog wil be prompted to confirm the files to be deleted. If you pass +C<-f> option as well, the dialog will be skipped and uninstallation +will be forced. + =item --cascade-search B<EXPERIMENTAL>: Specifies whether to cascade search when you specify -multiple mirrors and a mirror has a lower version of the module than -requested. Defaults to false. +multiple mirrors and a mirror doesn't have a module or has a lower +version of the module than requested. Defaults to false. =item --skip-installed Specifies whether a module given in the command line is skipped if its latest version is already installed. Defaults to true. -B<NOTE>: The C<PERL5LIB> environment variable have to be correctly set for this -to work with modules installed using L<local::lib>. +B<NOTE>: The C<PERL5LIB> environment variable have to be correctly set +for this to work with modules installed using L<local::lib>, unless +you always use the C<-l> option. =item --skip-satisfied @@ -11258,8 +933,18 @@ C<--skip-installed> but while C<--skip-installed> checks if the I<latest> version of CPAN is installed, C<--skip-satisfied> checks if a requested version (or not, which means any version) is installed. -Defaults to false for bare module names, but if you specify versions -with C<~>, it will always skip satisfied requirements. +Defaults to false. + +=item --verify + +Verify the integrity of distribution files retrieved from PAUSE using +CHECKSUMS and SIGNATURES (if found). Defaults to false. + +=item --report-perl-version + +Whether it report the locally installed perl version to the various +web server as part of User-Agent. Defaults to true, and you can disable +it by using C<--no-report-perl-version>. =item --auto-cleanup @@ -11274,9 +959,9 @@ directories. 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>. +Defaults to true (man pages generated) unless C<-L|--local-lib-contained> +option is supplied in which case it's set to false. You can disable +it with C<--no-man-pages>. =item --lwp |