@@ -11,6 +11,7 @@
# 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
@@ -19,7 +20,7 @@ BEGIN {
my %fatpacked;
$fatpacked{"App/cpanminus.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS';
- package App::cpanminus;our$VERSION="1.7004";1;
+ package App::cpanminus;our$VERSION="1.7014";1;
APP_CPANMINUS
$fatpacked{"App/cpanminus/CPANVersion.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS_CPANVERSION';
@@ -30,38 +31,8 @@ $fatpacked{"App/cpanminus/Dependency.pm"} = '#line '.(1+__LINE__).' "'.__FILE__.
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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS_SCRIPT';
- package App::cpanminus::script;use strict;use Config;use Cwd ();use App::cpanminus;use File::Basename ();use File::Find ();use File::Path ();use File::Spec ();use File::Copy ();use File::Temp ();use Getopt::Long ();use Parse::CPAN::Meta;use Symbol ();use String::ShellQuote ();use version ();use aliased 'App::cpanminus::Dependency';use constant WIN32=>$^O eq 'MSWin32';use constant SUNOS=>$^O eq 'solaris';use constant CAN_SYMLINK=>eval {symlink("","");1};our$VERSION=$App::cpanminus::VERSION;if ($INC{"App/FatPacker/Trace.pm"}){require JSON::PP;require CPAN::Meta::YAML;require CPAN::Meta::Prereqs;require version::vpp;require File::pushd}my$quote=WIN32 ? q/"/ : q/'/;sub agent {my$self=shift;my$agent="cpanminus/$VERSION";$agent .= " perl/$]" if$self->{report_perl_version};$agent}sub determine_home {my$class=shift;my$homedir=$ENV{HOME}|| eval {require File::HomeDir;File::HomeDir->my_home}|| join('',@ENV{qw(HOMEDRIVE HOMEPATH)});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)[0]}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;
+ package App::cpanminus::script;use strict;use Config;use Cwd ();use App::cpanminus;use App::cpanminus::Dependency;use File::Basename ();use File::Find ();use File::Path ();use File::Spec ();use File::Copy ();use File::Temp ();use Getopt::Long ();use Symbol ();use String::ShellQuote ();use version ();use constant WIN32=>$^O eq 'MSWin32';use constant BAD_TAR=>($^O eq 'solaris' || $^O eq 'hpux');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;require Parse::PMFile}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'=>sub {$self->diag("--perl is deprecated since it's known to be fragile in figuring out dependencies. Run `$_[1] -S cpanm` instead.\n",1);$self->{perl}=$_[1]},'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},'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 doit {my$self=shift;my$code;eval {$code=($self->_doit==0)};if (my$e=$@){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}return$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_metacpan($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_metacpan($r)}elsif ($r =~ s/\!=\s*//){push@exclusion,$self->numify_ver_metacpan($r)}}my@filters=({range=>{'module.version_numified'=>\%range }},);if (@exclusion){push@filters,{not=>{or=>[map {+{term=>{'module.version_numified'=>$self->numify_ver_metacpan($_)}}}@exclusion ]},}}return@filters}}sub numify_ver_metacpan {my($self,$ver)=@_;$ver =~ s/_//g;version->new($ver)->numify}sub numify_ver {my($self,$ver)=@_;eval 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','author','module','status' ],});my($release,$author,$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};$author=$match->{author};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=>{and=>[{term=>{'release.name'=>$release }},{term=>{'release.author'=>$author }},]},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){$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)=@_;require CPAN::Meta::YAML;$self->chat("Searching $module on cpanmetadb ...\n");(my$uri=$self->{cpanmetadb})=~ s{/?$}{/package/$module};my$yaml=$self->get($uri);my$meta=eval {CPAN::Meta::YAML::Load($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;return}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)[0]}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}},App::cpanminus::Dependency->new('ExtUtils::MakeMaker'=>6.58),App::cpanminus::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->mask_output(diag_fail=>"Download $uri failed. Retrying ... ")}if ($cancelled){$self->diag_fail("Download cancelled.");return}unless ($file){$self->mask_output(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");return 1}(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 search_inc {my$self=shift;$self->{search_inc}||= do {if (defined$::Bin){[grep!/^\Q$::Bin\E\/..\/(?:fat)?lib$/,@INC]}else {[@INC]}}}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,App::cpanminus::Dependency->from_prereqs($dist->{cpanmeta}->effective_prereqs,['configure'],$self->{install_types},)}if (-e 'Build.PL' &&!$self->should_use_mm($dist->{dist})&&!@config_deps){push@config_deps,App::cpanminus::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,App::cpanminus::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 0 if$file =~ m!^(?:x?t|inc|local|perl5|fatlib|_build)/!;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 Parse::PMFile;my@files=grep {/\.pm(?:\.PL)?$/ && $try->($_)}$self->list_files;my$provides={};for my$file (@files){my$parser=Parse::PMFile->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 App::cpanminus::Dependency->from_prereqs($prereqs,$dist->{want_phases},$self->{install_types})}require CPAN::Meta;my@deps;my($meta_file)=grep -f,qw(MYMETA.json MYMETA.yml);if ($meta_file){$self->chat("Checking dependencies from $meta_file ...\n");my$mymeta=eval {CPAN::Meta->load_file($meta_file,{lazy_validation=>1 })};if ($mymeta){$dist->{meta}{name}=$mymeta->name;$dist->{meta}{version}=$mymeta->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>)};my$meta=CPAN::Meta->new({name=>$dist->{meta}{name},version=>$dist->{meta}{version},%$prereqs },{lazy_validation=>1 },);@deps=$self->extract_prereqs($meta,$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,App::cpanminus::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,App::cpanminus::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,$meta,$dist)=@_;my@features=$self->configure_features($dist,$meta->features);return App::cpanminus::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 a while...\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)=@_;if (File::Spec->file_name_is_absolute($name)){if (-x $name &&!-d _){return$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))&&!-d _){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 || BAD_TAR || (($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:********@}gx for@strings;return@strings}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.
@@ -175,75 +146,83 @@ $fatpacked{"CPAN/DistnameInfo.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
CPAN_DISTNAMEINFO
$fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META';
- 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;
+ use 5.006;use strict;use warnings;package CPAN::Meta;$CPAN::Meta::VERSION='2.142690';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.4414 ();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 load_string {my ($class,$string,$options)=@_;$options->{lazy_validation}=1 unless exists$options->{lazy_validation};my$self;eval {my$struct=Parse::CPAN::Meta->load_string($string);$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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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;
+ package CPAN::Meta::Check;$CPAN::Meta::Check::VERSION='0.009';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)=@_;$module eq 'perl' and return ($reqs->accepts_module($module,$])? (): sprintf "Your Perl (%s) is not in the range '%s'",$],$reqs->requirements_for_module($module));my$metadata=Module::Metadata->new_from_module($module,inc=>$dirs);return "Module '$module' is not installed" if not defined$metadata;my$version=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;return$prereqs->merged_requirements(ref($phases)? $phases : [$phases ],[$type ])}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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_CONVERTER';
- 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_
+ use 5.006;use strict;use warnings;package CPAN::Meta::Converter;$CPAN::Meta::Converter::VERSION='2.142690';use CPAN::Meta::Validator;use CPAN::Meta::Requirements;use Parse::CPAN::Meta 1.4400 ();BEGIN {eval "use version ()";if (my$err=$@){eval "use ExtUtils::MakeMaker::version" or die$err}}*_is_qv=version->can('is_qv')? sub {$_[0]->is_qv}: sub {exists $_[0]->{qv}};sub _dclone {my$ref=shift;no warnings 'once';no warnings 'redefine';local*UNIVERSAL::TO_JSON=sub {"$_[0]"};my$json=Parse::CPAN::Meta->json_backend()->new ->utf8 ->allow_blessed ->convert_blessed;$json->decode($json->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;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;
+ /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)=@_;return {version=>$version,url=>$known_specs{$version},}}my@open_source=('perl','gpl','apache','artistic','artistic_2','lgpl','bsd','gpl','mit','mozilla','open_source',);my%is_open_source=map {;$_=>1}@open_source;my@valid_licenses_1=(@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}}else {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){if (grep {!$is_open_source{$license_downgrade_map{lc $_}|| 'unknown' }}@$element){return 'unknown'}else {return 'open_source'}}elsif (@$element==1){return$license_downgrade_map{lc$element->[0]}|| "unknown"}}elsif (!ref$element){return$license_downgrade_map{lc$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 _is_qv($v)? $v->normal : $element}else {return 0}}sub _bad_version_hook {my ($v)=@_;$v =~ s{[a-z]+$}{};my$vobj=eval {version->new($v)};return defined($vobj)? $vobj : version->new(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=>\&_bad_version_hook });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,$is_fragment)=@_;my$new_data={};for my$key (keys %$spec){next if$key eq ':custom' || $key eq ':drop';next unless my$fcn=$spec->{$key};if ($is_fragment && $key eq 'generated_by'){$fcn=\&_keep}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,},);my%fragments_generate=('2'=>{'abstract'=>'abstract','author'=>'author','generated_by'=>'generated_by','license'=>'license','name'=>'name','version'=>'version','dynamic_config'=>'dynamic_config','release_status'=>'release_status','keywords'=>'keywords','no_index'=>'no_index','optional_features'=>'optional_features','provides'=>'provides','resources'=>'resources','description'=>'description','prereqs'=>'prereqs',},'1.4'=>{'abstract'=>'abstract','author'=>'author','generated_by'=>'generated_by','license'=>'license','name'=>'name','version'=>'version','build_requires'=>'prereqs','conflicts'=>'prereqs','distribution_type'=>'distribution_type','dynamic_config'=>'dynamic_config','keywords'=>'keywords','no_index'=>'no_index','optional_features'=>'optional_features','provides'=>'provides','recommends'=>'prereqs','requires'=>'prereqs','resources'=>'resources','configure_requires'=>'prereqs',},);$fragments_generate{$_}=$fragments_generate{'1.4'}for qw/1.3 1.2 1.1 1.0/;sub new {my ($class,$data,%args)=@_;my$self={'data'=>$data,'spec'=>_extract_spec_version($data,$args{default_version}),};return bless$self,$class}sub _extract_spec_version {my ($data,$default)=@_;my$spec=$data->{'meta-spec'};return($default || "1.0")unless defined$spec && ref$spec eq 'HASH';my$v=$spec->{version};if (defined$v && $v =~ /^\d+(?:\.\d+)?$/){return$v if defined$v && grep {$v eq $_}keys%known_specs;return$v+0 if defined$v && grep {$v==$_}keys%known_specs}return "2" if exists$data->{prereqs};return "1.4" if exists$data->{configure_requires};return($default || "1.2")}sub convert {my ($self,%args)=@_;my$args={%args };my$new_version=$args->{version}|| $HIGHEST;my$is_fragment=$args->{is_fragment};my ($old_version)=$self->{spec};my$converted=_dclone($self->{data});if ($old_version==$new_version){$converted=_convert($converted,$cleanup{$old_version},$old_version,$is_fragment);unless ($args->{is_fragment}){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],$is_fragment);unless ($args->{is_fragment}){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],$is_fragment);unless ($args->{is_fragment}){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}}sub upgrade_fragment {my ($self)=@_;my ($old_version)=$self->{spec};my%expected=map {;$_=>1}grep {defined}map {$fragments_generate{$old_version}{$_}}keys %{$self->{data}};my$converted=$self->convert(version=>$HIGHEST,is_fragment=>1);for my$key (keys %$converted){next if$key =~ /^x_/i || $key eq 'meta-spec';delete$converted->{$key}unless$expected{$key}}return$converted}1;
CPAN_META_CONVERTER
$fatpacked{"CPAN/Meta/Feature.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_FEATURE';
- 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;
+ use 5.006;use strict;use warnings;package CPAN::Meta::Feature;$CPAN::Meta::Feature::VERSION='2.142690';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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_HISTORY';
- use 5.006;use strict;use warnings;package CPAN::Meta::History;our$VERSION='2.132510';1;
+ use 5.006;use strict;use warnings;package CPAN::Meta::History;$CPAN::Meta::History::VERSION='2.142690';1;
CPAN_META_HISTORY
+$fatpacked{"CPAN/Meta/Merge.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_MERGE';
+ use strict;use warnings;package CPAN::Meta::Merge;$CPAN::Meta::Merge::VERSION='2.142690';use Carp qw/croak/;use Scalar::Util qw/blessed/;use CPAN::Meta::Converter;sub _identical {my ($left,$right,$path)=@_;croak "Can't merge attribute " .join '.',@{$path}unless$left eq $right;return$left}sub _merge {my ($current,$next,$mergers,$path)=@_;for my$key (keys %{$next}){if (not exists$current->{$key}){$current->{$key}=$next->{$key}}elsif (my$merger=$mergers->{$key}){$current->{$key}=$merger->($current->{$key},$next->{$key},[@{$path},$key ])}elsif ($merger=$mergers->{':default'}){$current->{$key}=$merger->($current->{$key},$next->{$key},[@{$path},$key ])}else {croak sprintf "Can't merge unknown attribute '%s'",join '.',@{$path},$key}}return$current}sub _uniq {my%seen=();return grep {not $seen{$_}++}@_}sub _set_addition {my ($left,$right)=@_;return [+_uniq(@{$left},@{$right})]}sub _uniq_map {my ($left,$right,$path)=@_;for my$key (keys %{$right}){if (not exists$left->{$key}){$left->{$key}=$right->{$key}}else {croak 'Duplication of element ' .join '.',@{$path},$key}}return$left}sub _improvize {my ($left,$right,$path)=@_;my ($name)=reverse @{$path};if ($name =~ /^x_/){if (ref($left)eq 'ARRAY'){return _set_addition($left,$right,$path)}elsif (ref($left)eq 'HASH'){return _uniq_map($left,$right,$path)}else {return _identical($left,$right,$path)}}croak sprintf "Can't merge '%s'",join '.',@{$path}}my%default=(abstract=>\&_identical,author=>\&_set_addition,dynamic_config=>sub {my ($left,$right)=@_;return$left || $right},generated_by=>sub {my ($left,$right)=@_;return join ', ',_uniq(split(/, /,$left),split(/, /,$right))},license=>\&_set_addition,'meta-spec'=>{version=>\&_identical,url=>\&_identical },name=>\&_identical,release_status=>\&_identical,version=>\&_identical,description=>\&_identical,keywords=>\&_set_addition,no_index=>{map {($_=>\&_set_addition)}qw/file directory package namespace/ },optional_features=>\&_uniq_map,prereqs=>sub {require CPAN::Meta::Prereqs;my ($left,$right)=map {CPAN::Meta::Prereqs->new($_)}@_[0,1];return$left->with_merged_prereqs($right)->as_string_hash},provides=>\&_uniq_map,resources=>{license=>\&_set_addition,homepage=>\&_identical,bugtracker=>\&_uniq_map,repository=>\&_uniq_map,':default'=>\&_improvize,},':default'=>\&_improvize,);sub new {my ($class,%arguments)=@_;croak 'default version required' if not exists$arguments{default_version};my%mapping=%default;my%extra=%{$arguments{extra_mappings}|| {}};for my$key (keys%extra){if (ref($mapping{$key})eq 'HASH'){$mapping{$key}={%{$mapping{$key}},%{$extra{$key}}}}else {$mapping{$key}=$extra{$key}}}return bless {default_version=>$arguments{default_version},mapping=>_coerce_mapping(\%mapping,[]),},$class}my%coderef_for=(set_addition=>\&_set_addition,uniq_map=>\&_uniq_map,identical=>\&_identical,improvize=>\&_improvize,);sub _coerce_mapping {my ($orig,$map_path)=@_;my%ret;for my$key (keys %{$orig}){my$value=$orig->{$key};if (ref($orig->{$key})eq 'CODE'){$ret{$key}=$value}elsif (ref($value)eq 'HASH'){my$mapping=_coerce_mapping($value,[@{$map_path},$key ]);$ret{$key}=sub {my ($left,$right,$path)=@_;return _merge($left,$right,$mapping,[@{$path},$key ])}}elsif ($coderef_for{$value}){$ret{$key}=$coderef_for{$value}}else {croak "Don't know what to do with " .join '.',@{$map_path},$key}}return \%ret}sub merge {my ($self,@items)=@_;my$current={};for my$next (@items){if (blessed($next)&& $next->isa('CPAN::Meta')){$next=$next->as_struct}elsif (ref($next)eq 'HASH'){my$cmc=CPAN::Meta::Converter->new($next,default_version=>$self->{default_version});$next=$cmc->upgrade_fragment}else {croak "Don't know how to merge '$next'"}$current=_merge($current,$next,$self->{mapping},[])}return$current}1;
+CPAN_META_MERGE
+
$fatpacked{"CPAN/Meta/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_PREREQS';
- 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;
+ use 5.006;use strict;use warnings;package CPAN::Meta::Prereqs;$CPAN::Meta::Prereqs::VERSION='2.142690';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 merged_requirements {my ($self,$phases,$types)=@_;$phases=[qw/runtime build test/]unless defined$phases;$types=[qw/requires recommends/]unless defined$types;confess "merged_requirements phases argument must be an arrayref" unless ref$phases eq 'ARRAY';confess "merged_requirements types argument must be an arrayref" unless ref$types eq 'ARRAY';my$req=CPAN::Meta::Requirements->new;for my$phase (@$phases){unless ($phase =~ /\Ax_/i or grep {$phase eq $_}$self->__legal_phases){confess "requested requirements for unknown phase: $phase"}for my$type (@$types){unless ($type =~ /\Ax_/i or grep {$type eq $_}$self->__legal_types){confess "requested requirements for unknown type: $type"}$req->add_requirements($self->requirements_for($phase,$type))}}$req->finalize if$self->is_finalized;return$req}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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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;
+ use strict;use warnings;package CPAN::Meta::Requirements;our$VERSION='2.128';use Carp ();use Scalar::Util ();BEGIN {eval "use version ()";if (my$err=$@){eval "use ExtUtils::MakeMaker::version" or die$err}}*_is_qv=version->can('is_qv')? sub {$_[0]->is_qv}: sub {exists $_[0]->{qv}};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 _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_object {my ($self,$version)=@_;my$vobj;if ($INC{'version/vpp.pm'}|| $INC{'ExtUtils/MakeMaker/version/vpp.pm'}){my$magic=_find_magic_vstring($version);$version=$magic if length$magic}eval {local$SIG{__WARN__}=sub {die "Invalid version: $_[0]"};$vobj=(!defined$version)? version->new(0): (!Scalar::Util::blessed($version))? version->new($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->new("0$vobj")}if (_is_qv($vobj)){$vobj=version->new($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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_SPEC';
- use 5.006;use strict;use warnings;package CPAN::Meta::Spec;our$VERSION='2.132510';1;
+ use 5.006;use strict;use warnings;package CPAN::Meta::Spec;$CPAN::Meta::Spec::VERSION='2.142690';1;
CPAN_META_SPEC
$fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_VALIDATOR';
- 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;
+ use 5.006;use strict;use warnings;package CPAN::Meta::Validator;$CPAN::Meta::Validator::VERSION='2.142690';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,list=>{value=>\&string }},'dynamic_config'=>{mandatory=>1,value=>\&boolean },'generated_by'=>{mandatory=>1,value=>\&string },'license'=>{mandatory=>1,list=>{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'=>{list=>{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=>{list=>{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'=>eval {$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', 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})}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})}else {$self->_error("$spec_error for ':key'")}}else {$self->_error("Unknown key, '$key', found in map structure")}pop @{$self->{stack}}}}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 ($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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_YAML';
- 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;
+ use 5.008001;use strict;use warnings;package CPAN::Meta::YAML;$CPAN::Meta::YAML::VERSION='0.012';BEGIN {$CPAN::Meta::YAML::AUTHORITY='cpan:ADAMK'};use Exporter;our@ISA=qw{Exporter};our@EXPORT=qw{Load Dump};our@EXPORT_OK=qw{LoadFile DumpFile freeze thaw};sub Dump {return CPAN::Meta::YAML->new(@_)->_dump_string}sub Load {my$self=CPAN::Meta::YAML->_load_string(@_);if (wantarray){return @$self}else {return$self->[-1]}}BEGIN {*freeze=\&Dump;*thaw=\&Load}sub DumpFile {my$file=shift;return CPAN::Meta::YAML->new(@_)->_dump_file($file)}sub LoadFile {my$file=shift;my$self=CPAN::Meta::YAML->_load_file($file);if (wantarray){return @$self}else {return$self->[-1]}}sub new {my$class=shift;bless [@_ ],$class}sub read_string {my$self=shift;$self->_load_string(@_)}sub write_string {my$self=shift;$self->_dump_string(@_)}sub read {my$self=shift;$self->_load_file(@_)}sub write {my$self=shift;$self->_dump_file(@_)}my@UNPRINTABLE=qw(0 x01 x02 x03 x04 x05 x06 a b t n v f r x0E x0F x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x1A e x1C x1D x1E x1F);my%UNESCAPES=(0=>"\x00",z=>"\x00",N=>"\x85",a=>"\x07",b=>"\x08",t=>"\x09",n=>"\x0a",v=>"\x0b",f=>"\x0c",r=>"\x0d",e=>"\x1b",'\\'=>'\\',);my%QUOTE=map {$_=>1}qw{null true false};my$re_capture_double_quoted=qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;my$re_capture_single_quoted=qr/\'([^\']*(?:\'\'[^\']*)*)\'/;my$re_capture_unquoted_key=qr/([^:]+(?::+\S[^:]*)*)(?=\s*\:(?:\s+|$))/;my$re_trailing_comment=qr/(?:\s+\#.*)?/;my$re_key_value_separator=qr/\s*:(?:\s+(?:\#.*)?|$)/;sub _load_file {my$class=ref $_[0]? ref shift : shift;my$file=shift or $class->_error('You did not specify a file name');$class->_error("File '$file' does not exist")unless -e $file;$class->_error("'$file' is a directory, not a file")unless -f _;$class->_error("Insufficient permissions to read '$file'")unless -r _;open(my$fh,"<:unix:encoding(UTF-8)",$file);unless ($fh){$class->_error("Failed to open file '$file': $!")}if (_can_flock()){flock($fh,Fcntl::LOCK_SH())or warn "Couldn't lock '$file' for reading: $!"}my$contents=eval {use warnings FATAL=>'utf8';local $/;<$fh>};if (my$err=$@){$class->_error("Error reading from file '$file': $err")}unless (close$fh){$class->_error("Failed to close file '$file': $!")}$class->_load_string($contents)}sub _load_string {my$class=ref $_[0]? ref shift : shift;my$self=bless [],$class;my$string=$_[0];eval {unless (defined$string){die \"Did not provide a string to load"}if (utf8::is_utf8($string)&&!utf8::valid($string)){die \<<'...'}utf8::upgrade($string);$string =~ s/^\x{FEFF}//;return$self unless length$string;my@lines=grep {!/^\s*(?:\#.*)?\z/}split /(?:\015{1,2}\012|\015|\012)/,$string;@lines and $lines[0]=~ /^\%YAML[: ][\d\.]+.*\z/ and shift@lines;my$in_document=0;while (@lines){if ($lines[0]=~ /^---\s*(?:(.+)\s*)?\z/){shift@lines;if (defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/){push @$self,$self->_load_scalar("$1",[undef ],\@lines);next}$in_document=1}if (!@lines or $lines[0]=~ /^(?:---|\.\.\.)/){push @$self,undef;while (@lines and $lines[0]!~ /^---/){shift@lines}$in_document=0}elsif (!$in_document && @$self){die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'"}elsif ($lines[0]=~ /^\s*\-(?:\s|$|-+$)/){my$document=[];push @$self,$document;$self->_load_array($document,[0 ],\@lines)}elsif ($lines[0]=~ /^(\s*)\S/){my$document={};push @$self,$document;$self->_load_hash($document,[length($1)],\@lines)}else {die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'"}}};if (ref $@ eq 'SCALAR'){$self->_error(${$@})}elsif ($@){$self->_error($@)}return$self}sub _unquote_single {my ($self,$string)=@_;return '' unless length$string;$string =~ s/\'\'/\'/g;return$string}sub _unquote_double {my ($self,$string)=@_;return '' unless length$string;$string =~ s/\\"/"/g;$string =~ s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))}
+ Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set).
+ Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"?
+ ...
+ {(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex;return$string}sub _load_scalar {my ($self,$string,$indent,$lines)=@_;$string =~ s/\s*\z//;return undef if$string eq '~';if ($string =~ /^$re_capture_single_quoted$re_trailing_comment\z/){return$self->_unquote_single($1)}if ($string =~ /^$re_capture_double_quoted$re_trailing_comment\z/){return$self->_unquote_double($1)}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 !~ /^[>|]/){die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'" if$string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or $string =~ /:(?:\s|$)/;$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 _load_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->_load_hash($array->[-1],[@$indent,$indent2 ],$lines)}elsif ($lines->[0]=~ /^\s*\-\s*\z/){shift @$lines;unless (@$lines){push @$array,undef;return 1}if ($lines->[0]=~ /^(\s*)\-/){my$indent2=length("$1");if ($indent->[-1]==$indent2){push @$array,undef}else {push @$array,[];$self->_load_array($array->[-1],[@$indent,$indent2 ],$lines)}}elsif ($lines->[0]=~ /^(\s*)\S/){push @$array,{};$self->_load_hash($array->[-1],[@$indent,length("$1")],$lines)}else {die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"}}elsif ($lines->[0]=~ /^\s*\-(\s*)(.+?)\s*\z/){shift @$lines;push @$array,$self->_load_scalar("$2",[@$indent,undef ],$lines)}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 _load_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]'"}my$key;if ($lines->[0]=~ s/^\s*$re_capture_single_quoted$re_key_value_separator//){$key=$self->_unquote_single($1)}elsif ($lines->[0]=~ s/^\s*$re_capture_double_quoted$re_key_value_separator//){$key=$self->_unquote_double($1)}elsif ($lines->[0]=~ s/^\s*$re_capture_unquoted_key$re_key_value_separator//){$key=$1;$key =~ s/\s+$//}elsif ($lines->[0]=~ /^\s*\?/){die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'"}else {die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"}if (length$lines->[0]){$hash->{$key}=$self->_load_scalar(shift(@$lines),[@$indent,undef ],$lines)}else {shift @$lines;unless (@$lines){$hash->{$key}=undef;return 1}if ($lines->[0]=~ /^(\s*)-/){$hash->{$key}=[];$self->_load_array($hash->{$key},[@$indent,length($1)],$lines)}elsif ($lines->[0]=~ /^(\s*)./){my$indent2=length("$1");if ($indent->[-1]>= $indent2){$hash->{$key}=undef}else {$hash->{$key}={};$self->_load_hash($hash->{$key},[@$indent,length($1)],$lines)}}}}return 1}sub _dump_file {my$self=shift;require Fcntl;my$file=shift or $self->_error('You did not specify a file name');my$fh;if (_can_flock()){my$flags=Fcntl::O_WRONLY()|Fcntl::O_CREAT();sysopen($fh,$file,$flags);unless ($fh){$self->_error("Failed to open file '$file' for writing: $!")}binmode($fh,":raw:encoding(UTF-8)");flock($fh,Fcntl::LOCK_EX())or warn "Couldn't lock '$file' for reading: $!";truncate$fh,0;seek$fh,0,0}else {open$fh,">:unix:encoding(UTF-8)",$file}print {$fh}$self->_dump_string;unless (close$fh){$self->_error("Failed to close file '$file': $!")}return 1}sub _dump_string {my$self=shift;return '' unless ref$self && @$self;my$indent=0;my@lines=();eval {for my$cursor (@$self){push@lines,'---';if (!defined$cursor){}elsif (!ref$cursor){$lines[-1].= ' ' .$self->_dump_scalar($cursor)}elsif (ref$cursor eq 'ARRAY'){unless (@$cursor){$lines[-1].= ' []';next}push@lines,$self->_dump_array($cursor,$indent,{})}elsif (ref$cursor eq 'HASH'){unless (%$cursor){$lines[-1].= ' {}';next}push@lines,$self->_dump_hash($cursor,$indent,{})}else {die \("Cannot serialize " .ref($cursor))}}};if (ref $@ eq 'SCALAR'){$self->_error(${$@})}elsif ($@){$self->_error($@)}join '',map {"$_\n"}@lines}sub _has_internal_string_value {my$value=shift;my$b_obj=B::svref_2object(\$value);return$b_obj->FLAGS & B::SVf_POK()}sub _dump_scalar {my$string=$_[1];my$is_key=$_[2];my$has_string_flag=_has_internal_string_value($string);return '~' unless defined$string;return "''" unless length$string;if (Scalar::Util::looks_like_number($string)){if ($is_key || $has_string_flag){return qq['$string']}else {return$string}}if ($string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/){$string =~ s/\\/\\\\/g;$string =~ s/"/\\"/g;$string =~ s/\n/\\n/g;$string =~ s/[\x85]/\\N/g;$string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;$string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge;return qq|"$string"|}if ($string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or $QUOTE{$string}){return "'$string'"}return$string}sub _dump_array {my ($self,$array,$indent,$seen)=@_;if ($seen->{refaddr($array)}++){die \"CPAN::Meta::YAML does not support circular references"}my@lines=();for my$el (@$array){my$line=(' ' x $indent).'-';my$type=ref$el;if (!$type){$line .= ' ' .$self->_dump_scalar($el);push@lines,$line}elsif ($type eq 'ARRAY'){if (@$el){push@lines,$line;push@lines,$self->_dump_array($el,$indent + 1,$seen)}else {$line .= ' []';push@lines,$line}}elsif ($type eq 'HASH'){if (keys %$el){push@lines,$line;push@lines,$self->_dump_hash($el,$indent + 1,$seen)}else {$line .= ' {}';push@lines,$line}}else {die \"CPAN::Meta::YAML does not support $type references"}}@lines}sub _dump_hash {my ($self,$hash,$indent,$seen)=@_;if ($seen->{refaddr($hash)}++){die \"CPAN::Meta::YAML does not support circular references"}my@lines=();for my$name (sort keys %$hash){my$el=$hash->{$name};my$line=(' ' x $indent).$self->_dump_scalar($name,1).":";my$type=ref$el;if (!$type){$line .= ' ' .$self->_dump_scalar($el);push@lines,$line}elsif ($type eq 'ARRAY'){if (@$el){push@lines,$line;push@lines,$self->_dump_array($el,$indent + 1,$seen)}else {$line .= ' []';push@lines,$line}}elsif ($type eq 'HASH'){if (keys %$el){push@lines,$line;push@lines,$self->_dump_hash($el,$indent + 1,$seen)}else {$line .= ' {}';push@lines,$line}}else {die \"CPAN::Meta::YAML does not support $type references"}}@lines}our$errstr='';sub _error {require Carp;$errstr=$_[1];$errstr =~ s/ at \S+ line \d+.*//;Carp::croak($errstr)}my$errstr_warned;sub errstr {require Carp;Carp::carp("CPAN::Meta::YAML->errstr and \$CPAN::Meta::YAML::errstr is deprecated")unless$errstr_warned++;$errstr}use B;my$HAS_FLOCK;sub _can_flock {if (defined$HAS_FLOCK){return$HAS_FLOCK}else {require Config;my$c=\%Config::Config;$HAS_FLOCK=grep {$c->{$_}}qw/d_flock d_fcntl_can_lock d_lockf/;require Fcntl if$HAS_FLOCK;return$HAS_FLOCK}}BEGIN {local $@;if (eval {require Scalar::Util}&& $Scalar::Util::VERSION && eval($Scalar::Util::VERSION)>= 1.18){*refaddr=*Scalar::Util::refaddr}else {eval <<'END_PERL'}}1;
# Scalar::Util failed to load or too old
sub refaddr {
- my $pkg = ref($_[0]) or return undef;
- if ( !! UNIVERSAL::can($_[0], 'can') ) {
- bless $_[0], 'Scalar::Util::Fake';
- } else {
- $pkg = undef;
- }
- "$_[0]" =~ /0x(\w+)/;
- my $i = do { local $^W; hex $1 };
- bless $_[0], $pkg if defined $pkg;
- $i;
+ my $pkg = ref($_[0]) or return undef;
+ if ( !! UNIVERSAL::can($_[0], 'can') ) {
+ bless $_[0], 'Scalar::Util::Fake';
+ } else {
+ $pkg = undef;
+ }
+ "$_[0]" =~ /0x(\w+)/;
+ my $i = do { no warnings 'portable'; hex $1 };
+ bless $_[0], $pkg if defined $pkg;
+ $i;
}
END_PERL
CPAN_META_YAML
$fatpacked{"Exporter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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;
+ package Exporter;require 5.006;our$Debug=0;our$ExportLevel=0;our$Verbose ||=0;our$VERSION='5.70';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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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;
+ 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 {my$oldwarn=$SIG{__WARN__};local$SIG{__WARN__}=sub {local$SIG{__WARN__}=$oldwarn;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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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;
+ use strict;use warnings;package File::pushd;our$VERSION='1.009';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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINY';
- package HTTP::Tiny;use strict;use warnings;our$VERSION='0.043';use Carp ();my@attributes;BEGIN {@attributes=qw(cookie_jar default_headers http_proxy https_proxy keep_alive local_address max_redirect max_size proxy no_proxy timeout SSL_options verify_SSL);my%persist_ok=map {;$_=>1}qw(cookie_jar default_headers max_redirect max_size);no strict 'refs';no warnings 'uninitialized';for my$accessor (@attributes){*{$accessor}=sub {@_ > 1 ? do {delete $_[0]->{handle}if!$persist_ok{$accessor}&& $_[1]ne $_[0]->{$accessor};$_[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,keep_alive=>1,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);$self->_set_proxies;return$self}sub _set_proxies {my ($self)=@_;if (!$self->{proxy}){$self->{proxy}=$ENV{all_proxy}|| $ENV{ALL_PROXY};if (defined$self->{proxy}){$self->_split_proxy('generic proxy'=>$self->{proxy})}else {delete$self->{proxy}}}if (!$self->{http_proxy}){$self->{http_proxy}=$ENV{http_proxy}|| $self->{proxy};if (defined$self->{http_proxy}){$self->_split_proxy(http_proxy=>$self->{http_proxy});$self->{_has_proxy}{http}=1}else {delete$self->{http_proxy}}}if (!$self->{https_proxy}){$self->{https_proxy}=$ENV{https_proxy}|| $ENV{HTTPS_PROXY}|| $self->{proxy};if ($self->{https_proxy}){$self->_split_proxy(https_proxy=>$self->{https_proxy});$self->{_has_proxy}{https}=1}else {delete$self->{https_proxy}}}unless (ref$self->{no_proxy}eq 'ARRAY'){$self->{no_proxy}=(defined$self->{no_proxy})? [split /\s*,\s*/,$self->{no_proxy}]: []}return}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));require Fcntl;sysopen my$fh,$tempfile,Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY()or Carp::croak(qq/Error: Could not create 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: Caught error closing 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=$@){if (ref$e eq 'HASH' && exists$e->{status}){return$e}$e="$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("&",(ref$data eq 'ARRAY')? (@terms): (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=>$host,host_port=>($port==$DefaultPort{$scheme}? $host : "$host:$port"),uri=>$path_query,headers=>{},};my$handle=delete$self->{handle};if ($handle){unless ($handle->can_reuse($scheme,$host,$port)){$handle->close;undef$handle}}$handle ||=$self->_open_handle($request,$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)}my$known_message_length;if ($method eq 'HEAD' || $response->{status}=~ /^[23]04/){$known_message_length=1}else {my$data_cb=$self->_prepare_data_cb($response,$args);$known_message_length=$handle->read_body($data_cb,$response)}if ($self->{keep_alive}&& $known_message_length && $response->{protocol}eq 'HTTP/1.1' && ($response->{headers}{connection}|| '')ne 'close'){$self->{handle}=$handle}else {$handle->close}$response->{success}=substr($response->{status},0,1)eq '2';$response->{url}=$url;return$response}sub _open_handle {my ($self,$request,$scheme,$host,$port)=@_;my$handle=HTTP::Tiny::Handle->new(timeout=>$self->{timeout},SSL_options=>$self->{SSL_options},verify_SSL=>$self->{verify_SSL},local_address=>$self->{local_address},keep_alive=>$self->{keep_alive});if ($self->{_has_proxy}{$scheme}&&!grep {$host =~ /\Q$_\E$/}@{$self->{no_proxy}}){return$self->_proxy_connect($request,$handle)}else {return$handle->connect($scheme,$host,$port)}}sub _proxy_connect {my ($self,$request,$handle)=@_;my@proxy_vars;if ($request->{scheme}eq 'https'){Carp::croak(qq{No https_proxy defined})unless$self->{https_proxy};@proxy_vars=$self->_split_proxy(https_proxy=>$self->{https_proxy});if ($proxy_vars[0]eq 'https'){Carp::croak(qq{Can't proxy https over https: $request->{uri} via $self->{https_proxy}})}}else {Carp::croak(qq{No http_proxy defined})unless$self->{http_proxy};@proxy_vars=$self->_split_proxy(http_proxy=>$self->{http_proxy})}my ($p_scheme,$p_host,$p_port,$p_auth)=@proxy_vars;if (length$p_auth &&!defined$request->{headers}{'proxy-authorization'}){$self->_add_basic_auth_header($request,'proxy-authorization'=>$p_auth)}$handle->connect($p_scheme,$p_host,$p_port);if ($request->{scheme}eq 'https'){$self->_create_proxy_tunnel($request,$handle)}else {$request->{uri}="$request->{scheme}://$request->{host_port}$request->{uri}"}return$handle}sub _split_proxy {my ($self,$type,$proxy)=@_;my ($scheme,$host,$port,$path_query,$auth)=eval {$self->_split_url($proxy)};unless(defined($scheme)&& length($scheme)&& length($host)&& length($port)&& $path_query eq '/'){Carp::croak(qq{$type URL must be in format http[s]://[auth@]<host>:<port>/\n})}return ($scheme,$host,$port,$auth)}sub _create_proxy_tunnel {my ($self,$request,$handle)=@_;$handle->_assert_ssl;my$agent=exists($request->{headers}{'user-agent'})? $request->{headers}{'user-agent'}: $self->{agent};my$connect_request={method=>'CONNECT',uri=>$request->{host_port},headers=>{host=>$request->{host_port},'user-agent'=>$agent,}};if ($request->{headers}{'proxy-authorization'}){$connect_request->{headers}{'proxy-authorization'}=delete$request->{headers}{'proxy-authorization'}}$handle->write_request($connect_request);my$response;do {$response=$handle->read_response_header}until (substr($response->{status},0,1)ne '1');unless (substr($response->{status},0,1)eq '2'){die$response}$handle->start_ssl($request->{host});return}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}{'user-agent'}||=$self->{agent};$request->{headers}{'connection'}="close" unless$self->{keep_alive};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}{authorization}){$self->_add_basic_auth_header($request,'authorization'=>$auth)}return}sub _add_basic_auth_header {my ($self,$request,$header,$auth)=@_;require MIME::Base64;$request->{headers}{$header}="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/;$auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg}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];my$SOCKET_CLASS=$ENV{PERL_HTTP_TINY_IPV4_ONLY}? 'IO::Socket::INET' : eval {require IO::Socket::IP;IO::Socket::IP->VERSION(0.25)}? 'IO::Socket::IP' : 'IO::Socket::INET';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'){$self->_assert_ssl}elsif ($scheme ne 'http'){die(qq/Unsupported URL scheme '$scheme'\n/)}$self->{fh}=$SOCKET_CLASS->new(PeerHost=>$host,PeerPort=>$port,$self->{local_address}? (LocalAddr=>$self->{local_address}): (),Proto=>'tcp',Type=>SOCK_STREAM,Timeout=>$self->{timeout},KeepAlive=>!!$self->{keep_alive})or die(qq/Could not connect to '$host:$port': $@\n/);binmode($self->{fh})or die(qq/Could not binmode() socket: '$!'\n/);$self->start_ssl($host)if$scheme eq 'https';$self->{scheme}=$scheme;$self->{host}=$host;$self->{port}=$port;return$self}sub start_ssl {my ($self,$host)=@_;if (ref($self->{fh})eq 'IO::Socket::SSL'){unless ($self->{fh}->stop_SSL){my$ssl_err=IO::Socket::SSL->errstr;die(qq/Error halting prior SSL connection: $ssl_err/)}}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/)}}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 || @_==3 && ref $_[1]eq 'HASH')|| die(q/Usage: $handle->write_header_lines(headers[,prefix])/ ."\n");my($self,$headers,$prefix_data)=@_;my$buf=(defined$prefix_data ? $prefix_data : '');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'}|| '';my$chunked=grep {/chunked/i}(ref$te eq 'ARRAY' ? @$te : $te);return$chunked ? $self->read_chunked_body($cb,$response): $self->read_content_body($cb,$response)}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}return length($self->{rbuf})==0}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 1}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_header_lines($headers,"$method $request_uri HTTP/1.1\x0D\x0A")}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;if (ref($self->{fh})eq 'IO::Socket::SSL'){return 1 if$self->{fh}->pending}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 _assert_ssl {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)}}sub can_reuse {my ($self,$scheme,$host,$port)=@_;return 0 if length($self->{rbuf})|| $scheme ne $self->{scheme}|| $host ne $self->{host}|| $port ne $self->{port}|| eval {$self->can_read(0)}|| $@ ;return 1}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;
+ package HTTP::Tiny;use strict;use warnings;our$VERSION='0.050';use Carp ();my@attributes;BEGIN {@attributes=qw(cookie_jar default_headers http_proxy https_proxy keep_alive local_address max_redirect max_size proxy no_proxy timeout SSL_options verify_SSL);my%persist_ok=map {;$_=>1}qw(cookie_jar default_headers max_redirect max_size);no strict 'refs';no warnings 'uninitialized';for my$accessor (@attributes){*{$accessor}=sub {@_ > 1 ? do {delete $_[0]->{handle}if!$persist_ok{$accessor}&& $_[1]ne $_[0]->{$accessor};$_[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,keep_alive=>1,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);$self->_set_proxies;return$self}sub _set_proxies {my ($self)=@_;if (!exists$self->{proxy}){$self->{proxy}=$ENV{all_proxy}|| $ENV{ALL_PROXY}}if (defined$self->{proxy}){$self->_split_proxy('generic proxy'=>$self->{proxy})}else {delete$self->{proxy}}if (!exists$self->{http_proxy}){$self->{http_proxy}=$ENV{http_proxy}|| $self->{proxy}}if (defined$self->{http_proxy}){$self->_split_proxy(http_proxy=>$self->{http_proxy});$self->{_has_proxy}{http}=1}else {delete$self->{http_proxy}}if (!exists$self->{https_proxy}){$self->{https_proxy}=$ENV{https_proxy}|| $ENV{HTTPS_PROXY}|| $self->{proxy}}if ($self->{https_proxy}){$self->_split_proxy(https_proxy=>$self->{https_proxy});$self->{_has_proxy}{https}=1}else {delete$self->{https_proxy}}unless (ref$self->{no_proxy}eq 'ARRAY'){$self->{no_proxy}=(defined$self->{no_proxy})? [split /\s*,\s*/,$self->{no_proxy}]: []}return}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));require Fcntl;sysopen my$fh,$tempfile,Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY()or Carp::croak(qq/Error: Could not create 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: Caught error closing 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=$@){if (ref$e eq 'HASH' && exists$e->{status}){return$e}$e="$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("&",(ref$data eq 'ARRAY')? (@terms): (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=>$host,port=>$port,host_port=>($port==$DefaultPort{$scheme}? $host : "$host:$port"),uri=>$path_query,headers=>{},};my$handle=delete$self->{handle};if ($handle){unless ($handle->can_reuse($scheme,$host,$port)){$handle->close;undef$handle}}$handle ||= $self->_open_handle($request,$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)}my$known_message_length;if ($method eq 'HEAD' || $response->{status}=~ /^[23]04/){$known_message_length=1}else {my$data_cb=$self->_prepare_data_cb($response,$args);$known_message_length=$handle->read_body($data_cb,$response)}if ($self->{keep_alive}&& $known_message_length && $response->{protocol}eq 'HTTP/1.1' && ($response->{headers}{connection}|| '')ne 'close'){$self->{handle}=$handle}else {$handle->close}$response->{success}=substr($response->{status},0,1)eq '2';$response->{url}=$url;return$response}sub _open_handle {my ($self,$request,$scheme,$host,$port)=@_;my$handle=HTTP::Tiny::Handle->new(timeout=>$self->{timeout},SSL_options=>$self->{SSL_options},verify_SSL=>$self->{verify_SSL},local_address=>$self->{local_address},keep_alive=>$self->{keep_alive});if ($self->{_has_proxy}{$scheme}&&!grep {$host =~ /\Q$_\E$/}@{$self->{no_proxy}}){return$self->_proxy_connect($request,$handle)}else {return$handle->connect($scheme,$host,$port)}}sub _proxy_connect {my ($self,$request,$handle)=@_;my@proxy_vars;if ($request->{scheme}eq 'https'){Carp::croak(qq{No https_proxy defined})unless$self->{https_proxy};@proxy_vars=$self->_split_proxy(https_proxy=>$self->{https_proxy});if ($proxy_vars[0]eq 'https'){Carp::croak(qq{Can't proxy https over https: $request->{uri} via $self->{https_proxy}})}}else {Carp::croak(qq{No http_proxy defined})unless$self->{http_proxy};@proxy_vars=$self->_split_proxy(http_proxy=>$self->{http_proxy})}my ($p_scheme,$p_host,$p_port,$p_auth)=@proxy_vars;if (length$p_auth &&!defined$request->{headers}{'proxy-authorization'}){$self->_add_basic_auth_header($request,'proxy-authorization'=>$p_auth)}$handle->connect($p_scheme,$p_host,$p_port);if ($request->{scheme}eq 'https'){$self->_create_proxy_tunnel($request,$handle)}else {$request->{uri}="$request->{scheme}://$request->{host_port}$request->{uri}"}return$handle}sub _split_proxy {my ($self,$type,$proxy)=@_;my ($scheme,$host,$port,$path_query,$auth)=eval {$self->_split_url($proxy)};unless(defined($scheme)&& length($scheme)&& length($host)&& length($port)&& $path_query eq '/'){Carp::croak(qq{$type URL must be in format http[s]://[auth@]<host>:<port>/\n})}return ($scheme,$host,$port,$auth)}sub _create_proxy_tunnel {my ($self,$request,$handle)=@_;$handle->_assert_ssl;my$agent=exists($request->{headers}{'user-agent'})? $request->{headers}{'user-agent'}: $self->{agent};my$connect_request={method=>'CONNECT',uri=>"$request->{host}:$request->{port}",headers=>{host=>"$request->{host}:$request->{port}",'user-agent'=>$agent,}};if ($request->{headers}{'proxy-authorization'}){$connect_request->{headers}{'proxy-authorization'}=delete$request->{headers}{'proxy-authorization'}}$handle->write_request($connect_request);my$response;do {$response=$handle->read_response_header}until (substr($response->{status},0,1)ne '1');unless (substr($response->{status},0,1)eq '2'){die$response}$handle->start_ssl($request->{host});return}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}}if (exists$request->{headers}{'host'}){die(qq/The 'Host' header must not be provided as header option\n/)}$request->{headers}{'host'}=$request->{host_port};$request->{headers}{'user-agent'}||= $self->{agent};$request->{headers}{'connection'}="close" unless$self->{keep_alive};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}{authorization}){$self->_add_basic_auth_header($request,'authorization'=>$auth)}return}sub _add_basic_auth_header {my ($self,$request,$header,$auth)=@_;require MIME::Base64;$request->{headers}{$header}="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,$host,$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='';if ((my$i=index$host,'@')!=-1){$auth=substr$host,0,$i,'';substr$host,0,1,'';$auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg}my$port=$host =~ s/:(\d*)\z// && length $1 ? $1 : $scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef;return ($scheme,(length$host ? lc$host : "localhost"),$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];if (eval {require "threads.pm";1}){*_get_tid=sub {threads->tid}}else {*_get_tid=sub () {0}}my$SOCKET_CLASS=$ENV{PERL_HTTP_TINY_IPV4_ONLY}? 'IO::Socket::INET' : eval {require IO::Socket::IP;IO::Socket::IP->VERSION(0.25)}? 'IO::Socket::IP' : 'IO::Socket::INET';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'){$self->_assert_ssl}elsif ($scheme ne 'http'){die(qq/Unsupported URL scheme '$scheme'\n/)}$self->{fh}=$SOCKET_CLASS->new(PeerHost=>$host,PeerPort=>$port,$self->{local_address}? (LocalAddr=>$self->{local_address}): (),Proto=>'tcp',Type=>SOCK_STREAM,Timeout=>$self->{timeout},KeepAlive=>!!$self->{keep_alive})or die(qq/Could not connect to '$host:$port': $@\n/);binmode($self->{fh})or die(qq/Could not binmode() socket: '$!'\n/);$self->start_ssl($host)if$scheme eq 'https';$self->{scheme}=$scheme;$self->{host}=$host;$self->{port}=$port;$self->{pid}=$$;$self->{tid}=_get_tid();return$self}sub start_ssl {my ($self,$host)=@_;if (ref($self->{fh})eq 'IO::Socket::SSL'){unless ($self->{fh}->stop_SSL){my$ssl_err=IO::Socket::SSL->errstr;die(qq/Error halting prior SSL connection: $ssl_err/)}}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/)}}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 || @_==3 && ref $_[1]eq 'HASH')|| die(q/Usage: $handle->write_header_lines(headers[,prefix])/ ."\n");my($self,$headers,$prefix_data)=@_;my$buf=(defined$prefix_data ? $prefix_data : '');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){$_='' unless defined $_;$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'}|| '';my$chunked=grep {/chunked/i}(ref$te eq 'ARRAY' ? @$te : $te);return$chunked ? $self->read_chunked_body($cb,$response): $self->read_content_body($cb,$response)}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}return length($self->{rbuf})==0}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 1}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_header_lines($headers,"$method $request_uri HTTP/1.1\x0D\x0A")}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;if (ref($self->{fh})eq 'IO::Socket::SSL'){return 1 if$self->{fh}->pending}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 _assert_ssl {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)}}sub can_reuse {my ($self,$scheme,$host,$port)=@_;return 0 if $self->{pid}!=$$ || $self->{tid}!=_get_tid()|| length($self->{rbuf})|| $scheme ne $self->{scheme}|| $host ne $self->{host}|| $port ne $self->{port}|| eval {$self->can_read(0)}|| $@ ;return 1}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')
@@ -254,7 +233,7 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
HTTP_TINY
$fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP';
- package JSON::PP;use 5.005;use strict;use base qw(Exporter);use overload ();use Carp ();use B ();$JSON::PP::VERSION='2.27203';@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/
+ package JSON::PP;use 5.005;use strict;use base qw(Exporter);use overload ();use Carp ();use B ();$JSON::PP::VERSION='2.27300';@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;
@@ -271,7 +250,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
sub get_$name {
\$_[0]->{PROPS}->[$flag_name] ? 1 : '';
}
- /}}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 =~ /^(?:
+ /}}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);utf8::encode($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){unless($ch=is_valid_utf8($ch)){$at -= 1;decode_error("malformed UTF-8 character in JSON string")}else {$at += $utf8_len - 1}$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]
@@ -289,7 +268,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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;
@@ -306,29 +285,34 @@ $fatpacked{"JSON/PP/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
JSON_PP_BOOLEAN
$fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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;
+ package Module::CPANfile;use strict;use warnings;use Cwd;use Carp ();use Module::CPANfile::Environment;use Module::CPANfile::Requirement;our$VERSION='1.1000';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);$env->parse($code)or die $@;$self->{_mirrors}=$env->mirrors;$self->{_prereqs}=$env->prereqs}sub from_prereqs {my($proto,$prereqs)=@_;my$self=$proto->new;$self->{_prereqs}=Module::CPANfile::Prereqs->from_cpan_meta($prereqs);$self}sub mirrors {my$self=shift;$self->{_mirrors}|| []}sub features {my$self=shift;map$self->feature($_),$self->{_prereqs}->identifiers}sub feature {my($self,$identifier)=@_;$self->{_prereqs}->feature($identifier)}sub prereq {shift->prereqs}sub prereqs {my$self=shift;$self->{_prereqs}->as_cpan_meta}sub merged_requirements {my$self=shift;$self->{_prereqs}->merged_requirements}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->prereqs->as_string_hash}sub prereq_for_module {my($self,$module)=@_;$self->{_prereqs}->find($module)}sub options_for_module {my($self,$module)=@_;my$prereq=$self->prereq_for_module($module)or return;$prereq->requirement->options}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$mirrors=$self->mirrors;my$prereqs=$self->prereq_specs;my$code='';$code .= $self->_dump_mirrors($mirrors);$code .= $self->_dump_prereqs($prereqs,$include_empty);for my$feature ($self->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_mirrors {my($self,$mirrors)=@_;my$code="";for my$url (@$mirrors){$code .= "mirror '$url';\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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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::Environment;use strict;use warnings;use Module::CPANfile::Prereqs;use Carp ();my@bindings=qw(on requires recommends suggests conflicts feature osname mirror configure_requires build_requires test_requires author_requires);my$file_id=1;sub new {my($class,$file)=@_;bless {file=>$file,phase=>'runtime',feature=>undef,features=>{},prereqs=>Module::CPANfile::Prereqs->new,mirrors=>[],},$class}sub bind {my$self=shift;my$pkg=caller;for my$binding (@bindings){no strict 'refs';*{"$pkg\::$binding"}=sub {$self->$binding(@_)}}}sub parse {my($self,$code)=@_;my$err;{local $@;$file_id++;$self->_evaluate(<<EVAL);$err=$@}if ($err){die "Parsing $self->{file} failed: $err"};return 1}sub _evaluate {my$_environment=$_[0];eval $_[1]}sub prereqs {$_[0]->{prereqs}}sub mirrors {$_[0]->{mirrors}}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}=$identifier;$self->prereqs->add_feature($identifier,$description);$code->()}sub osname {die "TODO"}sub mirror {my($self,$url)=@_;push @{$self->{mirrors}},$url}sub requirement_for {my($self,$module,@args)=@_;my$requirement=0;$requirement=shift@args if@args % 2;return Module::CPANfile::Requirement->new(name=>$module,version=>$requirement,@args,)}sub requires {my$self=shift;$self->add_prereq(requires=>@_)}sub recommends {my$self=shift;$self->add_prereq(recommends=>@_)}sub suggests {my$self=shift;$self->add_prereq(suggests=>@_)}sub conflicts {my$self=shift;$self->add_prereq(conflicts=>@_)}sub add_prereq {my($self,$type,$module,@args)=@_;$self->prereqs->add_prereq(feature=>$self->{feature},phase=>$self->{phase},type=>$type,module=>$module,requirement=>$self->requirement_for($module,@args),)}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;
package Module::CPANfile::Sandbox$file_id;
no warnings;
- my \$_result;
- BEGIN { \$_result = Module::CPANfile::Environment->bind }
+ BEGIN { \$_environment->bind }
# line 1 "$self->{file}"
$code;
-
- \$_result;
EVAL
MODULE_CPANFILE_ENVIRONMENT
-$fatpacked{"Module/CPANfile/Result.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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/CPANfile/Prereq.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_PREREQ';
+ package Module::CPANfile::Prereq;use strict;sub new {my($class,%options)=@_;bless \%options,$class}sub feature {$_[0]->{feature}}sub phase {$_[0]->{phase}}sub type {$_[0]->{type}}sub module {$_[0]->{module}}sub requirement {$_[0]->{requirement}}sub match_feature {my($self,$identifier)=@_;no warnings 'uninitialized';$self->feature eq $identifier}1;
+MODULE_CPANFILE_PREREQ
+
+$fatpacked{"Module/CPANfile/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_PREREQS';
+ package Module::CPANfile::Prereqs;use strict;use Carp ();use CPAN::Meta::Feature;use Module::CPANfile::Prereq;sub from_cpan_meta {my($class,$prereqs)=@_;my$self=$class->new;for my$phase (keys %$prereqs){for my$type (keys %{$prereqs->{$phase}}){while (my($module,$requirement)=each %{$prereqs->{$phase}{$type}}){$self->add_prereq(phase=>$phase,type=>$type,module=>$module,requirement=>Module::CPANfile::Requirement->new(name=>$module,version=>$requirement),)}}}$self}sub new {my$class=shift;bless {prereqs=>[],features=>{},},$class}sub add_feature {my($self,$identifier,$description)=@_;$self->{features}{$identifier}={description=>$description }}sub add_prereq {my($self,%args)=@_;$self->add(Module::CPANfile::Prereq->new(%args))}sub add {my($self,$prereq)=@_;push @{$self->{prereqs}},$prereq}sub as_cpan_meta {my$self=shift;$self->{cpanmeta}||= $self->build_cpan_meta}sub build_cpan_meta {my($self,$identifier)=@_;my$prereq_spec={};$self->prereq_each($identifier,sub {my$prereq=shift;$prereq_spec->{$prereq->phase}{$prereq->type}{$prereq->module}=$prereq->requirement->version});CPAN::Meta::Prereqs->new($prereq_spec)}sub prereq_each {my($self,$identifier,$code)=@_;for my$prereq (@{$self->{prereqs}}){next unless$prereq->match_feature($identifier);$code->($prereq)}}sub merged_requirements {my$self=shift;my$reqs=CPAN::Meta::Requirements->new;for my$prereq (@{$self->{prereqs}}){$reqs->add_string_requirement($prereq->module,$prereq->requirement->version)}$reqs}sub find {my($self,$module)=@_;for my$prereq (@{$self->{prereqs}}){return$prereq if$prereq->module eq $module}return}sub identifiers {my$self=shift;keys %{$self->{features}}}sub feature {my($self,$identifier)=@_;my$data=$self->{features}{$identifier}or Carp::croak("Unknown feature '$identifier'");my$prereqs=$self->build_cpan_meta($identifier);CPAN::Meta::Feature->new($identifier,{description=>$data->{description},prereqs=>$prereqs->as_string_hash,})}1;
+MODULE_CPANFILE_PREREQS
+
+$fatpacked{"Module/CPANfile/Requirement.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_REQUIREMENT';
+ package Module::CPANfile::Requirement;use strict;sub new {my ($class,%args)=@_;$args{version}||= 0;bless +{name=>delete$args{name},version=>delete$args{version},options=>\%args,},$class}sub name {$_[0]->{name}}sub version {$_[0]->{version}}sub options {$_[0]->{options}}sub has_options {keys %{$_[0]->{options}}> 0}1;
+MODULE_CPANFILE_REQUIREMENT
$fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_METADATA';
- package Module::Metadata;use strict;use warnings;our$VERSION='1.000019';$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
+ package Module::Metadata;BEGIN {$Module::Metadata::AUTHORITY='cpan:MSTROUT'}$Module::Metadata::VERSION='1.000024';use strict;use warnings;use Carp qw/croak/;use File::Spec;BEGIN {eval {require Fcntl;Fcntl->import('SEEK_SET');1}or *SEEK_SET=sub {0}}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
@@ -341,14 +325,14 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
\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
+ (?: :: )? # a pkg name can start with arisdottle
$PKG_FIRST_WORD_REGEXP # a package word
(?:
- (?: :: )+ ### aristotle (allow one or many times)
+ (?: :: )+ ### arisdottle (allow one or many times)
$PKG_ADDL_WORD_REGEXP ### a package word
)* # ^ zero, one or many times
(?:
- :: # allow trailing aristotle
+ :: # allow trailing arisdottle
)?
}x;my$PKG_REGEXP=qr{ # match a package declaration
^[\s\{;]* # intro chars on a line
@@ -375,40 +359,67 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$VARNAME_REGEXP # without parens
)
\s*
- =[^=~] # = but not ==, nor =~
- }x;sub new_from_file {my$class=shift;my$filename=File::Spec->rel2abs(shift);return undef unless defined($filename)&& -f $filename;return$class->_init(undef,$filename,@_)}sub new_from_handle {my$class=shift;my$handle=shift;my$filename=shift;return undef unless defined($handle)&& defined($filename);$filename=File::Spec->rel2abs($filename);return$class->_init(undef,$filename,@_,handle=>$handle)}sub new_from_module {my$class=shift;my$module=shift;my%props=@_;$props{inc}||=\@INC;my$filename=$class->find_module_by_name($module,$props{inc});return undef unless defined($filename)&& -f $filename;return$class->_init($module,$filename,%props)}{my$compare_versions=sub {my ($v1,$op,$v2)=@_;$v1=version->new($v1)unless UNIVERSAL::isa($v1,'version');my$eval_str="\$v1 $op \$v2";my$result=eval$eval_str;log_info {"error comparing versions: '$eval_str' $@"}if $@;return$result};my$normalize_version=sub {my ($version)=@_;if ($version =~ /[=<>!,]/){}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 { my \$dummy = q# Hide from _packages_inside()
+ =[^=~>] # = but not ==, nor =~, 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 =~ /[=<>!,]/){}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 (not $handle){my$filename=$self->{filename};open$handle,'<',$filename or croak("Can't open '$filename': $!");$self->_handle_bom($handle,$filename)}$self->_parse_fh($handle);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 _;$testfile .= '.pm';return [File::Spec->rel2abs($testfile),$dir ]if -e $testfile}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($sigil,$variable_name,$package);if ($line =~ /$VERS_REGEXP/o){($sigil,$variable_name,$package)=$2 ? ($1,$2,$3): ($4,$5,$6);if ($package){$package=($package eq '::')? 'main' : $package;$package =~ s/::$//}}return ($sigil,$variable_name,$package)}sub _handle_bom {my ($self,$fh,$filename)=@_;my$pos=tell$fh;return unless defined$pos;my$buf=' ' x 2;my$count=read$fh,$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=read$fh,$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 {seek$fh,$pos,SEEK_SET 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(@packages,%vers,%pod,@pod);my$package='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($version_sigil,$version_fullname,$version_package)=index($line,'VERSION')>= 1 ? $self->_parse_version_expression($line): ();if ($line =~ /$PKG_REGEXP/o){$package=$1;my$version=$2;push(@packages,$package)unless grep($package eq $_,@packages);$need_vers=defined$version ? 0 : 1;if (not exists$vers{$package}and defined$version){my$dwim_version=eval {_dwim_version($version)};croak "Version '$version' from $self->{filename} does not appear to be valid:\n$line\n\nThe fatal error was: $@\n" unless defined$dwim_version;$vers{$package}=$dwim_version}}elsif ($version_fullname && $version_package){push(@packages,$version_package)unless grep($version_package eq $_,@packages);$need_vers=0 if$version_package eq $package;unless (defined$vers{$version_package}&& length$vers{$version_package}){$vers{$version_package}=$self->_evaluate_version_line($version_sigil,$version_fullname,$line)}}elsif ($package eq 'main' && $version_fullname &&!exists($vers{main})){$need_vers=0;my$v=$self->_evaluate_version_line($version_sigil,$version_fullname,$line);$vers{$package}=$v;push(@packages,'main')}elsif ($package eq 'main' &&!exists($vers{main})&& $line =~ /\w/){$need_vers=1;$vers{main}='';push(@packages,'main')}elsif ($version_fullname && $need_vers){$need_vers=0;my$v=$self->_evaluate_version_line($version_sigil,$version_fullname,$line);unless (defined$vers{$package}&& length$vers{$package}){$vers{$package}=$v}}}}if ($self->{collect_pod}&& length($pod_data)){$pod{$pod_sect}=$pod_data}$self->{versions}=\%vers;$self->{packages}=\@packages;$self->{pod}=\%pod;$self->{pod_headings}=\@pod}{my$pn=0;sub _evaluate_version_line {my$self=shift;my($sigil,$variable_name,$line)=@_;my$vsub;$pn++;my$eval=qq{BEGIN { my \$dummy = q# Hide from _packages_inside()
#; package Module::Metadata::_version::p$pn;
use version;
no strict;
no warnings;
\$vsub = sub {
- local $sigil$var;
- \$$var=undef;
+ local $sigil$variable_name;
+ \$$variable_name=undef;
$line;
- \$$var
+ \$$variable_name
};
- }};$eval=$1 if$eval =~ m{^(.+)}s;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;
+ }};$eval=$1 if$eval =~ m{^(.+)}s;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}}sub is_indexable {my ($self,$package)=@_;my@indexable_packages=grep {$_ ne 'main'}$self->packages_inside;return!!grep {$_ eq $package}@indexable_packages if$package;return!!@indexable_packages}1;
MODULE_METADATA
$fatpacked{"Parse/CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARSE_CPAN_META';
- 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;
+ use 5.008001;use strict;package Parse::CPAN::Meta;our$VERSION='1.4414';use Exporter;use Carp 'croak';our@ISA=qw/Exporter/;our@EXPORT_OK=qw/Load LoadFile/;sub load_file {my ($class,$filename)=@_;my$meta=_slurp($filename);if ($filename =~ /\.ya?ml$/){return$class->load_yaml_string($meta)}elsif ($filename =~ /\.json$/){return$class->load_json_string($meta)}else {$class->load_string($meta)}}sub load_string {my ($class,$string)=@_;if ($string =~ /^---/){return$class->load_yaml_string($string)}elsif ($string =~ /^\s*\{/){return$class->load_json_string($string)}else {return$class->load_yaml_string($string)}}sub load_yaml_string {my ($class,$string)=@_;my$backend=$class->yaml_backend();my$data=eval {no strict 'refs';&{"$backend\::Load"}($string)};croak $@ if $@;return$data || {}}sub load_json_string {my ($class,$string)=@_;my$data=eval {$class->json_backend()->new->decode($string)};croak $@ if $@;return$data || {}}sub yaml_backend {if (!defined$ENV{PERL_YAML_BACKEND}){_can_load('CPAN::Meta::YAML',0.011)or croak "CPAN::Meta::YAML 0.011 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 {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 {require Encode;open my$fh,"<:raw","$_[0]" or die "can't open $_[0] for reading: $!";my$content=do {local $/;<$fh>};$content=Encode::decode('UTF-8',$content,Encode::PERLQQ());return$content}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 ($) {return Load(_slurp(shift))}sub Load ($) {require CPAN::Meta::YAML;my$object=eval {CPAN::Meta::YAML::Load(shift)};croak $@ if $@;return$object}1;
PARSE_CPAN_META
+$fatpacked{"Parse/PMFile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARSE_PMFILE';
+ package Parse::PMFile;use strict;use warnings;use Safe;use JSON::PP ();use Dumpvalue;use version ();use File::Spec ();our$VERSION='0.28';our$VERBOSE=0;our$ALLOW_DEV_VERSION=0;our$FORK=0;our$UNSAFE=$] < 5.010000 ? 1 : 0;sub new {my ($class,$meta,$opts)=@_;bless {%{$opts || {}},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){my$version;unless (eval {$version=$self->_parse_version;1}){$self->_verbose(1,"error with version in $pmfile: $@");return}$self->{VERSION}=$version;if ($self->{VERSION}=~ /^\{.*\}$/){}elsif ($self->{VERSION}=~ /[_\s]/ &&!$self->{ALLOW_DEV_VERSION}&&!$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,%errors);my%checked_in;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}if ($self->{USERID}&& $self->{PERMISSIONS}&&!$self->_perm_check($package)){delete$ppp->{$package};next}{my (undef,$module)=split m{/lib/},$self->{PMFILE},2;if ($module){$module =~ s{\.pm\z}{};$module =~ s{/}{::}g;if (lc$module eq lc$package && $module ne $package){$errors{$package}={indexing_warning=>"Capitalization of package ($package) does not match filename!",infile=>$self->{PMFILE},}}}}my$pp=$ppp->{$package};if ($pp->{version}&& $pp->{version}=~ /^\{.*\}$/){my$dont_delete;my$err=JSON::PP::decode_json($pp->{version});if ($err->{x_normalize}){$errors{$package}={normalize=>$err->{version},infile=>$pp->{infile},};$pp->{version}="undef";$dont_delete=1}elsif ($err->{openerr}){$self->_verbose(1,qq{Parse::PMFile was not able to
+ read the file. It issued the following error: C< $err->{r} >},);$errors{$package}={open=>$err->{r},infile=>$pp->{infile},}}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.)},);$errors{$package}={parse_version=>$err->{line},infile=>$err->{file},}}unless ($dont_delete){delete$ppp->{$package};next}}for ($package,$pp->{version},){if (!defined || /^\s*$/ || /\s/){delete$ppp->{$package};next}}$checked_in{$package}=$ppp->{$package}}return (wantarray && %errors)? (\%checked_in,\%errors): \%checked_in}sub _perm_check {my ($self,$package)=@_;my$userid=$self->{USERID};my$module=$self->{PERMISSIONS}->module_permissions($package);return 1 if!$module;return 1 if defined$module->m && $module->m eq $userid;return 1 if defined$module->f && $module->f eq $userid;return 1 if defined$module->c && grep {$_ eq $userid}@{$module->c};return}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;if ($self->{FORK}|| $FORK){$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;
+ Parse::PMFile::_parse_version_safely("$pmcp");
+ };$comp->permit("entereval");$comp->share("*Parse::PMFile::_parse_version_safely");$comp->share("*version::new");$comp->share("*version::numify");$comp->share_from('main',['*version::','*charstar::','*Exporter::','*DynaLoader::']);$comp->share_from('version',['&qv']);$comp->permit(":base_math");$comp->deny(qw/enteriter iter unstack goto/);version->import('qv')if$self->{UNSAFE}|| $UNSAFE;{no strict;$v=($self->{UNSAFE}|| $UNSAFE)? eval$eval : $comp->reval($eval)}if ($@){my$err=$@;if (ref$err){if ($err->{line}=~ /([\$*])([\w\:\']*)\bVERSION\b.*?\=(.*)/){local($^W)=0;$self->_restore_overloaded_stuff if version->isa('version::vpp');$v=($self->{UNSAFE}|| $UNSAFE)? eval $3 : $comp->reval($3);$v=$$v if $1 eq '*' && ref$v}if ($@ or!$v){$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)=~ /^version(::vpp)?$/}else {$v=""}if ($self->{FORK}|| $FORK){open my$fh,'>:utf8',$tmpfile;print$fh $v;exit 0}else {utf8::encode($v);$v=undef if defined$v &&!length$v;$comp->erase;$self->_restore_overloaded_stuff}}}unlink$tmpfile if ($self->{FORK}|| $FORK)&& -e $tmpfile;return$self->_normalize_version($v)}sub _restore_overloaded_stuff {my$self=shift;return if$self->{UNSAFE}|| $UNSAFE;no strict 'refs';no warnings 'redefine';if (version->isa('version::vxs')){*{'version::(""'}=\&version::vxs::stringify;*{'version::(0+'}=\&version::vxs::numify;*{'version::(cmp'}=\&version::vxs::VCMP;*{'version::(<=>'}=\&version::vxs::VCMP;*{'version::(bool'}=\&version::vxs::boolean}elsif (version->isa('version::vpp')){{package charstar;overload->import}*{'version::(""'}=\&version::vpp::stringify;*{'version::(0+'}=\&version::vpp::numify;*{'version::(cmp'}=\&version::vpp::vcmp;*{'version::(<=>'}=\&version::vpp::vcmp;*{'version::(bool'}=\&version::vpp::vbool;*{'charstar::(""'}=\&charstar::thischar;*{'charstar::(0+'}=\&charstar::thischar;*{'charstar::(++'}=\&charstar::increment;*{'charstar::(--'}=\&charstar::decrement;*{'charstar::(+'}=\&charstar::plus;*{'charstar::(-'}=\&charstar::minus;*{'charstar::(*'}=\&charstar::multiply;*{'charstar::(cmp'}=\&charstar::cmp;*{'charstar::(<=>'}=\&charstar::spaceship;*{'charstar::(bool'}=\&charstar::thischar;*{'charstar::(='}=\&charstar::clone}else {*{'version::(""'}=\&version::stringify;*{'version::(0+'}=\&version::numify;*{'version::(cmp'}=\&version::vcmp;*{'version::(<=>'}=\&version::vcmp;*{'version::(bool'}=\&version::boolean}}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 =~ /^__(?:END|DATA)__\b/ and $pmfile !~ /\.PL$/){last PLINE}my$pkg;my$strict_version;if ($pline =~ m{
+ # (.*) # takes too much time if $pline is long
+ (?<![*\$\\@%&]) # no sigils
+ \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 (defined$provides->{$pkg}{version}){my$v=$provides->{$pkg}{version};if ($v =~ /[_\s]/ &&!$self->{ALLOW_DEV_VERSION}&&!$ALLOW_DEV_VERSION){next PLINE}unless (eval {$version=$self->_normalize_version($v);1}){$self->_verbose(1,"error with version in $pmfile: $@");next}$ppp->{$pkg}{version}=$version}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 {}}close$fh;$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*#/;last if /^__(?:END|DATA)__\b/;chop;if (my ($ver)=/package \s+ \S+ \s+ (\S+) \s* [;{]/x){return$ver if version::is_lax($ver)}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 }if (!version::is_lax($v)){return JSON::PP::encode_json({x_normalize=>'version::is_lax failed',version=>$v })}my$vv=eval {no warnings;version->new($v)->numify};if ($@){return JSON::PP::encode_json({x_normalize=>$@,version=>$v })}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=$self->_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 <= ((ref$self && $self->{VERBOSE})|| $VERBOSE)}sub _vcmp {my($self,$l,$r)=@_;local($^W)=0;$self->_verbose(9,"l[$l] r[$r]");return 0 if$l eq $r;for ($l,$r){s/_//g}$self->_verbose(9,"l[$l] r[$r]");for ($l,$r){next unless tr/.// > 1 || /^v/;s/^v?/v/;1 while s/\.0+(\d)/.$1/}$self->_verbose(9,"l[$l] r[$r]");if ($l=~/^v/ <=> $r=~/^v/){for ($l,$r){next if /^v/;$_=$self->_float2vv($_)}}$self->_verbose(9,"l[$l] r[$r]");my$lvstring="v0";my$rvstring="v0";if ($] >= 5.006 && $l =~ /^v/ && $r =~ /^v/){$lvstring=$self->_vstring($l);$rvstring=$self->_vstring($r);$self->_verbose(9,sprintf "lv[%vd] rv[%vd]",$lvstring,$rvstring)}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 "Parse::PMFile::_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){$self->_verbose(9,"Suspicious version string seen [$n]\n");return$n}my$better=sprintf "v%vd",$n;$self->_verbose(9,"n[$n] better[$better]");return$better}1;
+PARSE_PMFILE
+
$fatpacked{"String/ShellQuote.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LIB_CORE_ONLY';
package lib::core::only;use strict;use warnings FATAL=>'all';use Config;sub import {@INC=@Config{qw(privlibexp archlibexp)};return}1;
LIB_CORE_ONLY
$fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL_LIB';
- package local::lib;use 5.006;use strict;use warnings;use Config;use File::Spec ();our$VERSION='2.000008';$VERSION=eval$VERSION;sub import {my ($class,@args)=@_;push@args,@ARGV if $0 eq '-';my@steps;my%opts;my$shelltype;while (@args){my$arg=shift@args;if ($arg =~ /\xE2\x88\x92/ or $arg =~ /−/){die <<'DEATH'}elsif ($arg eq '--self-contained'){die <<'DEATH'}elsif($arg =~ /^--deactivate(?:=(.*))?$/){my$path=defined $1 ? $1 : shift@args;push@steps,['deactivate',$path]}elsif ($arg eq '--deactivate-all'){push@steps,['deactivate_all']}elsif ($arg =~ /^--shelltype(?:=(.*))?$/){$shelltype=defined $1 ? $1 : shift@args}elsif ($arg eq '--no-create'){$opts{no_create}=1}elsif ($arg =~ /^--/){die "Unknown import argument: $arg"}else {push@steps,['activate',$arg]}}if (!@steps){push@steps,['activate',undef]}my$self=$class->new(%opts);for (@steps){my ($method,@args)=@$_;$self=$self->$method(@args)}if ($0 eq '-'){print$self->environment_vars_string($shelltype);exit 0}else {$self->setup_local_lib}}sub new {my$class=shift;bless {@_},$class}sub clone {my$self=shift;bless {%$self,@_},ref$self}sub inc {$_[0]->{inc}||=\@INC}sub libs {$_[0]->{libs}||=[\'PERL5LIB' ]}sub bins {$_[0]->{bins}||=[\'PATH' ]}sub roots {$_[0]->{roots}||=[\'PERL_LOCAL_LIB_ROOT' ]}sub extra {$_[0]->{extra}||={}}sub no_create {$_[0]->{no_create}}my$_archname=$Config{archname};my$_version=$Config{version};my@_inc_version_list=reverse split / /,$Config{inc_version_list};my$_path_sep=$Config{path_sep};sub _as_list {my$list=shift;grep length,map {!(ref $_ && ref $_ eq 'SCALAR')? $_ : (defined$ENV{$$_}? split(/\Q$_path_sep/,$ENV{$$_}): ())}ref$list ? @$list : $list}sub _remove_from {my ($list,@remove)=@_;return @$list if!@remove;my%remove=map {$_=>1}@remove;grep!$remove{$_},_as_list($list)}my@_lib_subdirs=([$_version,$_archname],[$_version],[$_archname],(@_inc_version_list ? \@_inc_version_list : ()),[],);sub install_base_bin_path {my ($class,$path)=@_;return File::Spec->catdir($path,'bin')}sub install_base_perl_path {my ($class,$path)=@_;return File::Spec->catdir($path,'lib','perl5')}sub install_base_arch_path {my ($class,$path)=@_;File::Spec->catdir($class->install_base_perl_path($path),$_archname)}sub lib_paths_for {my ($class,$path)=@_;my$base=$class->install_base_perl_path($path);return map {File::Spec->catdir($base,@$_)}@_lib_subdirs}sub _mm_escape_path {my$path=shift;$path =~ s/\\/\\\\\\\\/g;if ($path =~ s/ /\\ /g){$path=qq{"\\"$path\\""}}return$path}sub _mb_escape_path {my$path=shift;$path =~ s/\\/\\\\/g;return qq{"$path"}}sub installer_options_for {my ($class,$path)=@_;return (PERL_MM_OPT=>defined$path ? "INSTALL_BASE="._mm_escape_path($path): undef,PERL_MB_OPT=>defined$path ? "--install_base "._mb_escape_path($path): undef,)}sub active_paths {my ($self)=@_;$self=ref$self ? $self : $self->new;return grep {my$active_ll=$self->install_base_perl_path($_);grep {$_ eq $active_ll}@{$self->inc}}_as_list($self->roots)}sub deactivate {my ($self,$path)=@_;$self=$self->new unless ref$self;$path=$self->resolve_path($path);$path=$self->normalize_path($path);my@active_lls=$self->active_paths;if (!grep {$_ eq $path}@active_lls){warn "Tried to deactivate inactive local::lib '$path'\n";return$self}my%args=(bins=>[_remove_from($self->bins,$self->install_base_bin_path($path))],libs=>[_remove_from($self->libs,$self->install_base_perl_path($path))],inc=>[_remove_from($self->inc,$self->lib_paths_for($path))],roots=>[_remove_from($self->roots,$path)],);$args{extra}={$self->installer_options_for($args{roots}[0])};$self->clone(%args)}sub deactivate_all {my ($self)=@_;$self=$self->new unless ref$self;my@active_lls=$self->active_paths;my%args;if (@active_lls){%args=(bins=>[_remove_from($self->bins,map$self->install_base_bin_path($_),@active_lls)],libs=>[_remove_from($self->libs,map$self->install_base_perl_path($_),@active_lls)],inc=>[_remove_from($self->inc,map$self->lib_paths_for($_),@active_lls)],roots=>[_remove_from($self->roots,@active_lls)],)}$args{extra}={$self->installer_options_for(undef)};$self->clone(%args)}sub activate {my ($self,$path)=@_;$self=$self->new unless ref$self;$path=$self->resolve_path($path);$self->ensure_dir_structure_for($path)unless$self->no_create;$path=$self->normalize_path($path);my@active_lls=$self->active_paths;if (grep {$_ eq $path}@active_lls[1 .. $#active_lls]){$self=$self->deactivate($path)}my%args;if (!@active_lls || $active_lls[0]ne $path){%args=(bins=>[$self->install_base_bin_path($path),@{$self->bins}],libs=>[$self->install_base_perl_path($path),@{$self->libs}],inc=>[$self->lib_paths_for($path),@{$self->inc}],roots=>[$path,@{$self->roots}],)}$args{extra}={$self->installer_options_for($path)};$self->clone(%args)}sub normalize_path {my ($self,$path)=@_;$path=(Win32::GetShortPathName($path)|| $path)if $^O eq 'MSWin32';return$path}sub build_environment_vars_for {my$self=$_[0]->new->activate($_[1]);$self->build_environment_vars}sub build_environment_vars {my$self=shift;(PATH=>join($_path_sep,_as_list($self->bins)),PERL5LIB=>join($_path_sep,_as_list($self->libs)),PERL_LOCAL_LIB_ROOT=>join($_path_sep,_as_list($self->roots)),%{$self->extra},)}sub setup_local_lib_for {my$self=$_[0]->new->activate($_[1]);$self->setup_local_lib}sub setup_local_lib {my$self=shift;$self->setup_env_hash;@INC=@{$self->inc}}sub setup_env_hash_for {my$self=$_[0]->new->activate($_[1]);$self->setup_env_hash}sub setup_env_hash {my$self=shift;my%env=$self->build_environment_vars;for my$key (keys%env){if (defined$env{$key}){$ENV{$key}=$env{$key}}else {delete$ENV{$key}}}}sub print_environment_vars_for {print $_[0]->environment_vars_string_for(@_[1..$#_])}sub environment_vars_string_for {my$self=$_[0]->new->activate($_[1]);$self->environment_vars_string}sub environment_vars_string {my ($self,$shelltype)=@_;$shelltype ||=$self->guess_shelltype;my$build_method="build_${shelltype}_env_declaration";my$extra=$self->extra;my@envs=(PATH=>$self->bins,PERL5LIB=>$self->libs,PERL_LOCAL_LIB_ROOT=>$self->roots,map {$_=>$extra->{$_}}sort keys %$extra,);my$out='';while (@envs){my ($name,$value)=(shift(@envs),shift(@envs));if (ref$value && @$value==1 && ref$value->[0]&& ref$value->[0]eq 'SCALAR' && ${$value->[0]}eq $name){next}if (!ref$value and defined$value ? (defined$ENV{$name}&& $value eq $ENV{$name}):!defined$ENV{$name}){next}$out .= $self->$build_method($name,$value)}my$wrap_method="wrap_${shelltype}_output";if ($self->can($wrap_method)){return$self->$wrap_method($out)}return$out}sub build_bourne_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'$%s','"','\\%s');if (!defined$value){return qq{unset $name;\n}}$value =~ s/(^|\G|$_path_sep)\$$name$_path_sep/$1\$$name\${$name+$_path_sep}/g;$value =~ s/$_path_sep\$$name$/\${$name+$_path_sep}\$$name/;qq{${name}="$value"; export ${name};\n}}sub build_csh_env_declaration {my ($class,$name,$args)=@_;my ($value,@vars)=$class->_interpolate($args,'$%s','"','"\\%s"');if (!defined$value){return qq{unsetenv $name;\n}}my$out='';for my$var (@vars){$out .= qq{if ! \$?$name setenv $name '';\n}}my$value_without=$value;if ($value_without =~ s/(?:^|$_path_sep)\$$name(?:$_path_sep|$)//g){$out .= qq{if "\$$name" != '' setenv $name "$value";\n};$out .= qq{if "\$$name" == '' }}$out .= qq{setenv $name "$value_without";\n};return$out}sub build_cmd_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'%%%s%%',qr([()!^"<>&|]),'^%s');if (!$value){return qq{\@set $name=\n}}my$out='';my$value_without=$value;if ($value_without =~ s/(?:^|$_path_sep)%$name%(?:$_path_sep|$)//g){$out .= qq{\@if not "%$name%"=="" set $name=$value\n};$out .= qq{\@if "%$name%"=="" }}$out .= qq{\@set $name=$value_without\n};return$out}sub build_powershell_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'$env:%s','"','`%s');if (!$value){return qq{Remove-Item -ErrorAction 0 Env:\\$name;\n}}my$maybe_path_sep=qq{\$(if("\$env:$name"-eq""){""}else{"$_path_sep"})};$value =~ s/(^|\G|$_path_sep)\$env:$name$_path_sep/$1\$env:$name"+$maybe_path_sep+"/g;$value =~ s/$_path_sep\$env:$name$/"+$maybe_path_sep+\$env:$name+"/;qq{\$env:$name = \$("$value");\n}}sub wrap_powershell_output {my ($class,$out)=@_;return$out || " \n"}sub build_fish_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'$%s','"','\\%s');if (!defined$value){return qq{set -e $name;\n}}$value =~ s/$_path_sep/ /g;qq{set -x $name $value;\n}}sub _interpolate {my ($class,$args,$var_pat,$escape,$escape_pat)=@_;return unless defined$args;my@args=ref$args ? @$args : $args;return unless@args;my@vars=map {$$_}grep {ref $_ eq 'SCALAR'}@args;my$string=join$_path_sep,map {ref $_ eq 'SCALAR' ? sprintf($var_pat,$$_): do {s/($escape)/sprintf($escape_pat, $1)/ge;$_}}@args;return wantarray ? ($string,\@vars): $string}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 resolve_path {my ($class,$path)=@_;$path=$class->${pipeline qw(resolve_relative_path resolve_home_path resolve_empty_path)}($path);$path}sub resolve_empty_path {my ($class,$path)=@_;if (defined$path){$path}else {'~/perl5'}}sub resolve_home_path {my ($class,$path)=@_;$path =~ /^~([^\/]*)/ or return$path;my$user=$1;my$homedir=do {if (!length($user)&& defined$ENV{HOME}){$ENV{HOME}}else {require File::Glob;File::Glob::bsd_glob("~$user",File::Glob::GLOB_TILDE())}};unless (defined$homedir){require Carp;Carp::croak("Couldn't resolve homedir for " .(defined$user ? $user : 'current user'))}$path =~ s/^~[^\/]*/$homedir/;$path}sub resolve_relative_path {my ($class,$path)=@_;$path=File::Spec->rel2abs($path)}sub ensure_dir_structure_for {my ($class,$path)=@_;unless (-d $path){warn "Attempting to create directory ${path}\n"}require File::Basename;my@dirs;while(!-d $path){push@dirs,$path;$path=File::Basename::dirname($path)}mkdir $_ for reverse@dirs;return}sub guess_shelltype {my$shellbin =defined$ENV{SHELL}? ($ENV{SHELL}=~ /([\w.]+)$/)[-1]: ($^O eq 'MSWin32' && exists$ENV{'!EXITCODE'})? 'bash' : ($^O eq 'MSWin32' && $ENV{PROMPT}&& $ENV{COMSPEC})? ($ENV{COMSPEC}=~ /([\w.]+)$/)[-1]: ($^O eq 'MSWin32' &&!$ENV{PROMPT})? 'powershell.exe' : 'sh';for ($shellbin){return /csh$/ ? 'csh' : /fish/ ? 'fish' : /command(?:\.com)?$/i ? 'cmd' : /cmd(?:\.exe)?$/i ? 'cmd' : /4nt(?:\.exe)?$/i ? 'cmd' : /powershell(?:\.exe)?$/i ? 'powershell' : 'bourne'}}1;
+ package local::lib;use 5.006;use strict;use warnings;use Config;our$VERSION='2.000014';$VERSION=eval$VERSION;BEGIN {*_WIN32=($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'symbian')? sub(){1}: sub(){0};*_USE_FSPEC=($^O eq 'MacOS' || $^O eq 'VMS' || $INC{'File/Spec.pm'})? sub(){1}: sub(){0}}our$_DIR_JOIN=_WIN32 ? '\\' : '/';our$_DIR_SPLIT=(_WIN32 || $^O eq 'cygwin')? qr{[\\/]} : qr{/};our$_ROOT=_WIN32 ? do {my$UNC=qr{[\\/]{2}[^\\/]+[\\/][^\\/]+};qr{^(?:$UNC|[A-Za-z]:|)$_DIR_SPLIT}}: qr{^/};our$_PERL;sub _cwd {my$drive=shift;if (!$_PERL){($_PERL)=$^X =~ /(.+)/;if (_is_abs($_PERL)){}elsif (-x $Config{perlpath}){$_PERL=$Config{perlpath}}else {($_PERL)=map {/(.*)/}grep {-x $_}map {join($_DIR_JOIN,$_,$_PERL)}split /\Q$Config{path_sep}\E/,$ENV{PATH}}}local@ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};my$cmd=$drive ? "eval { Cwd::getdcwd(q($drive)) }" : 'getcwd';my$cwd=`"$_PERL" -MCwd -le "print $cmd"`;chomp$cwd;if (!length$cwd && $drive){$cwd=$drive}$cwd =~ s/$_DIR_SPLIT?$/$_DIR_JOIN/;$cwd}sub _catdir {if (_USE_FSPEC){require File::Spec;File::Spec->catdir(@_)}else {my$dir=join($_DIR_JOIN,@_);$dir =~ s{($_DIR_SPLIT)(?:\.?$_DIR_SPLIT)+}{$1}g;$dir}}sub _is_abs {if (_USE_FSPEC){require File::Spec;File::Spec->file_name_is_absolute($_[0])}else {$_[0]=~ $_ROOT}}sub _rel2abs {my ($dir,$base)=@_;return$dir if _is_abs($dir);$base=_WIN32 && $dir =~ s/^([A-Za-z]:)// ? _cwd("$1"): $base ? $base : _cwd;return _catdir($base,$dir)}sub import {my ($class,@args)=@_;push@args,@ARGV if $0 eq '-';my@steps;my%opts;my$shelltype;while (@args){my$arg=shift@args;if ($arg =~ /\xE2\x88\x92/ or $arg =~ /−/){die <<'DEATH'}elsif ($arg eq '--self-contained'){die <<'DEATH'}elsif($arg =~ /^--deactivate(?:=(.*))?$/){my$path=defined $1 ? $1 : shift@args;push@steps,['deactivate',$path]}elsif ($arg eq '--deactivate-all'){push@steps,['deactivate_all']}elsif ($arg =~ /^--shelltype(?:=(.*))?$/){$shelltype=defined $1 ? $1 : shift@args}elsif ($arg eq '--no-create'){$opts{no_create}=1}elsif ($arg =~ /^--/){die "Unknown import argument: $arg"}else {push@steps,['activate',$arg]}}if (!@steps){push@steps,['activate',undef]}my$self=$class->new(%opts);for (@steps){my ($method,@args)=@$_;$self=$self->$method(@args)}if ($0 eq '-'){print$self->environment_vars_string($shelltype);exit 0}else {$self->setup_local_lib}}sub new {my$class=shift;bless {@_},$class}sub clone {my$self=shift;bless {%$self,@_},ref$self}sub inc {$_[0]->{inc}||= \@INC}sub libs {$_[0]->{libs}||= [\'PERL5LIB' ]}sub bins {$_[0]->{bins}||= [\'PATH' ]}sub roots {$_[0]->{roots}||= [\'PERL_LOCAL_LIB_ROOT' ]}sub extra {$_[0]->{extra}||= {}}sub no_create {$_[0]->{no_create}}my$_archname=$Config{archname};my$_version=$Config{version};my@_inc_version_list=reverse split / /,$Config{inc_version_list};my$_path_sep=$Config{path_sep};sub _as_list {my$list=shift;grep length,map {!(ref $_ && ref $_ eq 'SCALAR')? $_ : (defined$ENV{$$_}? split(/\Q$_path_sep/,$ENV{$$_}): ())}ref$list ? @$list : $list}sub _remove_from {my ($list,@remove)=@_;return @$list if!@remove;my%remove=map {$_=>1}@remove;grep!$remove{$_},_as_list($list)}my@_lib_subdirs=([$_version,$_archname],[$_version],[$_archname],(@_inc_version_list ? \@_inc_version_list : ()),[],);sub install_base_bin_path {my ($class,$path)=@_;return _catdir($path,'bin')}sub install_base_perl_path {my ($class,$path)=@_;return _catdir($path,'lib','perl5')}sub install_base_arch_path {my ($class,$path)=@_;_catdir($class->install_base_perl_path($path),$_archname)}sub lib_paths_for {my ($class,$path)=@_;my$base=$class->install_base_perl_path($path);return map {_catdir($base,@$_)}@_lib_subdirs}sub _mm_escape_path {my$path=shift;$path =~ s/\\/\\\\\\\\/g;if ($path =~ s/ /\\ /g){$path=qq{"\\"$path\\""}}return$path}sub _mb_escape_path {my$path=shift;$path =~ s/\\/\\\\/g;return qq{"$path"}}sub installer_options_for {my ($class,$path)=@_;return (PERL_MM_OPT=>defined$path ? "INSTALL_BASE="._mm_escape_path($path): undef,PERL_MB_OPT=>defined$path ? "--install_base "._mb_escape_path($path): undef,)}sub active_paths {my ($self)=@_;$self=ref$self ? $self : $self->new;return grep {my$active_ll=$self->install_base_perl_path($_);grep {$_ eq $active_ll}@{$self->inc}}_as_list($self->roots)}sub deactivate {my ($self,$path)=@_;$self=$self->new unless ref$self;$path=$self->resolve_path($path);$path=$self->normalize_path($path);my@active_lls=$self->active_paths;if (!grep {$_ eq $path}@active_lls){warn "Tried to deactivate inactive local::lib '$path'\n";return$self}my%args=(bins=>[_remove_from($self->bins,$self->install_base_bin_path($path))],libs=>[_remove_from($self->libs,$self->install_base_perl_path($path))],inc=>[_remove_from($self->inc,$self->lib_paths_for($path))],roots=>[_remove_from($self->roots,$path)],);$args{extra}={$self->installer_options_for($args{roots}[0])};$self->clone(%args)}sub deactivate_all {my ($self)=@_;$self=$self->new unless ref$self;my@active_lls=$self->active_paths;my%args;if (@active_lls){%args=(bins=>[_remove_from($self->bins,map$self->install_base_bin_path($_),@active_lls)],libs=>[_remove_from($self->libs,map$self->install_base_perl_path($_),@active_lls)],inc=>[_remove_from($self->inc,map$self->lib_paths_for($_),@active_lls)],roots=>[_remove_from($self->roots,@active_lls)],)}$args{extra}={$self->installer_options_for(undef)};$self->clone(%args)}sub activate {my ($self,$path)=@_;$self=$self->new unless ref$self;$path=$self->resolve_path($path);$self->ensure_dir_structure_for($path)unless$self->no_create;$path=$self->normalize_path($path);my@active_lls=$self->active_paths;if (grep {$_ eq $path}@active_lls[1 .. $#active_lls]){$self=$self->deactivate($path)}my%args;if (!@active_lls || $active_lls[0]ne $path){%args=(bins=>[$self->install_base_bin_path($path),@{$self->bins}],libs=>[$self->install_base_perl_path($path),@{$self->libs}],inc=>[$self->lib_paths_for($path),@{$self->inc}],roots=>[$path,@{$self->roots}],)}$args{extra}={$self->installer_options_for($path)};$self->clone(%args)}sub normalize_path {my ($self,$path)=@_;$path=(Win32::GetShortPathName($path)|| $path)if $^O eq 'MSWin32';return$path}sub build_environment_vars_for {my$self=$_[0]->new->activate($_[1]);$self->build_environment_vars}sub build_activate_environment_vars_for {my$self=$_[0]->new->activate($_[1]);$self->build_environment_vars}sub build_deactivate_environment_vars_for {my$self=$_[0]->new->deactivate($_[1]);$self->build_environment_vars}sub build_deact_all_environment_vars_for {my$self=$_[0]->new->deactivate_all;$self->build_environment_vars}sub build_environment_vars {my$self=shift;(PATH=>join($_path_sep,_as_list($self->bins)),PERL5LIB=>join($_path_sep,_as_list($self->libs)),PERL_LOCAL_LIB_ROOT=>join($_path_sep,_as_list($self->roots)),%{$self->extra},)}sub setup_local_lib_for {my$self=$_[0]->new->activate($_[1]);$self->setup_local_lib}sub setup_local_lib {my$self=shift;require Carp::Heavy if$INC{'Carp.pm'};$self->setup_env_hash;@INC=@{$self->inc}}sub setup_env_hash_for {my$self=$_[0]->new->activate($_[1]);$self->setup_env_hash}sub setup_env_hash {my$self=shift;my%env=$self->build_environment_vars;for my$key (keys%env){if (defined$env{$key}){$ENV{$key}=$env{$key}}else {delete$ENV{$key}}}}sub print_environment_vars_for {print $_[0]->environment_vars_string_for(@_[1..$#_])}sub environment_vars_string_for {my$self=$_[0]->new->activate($_[1]);$self->environment_vars_string}sub environment_vars_string {my ($self,$shelltype)=@_;$shelltype ||= $self->guess_shelltype;my$extra=$self->extra;my@envs=(PATH=>$self->bins,PERL5LIB=>$self->libs,PERL_LOCAL_LIB_ROOT=>$self->roots,map {$_=>$extra->{$_}}sort keys %$extra,);$self->_build_env_string($shelltype,\@envs)}sub _build_env_string {my ($self,$shelltype,$envs)=@_;my@envs=@$envs;my$build_method="build_${shelltype}_env_declaration";my$out='';while (@envs){my ($name,$value)=(shift(@envs),shift(@envs));if (ref$value && @$value==1 && ref$value->[0]&& ref$value->[0]eq 'SCALAR' && ${$value->[0]}eq $name){next}$out .= $self->$build_method($name,$value)}my$wrap_method="wrap_${shelltype}_output";if ($self->can($wrap_method)){return$self->$wrap_method($out)}return$out}sub build_bourne_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'${%s}',qr/["\\\$!`]/,'\\%s');if (!defined$value){return qq{unset $name;\n}}$value =~ s/(^|\G|$_path_sep)\$\{$name\}$_path_sep/$1\${$name}\${$name+$_path_sep}/g;$value =~ s/$_path_sep\$\{$name\}$/\${$name+$_path_sep}\${$name}/;qq{${name}="$value"; export ${name};\n}}sub build_csh_env_declaration {my ($class,$name,$args)=@_;my ($value,@vars)=$class->_interpolate($args,'${%s}','"','"\\%s"');if (!defined$value){return qq{unsetenv $name;\n}}my$out='';for my$var (@vars){$out .= qq{if ! \$?$name setenv $name '';\n}}my$value_without=$value;if ($value_without =~ s/(?:^|$_path_sep)\$\{$name\}(?:$_path_sep|$)//g){$out .= qq{if "\${$name}" != '' setenv $name "$value";\n};$out .= qq{if "\${$name}" == '' }}$out .= qq{setenv $name "$value_without";\n};return$out}sub build_cmd_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'%%%s%%',qr(%),'%s');if (!$value){return qq{\@set $name=\n}}my$out='';my$value_without=$value;if ($value_without =~ s/(?:^|$_path_sep)%$name%(?:$_path_sep|$)//g){$out .= qq{\@if not "%$name%"=="" set "$name=$value"\n};$out .= qq{\@if "%$name%"=="" }}$out .= qq{\@set "$name=$value_without"\n};return$out}sub build_powershell_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'$env:%s','"','`%s');if (!$value){return qq{Remove-Item -ErrorAction 0 Env:\\$name;\n}}my$maybe_path_sep=qq{\$(if("\$env:$name"-eq""){""}else{"$_path_sep"})};$value =~ s/(^|\G|$_path_sep)\$env:$name$_path_sep/$1\$env:$name"+$maybe_path_sep+"/g;$value =~ s/$_path_sep\$env:$name$/"+$maybe_path_sep+\$env:$name+"/;qq{\$env:$name = \$("$value");\n}}sub wrap_powershell_output {my ($class,$out)=@_;return$out || " \n"}sub build_fish_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'$%s',qr/[\\"' ]/,'\\%s');if (!defined$value){return qq{set -e $name;\n}}$value =~ s/$_path_sep/ /g;qq{set -x $name $value;\n}}sub _interpolate {my ($class,$args,$var_pat,$escape,$escape_pat)=@_;return unless defined$args;my@args=ref$args ? @$args : $args;return unless@args;my@vars=map {$$_}grep {ref $_ eq 'SCALAR'}@args;my$string=join$_path_sep,map {ref $_ eq 'SCALAR' ? sprintf($var_pat,$$_): do {s/($escape)/sprintf($escape_pat, $1)/ge;$_}}@args;return wantarray ? ($string,\@vars): $string}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 resolve_path {my ($class,$path)=@_;$path=$class->${pipeline qw(resolve_relative_path resolve_home_path resolve_empty_path)}($path);$path}sub resolve_empty_path {my ($class,$path)=@_;if (defined$path){$path}else {'~/perl5'}}sub resolve_home_path {my ($class,$path)=@_;$path =~ /^~([^\/]*)/ or return$path;my$user=$1;my$homedir=do {if (!length($user)&& defined$ENV{HOME}){$ENV{HOME}}else {require File::Glob;File::Glob::bsd_glob("~$user",File::Glob::GLOB_TILDE())}};unless (defined$homedir){require Carp;require Carp::Heavy;Carp::croak("Couldn't resolve homedir for " .(defined$user ? $user : 'current user'))}$path =~ s/^~[^\/]*/$homedir/;$path}sub resolve_relative_path {my ($class,$path)=@_;_rel2abs($path)}sub ensure_dir_structure_for {my ($class,$path)=@_;unless (-d $path){warn "Attempting to create directory ${path}\n"}require File::Basename;my@dirs;while(!-d $path){push@dirs,$path;$path=File::Basename::dirname($path)}mkdir $_ for reverse@dirs;return}sub guess_shelltype {my$shellbin =defined$ENV{SHELL}? ($ENV{SHELL}=~ /([\w.]+)$/)[-1]: ($^O eq 'MSWin32' && exists$ENV{'!EXITCODE'})? 'bash' : ($^O eq 'MSWin32' && $ENV{PROMPT}&& $ENV{COMSPEC})? ($ENV{COMSPEC}=~ /([\w.]+)$/)[-1]: ($^O eq 'MSWin32' &&!$ENV{PROMPT})? 'powershell.exe' : 'sh';for ($shellbin){return /csh$/ ? 'csh' : /fish/ ? 'fish' : /command(?:\.com)?$/i ? 'cmd' : /cmd(?:\.exe)?$/i ? 'cmd' : /4nt(?:\.exe)?$/i ? 'cmd' : /powershell(?:\.exe)?$/i ? 'powershell' : 'bourne'}}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
@@ -429,15 +440,15 @@ $fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL
LOCAL_LIB
$fatpacked{"parent.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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"}}{no strict 'refs';push @{"$inheritor\::ISA"},@_}};"All your base are belong to us"
+ package parent;use strict;use vars qw($VERSION);$VERSION='0.228';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"}}{no strict 'refs';push @{"$inheritor\::ISA"},@_}};"All your base are belong to us"
PARENT
$fatpacked{"version.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION';
- package version;use 5.006002;use strict;use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);$VERSION=0.9908;$CLASS='version';{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}}}require version::regex;*version::is_lax=\&version::regex::is_lax;*version::is_strict=\&version::regex::is_strict;*LAX=\$version::regex::LAX;*STRICT=\$version::regex::STRICT;sub import {no strict 'refs';my ($class)=shift;unless ($class eq $CLASS){local $^W;*{$class.'::declare'}=\&{$CLASS.'::declare'};*{$class.'::qv'}=\&{$CLASS.'::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 =\&{$CLASS.'::_VERSION'}}if (exists($args{'VERSION'})){*{$callpkg.'::VERSION'}=\&{$CLASS.'::_VERSION'}}if (exists($args{'is_strict'})){*{$callpkg.'::is_strict'}=\&{$CLASS.'::is_strict'}unless defined(&{$callpkg.'::is_strict'})}if (exists($args{'is_lax'})){*{$callpkg.'::is_lax'}=\&{$CLASS.'::is_lax'}unless defined(&{$callpkg.'::is_lax'})}}1;
+ package version;use 5.006002;use strict;use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);$VERSION=0.9909;$CLASS='version';{local$SIG{'__DIE__'};if (1){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}}}require version::regex;*version::is_lax=\&version::regex::is_lax;*version::is_strict=\&version::regex::is_strict;*LAX=\$version::regex::LAX;*STRICT=\$version::regex::STRICT;sub import {no strict 'refs';my ($class)=shift;unless ($class eq $CLASS){local $^W;*{$class.'::declare'}=\&{$CLASS.'::declare'};*{$class.'::qv'}=\&{$CLASS.'::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 =\&{$CLASS.'::_VERSION'}}if (exists($args{'VERSION'})){*{$callpkg.'::VERSION'}=\&{$CLASS.'::_VERSION'}}if (exists($args{'is_strict'})){*{$callpkg.'::is_strict'}=\&{$CLASS.'::is_strict'}unless defined(&{$callpkg.'::is_strict'})}if (exists($args{'is_lax'})){*{$callpkg.'::is_lax'}=\&{$CLASS.'::is_lax'}unless defined(&{$callpkg.'::is_lax'})}}1;
VERSION
$fatpacked{"version/regex.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION_REGEX';
- package version::regex;use strict;use vars qw($VERSION $CLASS $STRICT $LAX);$VERSION=0.9908;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? )?
+ package version::regex;use strict;use vars qw($VERSION $CLASS $STRICT $LAX);$VERSION=0.9909;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;my$LAX_DOTTED_DECIMAL_VERSION=qr/
@@ -448,7 +459,7 @@ $fatpacked{"version/regex.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'V
VERSION_REGEX
$fatpacked{"version/vpp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION_VPP';
- 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 5.006002;use strict;use Config;use vars qw($VERSION $CLASS @ISA $LAX $STRICT);$VERSION=0.9908;$CLASS='version::vpp';require version::regex;*version::vpp::is_strict=\&version::regex::is_strict;*version::vpp::is_lax=\&version::regex::is_lax;*LAX=\$version::regex::LAX;*STRICT=\$version::regex::STRICT;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 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 5.006002;use strict;use Config;use vars qw($VERSION $CLASS @ISA $LAX $STRICT);$VERSION=0.9909;$CLASS='version::vpp';require version::regex;*version::vpp::is_strict=\&version::regex::is_strict;*version::vpp::is_lax=\&version::regex::is_lax;*LAX=\$version::regex::LAX;*STRICT=\$version::regex::STRICT;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;}
@@ -587,23 +598,6 @@ 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.
@@ -683,6 +677,10 @@ directory C<extlib>, which can be loaded from your application with:
use local::lib '/path/to/extlib';
+Note that this option does B<NOT> reliably work with perl
+installations supplied by operating system vendors that strips
+standard modules from perl, such as RHEL, Fedora and CentOS.
+
=item --self-contained
When examining the dependencies, assume no non-core modules are
@@ -931,7 +929,7 @@ 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
+A dialog will 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.
@@ -11,6 +11,7 @@ package App::cpanminus::fatscript;
# 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
@@ -20,7 +21,7 @@ my %fatpacked;
$fatpacked{"App/cpanminus.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS';
package App::cpanminus;
- our $VERSION = "1.7004";
+ our $VERSION = "1.7014";
=encoding utf8
@@ -181,7 +182,7 @@ $fatpacked{"App/cpanminus.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'A
=item *
- Tests that might fail when C<AUTOMATED_TESTING> is enabled.
+ Build.PL or Makefile.PL that prompts for input when C<PERL_MM_USE_DEFAULT> is enabled.
=item *
@@ -237,8 +238,6 @@ $fatpacked{"App/cpanminus.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'A
=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
@@ -493,1037 +492,485 @@ $fatpacked{"App/cpanminus/Dependency.pm"} = '#line '.(1+__LINE__).' "'.__FILE__.
1;
APP_CPANMINUS_DEPENDENCY
-$fatpacked{"App/cpanminus/ParsePM.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS_PARSEPM';
- package App::cpanminus::ParsePM;
- # fork of Parse::PMFile, use JSON::PP instead of JSON
-
+$fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS_SCRIPT';
+ package App::cpanminus::script;
use strict;
- use warnings;
- use Safe;
- use JSON::PP;
- use Dumpvalue;
- #use CPAN::Version;
- use version ();
+ use Config;
+ use Cwd ();
+ use App::cpanminus;
+ use App::cpanminus::Dependency;
+ use File::Basename ();
+ use File::Find ();
+ use File::Path ();
use File::Spec ();
+ use File::Copy ();
use File::Temp ();
- use POSIX ':sys_wait_h';
- use App::cpanminus::CPANVersion;
-
- our $VERSION = '0.04';
- our $VERBOSE = 0;
- our $ALLOW_DEV_VERSION = 0;
-
- sub new {
- my ($class, $meta) = @_;
- bless {META_CONTENT => $meta}, $class;
- }
-
- # from PAUSE::pmfile::examine_fio
- sub parse {
- my ($self, $pmfile) = @_;
-
- $pmfile =~ s|\\|/|g;
+ use Getopt::Long ();
+ use Symbol ();
+ use String::ShellQuote ();
+ use version ();
- my($filemtime) = (stat $pmfile)[9];
- $self->{MTIME} = $filemtime;
- $self->{PMFILE} = $pmfile;
+ use constant WIN32 => $^O eq 'MSWin32';
+ use constant BAD_TAR => ($^O eq 'solaris' || $^O eq 'hpux');
+ use constant CAN_SYMLINK => eval { symlink("", ""); 1 };
- unless ($self->_version_from_meta_ok) {
- $self->{VERSION} = $self->_parse_version;
- if ($self->{VERSION} =~ /^\{.*\}$/) {
- # JSON error message
- } elsif ($self->{VERSION} =~ /[_\s]/ && !$ALLOW_DEV_VERSION){ # ignore developer releases and "You suck!"
- return;
- }
- }
+ our $VERSION = $App::cpanminus::VERSION;
- 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");
+ if ($INC{"App/FatPacker/Trace.pm"}) {
+ require JSON::PP;
+ require CPAN::Meta::YAML;
+ require CPAN::Meta::Prereqs;
+ require version::vpp;
+ require File::pushd;
+ require Parse::PMFile;
+ }
- #
- # Immediately after each package (pmfile) examined contact
- # the database
- #
+ my $quote = WIN32 ? q/"/ : q/'/;
- my ($package);
- DBPACK: foreach $package (@keys_ppp) {
- # this part is taken from PAUSE::package::examine_pkg
- if ($package !~ /^\w[\w\:\']*\w?\z/
- ||
- $package !~ /\w\z/
- ||
- $package =~ /:/ && $package !~ /::/
- ||
- $package =~ /\w:\w/
- ||
- $package =~ /:::/
- ){
- $self->_verbose(1,"Package[$package] did not pass the ultimate sanity check");
- delete $ppp->{$package};
- next;
- }
+ sub agent {
+ my $self = shift;
+ my $agent = "cpanminus/$VERSION";
+ $agent .= " perl/$]" if $self->{report_perl_version};
+ $agent;
+ }
- # Can't do perm_check() here.
+ sub determine_home {
+ my $class = shift;
- my $pp = $ppp->{$package};
- if ($pp->{version} && $pp->{version} =~ /^\{.*\}$/) { # JSON parser error
- my $err = JSON::PP::decode_json($pp->{version});
- if ($err->{openerr}) {
- $self->_verbose(1,
- qq{Parse::PMFile was not able to
- read the file. It issued the following error: C< $err->{r} >},
- );
- } else {
- $self->_verbose(1,
- qq{Parse::PMFile was not able to
- parse the following line in that file: C< $err->{line} >
+ my $homedir = $ENV{HOME}
+ || eval { require File::HomeDir; File::HomeDir->my_home }
+ || join('', @ENV{qw(HOMEDRIVE HOMEPATH)}); # Win32
- 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.)},
+ if (WIN32) {
+ require Win32; # no fatpack
+ $homedir = Win32::GetShortPathName($homedir);
+ }
- );
- }
- delete $ppp->{$package};
- next;
- }
+ return "$homedir/.cpanm";
+ }
- # Sanity checks
+ sub new {
+ my $class = shift;
- for (
- $package,
- $pp->{version},
- ) {
- if (!defined || /^\s*$/ || /\s/){ # for whatever reason I come here
- delete $ppp->{$package};
- next; # don't screw up 02packages
- }
- }
- } # end foreach package
+ bless {
+ home => $class->determine_home,
+ cmd => 'install',
+ seen => {},
+ notest => undef,
+ test_only => undef,
+ installdeps => undef,
+ force => undef,
+ sudo => undef,
+ make => undef,
+ verbose => undef,
+ quiet => undef,
+ interactive => undef,
+ log => undef,
+ mirrors => [],
+ mirror_only => undef,
+ mirror_index => undef,
+ cpanmetadb => "http://cpanmetadb.plackperl.org/v1.0/",
+ perl => $^X,
+ argv => [],
+ local_lib => undef,
+ self_contained => undef,
+ prompt_timeout => 0,
+ prompt => undef,
+ configure_timeout => 60,
+ build_timeout => 3600,
+ test_timeout => 1800,
+ try_lwp => 1,
+ try_wget => 1,
+ try_curl => 1,
+ uninstall_shadows => ($] < 5.012),
+ skip_installed => 1,
+ skip_satisfied => 0,
+ auto_cleanup => 7, # days
+ pod2man => 1,
+ installed_dists => 0,
+ install_types => ['requires'],
+ with_develop => 0,
+ showdeps => 0,
+ scandeps => 0,
+ scandeps_tree => [],
+ format => 'tree',
+ save_dists => undef,
+ skip_configure => 0,
+ verify => 0,
+ report_perl_version => 1,
+ build_args => {},
+ features => {},
+ pure_perl => 0,
+ cpanfile_path => 'cpanfile',
+ @_,
+ }, $class;
+ }
- return $ppp;
+ sub env {
+ my($self, $key) = @_;
+ $ENV{"PERL_CPANM_" . $key};
}
- # from PAUSE::pmfile;
- sub _parse_version {
+ sub install_type_handlers {
my $self = shift;
- use strict;
-
- my $pmfile = $self->{PMFILE};
- my $tmpfile = File::Spec->catfile(File::Spec->tmpdir, "ParsePMFile$$" . rand(1000));
-
- my $pmcp = $pmfile;
- for ($pmcp) {
- s/([^\\](\\\\)*)@/$1\\@/g; # thanks to Raphael Manfredi for the
- # solution to escape @s and \
+ my @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}} ];
+ };
}
- my($v);
- {
- package main; # seems necessary
+ @handlers;
+ }
- # XXX: do we need to fork as PAUSE does?
- # or, is alarm() just fine?
- my $pid = fork();
- die "Can't fork: $!" unless defined $pid;
- if ($pid) {
- waitpid($pid, 0);
- if (open my $fh, '<', $tmpfile) {
- $v = <$fh>;
- }
- } else {
- # XXX Limit Resources too
+ sub build_args_handlers {
+ my $self = shift;
- my($comp) = Safe->new("_pause::mldistwatch");
- my $eval = qq{
- local(\$^W) = 0;
- App::cpanminus::ParsePM::_parse_version_safely("$pmcp");
- };
- $comp->permit("entereval"); # for MBARBON/Module-Info-0.30.tar.gz
- $comp->share("*App::cpanminus::ParsePM::_parse_version_safely");
- $comp->share("*version::new");
- $comp->share("*version::numify");
- $comp->share_from('main', ['*version::',
- '*Exporter::',
- '*DynaLoader::']);
- $comp->share_from('version', ['&qv']);
- # $comp->permit("require"); # no strict!
- $comp->deny(qw/enteriter iter unstack goto/); # minimum protection against Acme::BadExample
- {
- no strict;
- $v = $comp->reval($eval);
- }
- if ($@){ # still in the child process, out of Safe::reval
- my $err = $@;
- # warn ">>>>>>>err[$err]<<<<<<<<";
- if (ref $err) {
- if ($err->{line} =~ /[\$*]([\w\:\']*)\bVERSION\b.*?\=(.*)/) {
- # $v = $comp->reval($2);
- local *qv = \&version::qv; # equiv. of $comp->share_from('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;
- }
+ my @handlers;
+ for my $phase (qw( configure build test install )) {
+ push @handlers, "$phase-args=s" => \($self->{build_args}{$phase});
}
- unlink $tmpfile if -e $tmpfile;
- return $self->_normalize_version($v);
+ @handlers;
}
- # from PAUSE::pmfile;
- sub _packages_per_pmfile {
+ sub parse_options {
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 @ARGV = @{$self->{argv}};
+ push @ARGV, grep length, split /\s+/, $self->env('OPT');
+ push @ARGV, @_;
- local $/ = "\n";
- my $inpod = 0;
+ 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' => sub {
+ $self->diag("--perl is deprecated since it's known to be fragile in figuring out dependencies. Run `$_[1] -S cpanm` instead.\n", 1);
+ $self->{perl} = $_[1];
+ },
+ '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},
+ '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,
+ );
- 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";
+ 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;
+ }
- $pline =~ s/\#.*//;
- next if $pline =~ /^\s*$/;
- if ($pline =~ /\b__(?:END|DATA)__\b/
- and $pmfile !~ /\.PL$/ # PL files may well have code after __DATA__
- ){
- last PLINE;
- }
+ $self->{argv} = \@ARGV;
+ }
- my $pkg;
- my $strict_version;
+ sub check_upgrade {
+ my $self = shift;
+ my $install_base = $ENV{PERL_LOCAL_LIB_ROOT} ? $self->local_lib_target($ENV{PERL_LOCAL_LIB_ROOT}) : $Config{installsitebin};
+ if ($0 eq '-') {
+ # run from curl, that's fine
+ return;
+ } elsif ($0 !~ /^$install_base/) {
+ if ($0 =~ m!perlbrew/bin!) {
+ die <<DIE;
+ It appears your cpanm executable was installed via `perlbrew install-cpanm`.
+ cpanm --self-upgrade won't upgrade the version of cpanm you're running.
- if (
- $pline =~ m{
- # (.*) # takes too much time if $pline is long
- \bpackage\s+
- ([\w\:\']+)
- \s*
- (?: $ | [\}\;] | \s+($version::STRICT) )
- }x) {
- $pkg = $1;
- $strict_version = $2;
- if ($pkg eq "DB"){
- # XXX if pumpkin and perl make him comaintainer! I
- # think I always made the pumpkins comaint on DB
- # without further ado (?)
- next PLINE;
- }
- }
+ Run the following command to get it upgraded.
- if ($pkg) {
- # Found something
+ perlbrew install-cpanm
- # from package
- $pkg =~ s/\'/::/;
- next PLINE unless $pkg =~ /^[A-Za-z]/;
- next PLINE unless $pkg =~ /\w$/;
- next PLINE if $pkg eq "main";
- # Perl::Critic::Policy::TestingAndDebugging::ProhibitShebangWarningsArg
- # database for modid in mods, package in packages, package in perms
- # alter table mods modify modid varchar(128) binary NOT NULL default '';
- # alter table packages modify package varchar(128) binary NOT NULL default '';
- next PLINE if length($pkg) > 128;
- #restriction
- $ppp->{$pkg}{parsed}++;
- $ppp->{$pkg}{infile} = $pmfile;
- if ($self->_simile($pmfile,$pkg)) {
- $ppp->{$pkg}{simile} = $pmfile;
- if ($self->_version_from_meta_ok) {
- my $provides = $self->{META_CONTENT}{provides};
- if (exists $provides->{$pkg}) {
- if (exists $provides->{$pkg}{version}) {
- my $v = $provides->{$pkg}{version};
- if ($v =~ /[_\s]/ && !$ALLOW_DEV_VERSION){ # ignore developer releases and "You suck!"
- next PLINE;
- } else {
- $ppp->{$pkg}{version} = $self->_normalize_version($v);
- }
- } else {
- $ppp->{$pkg}{version} = "undef";
- }
- }
- } else {
- if (defined $strict_version){
- $ppp->{$pkg}{version} = $strict_version ;
- } else {
- $ppp->{$pkg}{version} = defined $version ? $version : "";
- }
- no warnings;
- if ($version eq 'undef') {
- $ppp->{$pkg}{version} = $version unless defined $ppp->{$pkg}{version};
- } else {
- $ppp->{$pkg}{version} =
- $version
- if $version
- > $ppp->{$pkg}{version} ||
- $version
- gt $ppp->{$pkg}{version};
- }
- }
- } else { # not simile
- #### it comes later, it would be nonsense
- #### to set to "undef". MM_Unix gives us
- #### the best we can reasonably consider
- $ppp->{$pkg}{version} =
- $version
- unless defined $ppp->{$pkg}{version} &&
- length($ppp->{$pkg}{version});
- }
- $ppp->{$pkg}{filemtime} = $filemtime;
+ DIE
} else {
- # $self->_verbose(2,"no pkg found");
+ die <<DIE;
+ You are running cpanm from the path where your current perl won't install executables to.
+ Because of that, cpanm --self-upgrade won't upgrade the version of cpanm you're running.
+
+ cpanm path : $0
+ Install path : $Config{installsitebin}
+
+ It means you either installed cpanm globally with system perl, or use distro packages such
+ as rpm or apt-get, and you have to use them again to upgrade cpanm.
+ DIE
}
}
+ }
- $fh->close;
- $ppp;
+ 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}});
+ }
}
- # from PAUSE::pmfile;
- {
- no strict;
- sub _parse_version_safely {
- my($parsefile) = @_;
- my $result;
- local *FH;
- local $/ = "\n";
- open(FH,$parsefile) or die "Could not open '$parsefile': $!";
- my $inpod = 0;
- while (<FH>) {
- $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
- next if $inpod || /^\s*#/;
- # last if /\b__(?:END|DATA)__\b/; # fails on quoted __END__ but this is rare
- chop;
- # next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/;
- next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
- my $current_parsed_line = $_;
- my $eval = qq{
- package #
- ExtUtils::MakeMaker::_version;
+ sub setup_verify {
+ my $self = shift;
- local $1$2;
- \$$2=undef; do {
- $_
- }; \$$2
- };
- local $^W = 0;
- local $SIG{__WARN__} = sub {};
- $result = eval($eval);
- # warn "current_parsed_line[$current_parsed_line]\$\@[$@]";
- if ($@ or !defined $result){
- die +{
- eval => $eval,
- line => $current_parsed_line,
- file => $parsefile,
- err => $@,
- };
- }
- last;
- } #;
- close FH;
+ my $has_modules = eval { require Module::Signature; require Digest::SHA; 1 };
+ $self->{cpansign} = $self->which('cpansign');
- $result = "undef" unless defined $result;
- return $result;
+ unless ($has_modules && $self->{cpansign}) {
+ warn "WARNING: Module::Signature and Digest::SHA is required for distribution verifications.\n";
+ $self->{verify} = 0;
}
}
- # from PAUSE::pmfile;
- sub _filter_ppps {
- my($self,@ppps) = @_;
- my @res;
+ sub parse_module_args {
+ my($self, $module) = @_;
- # very similar code is in PAUSE::dist::filter_pms
- MANI: for my $ppp ( @ppps ) {
- if ($self->{META_CONTENT}){
- my $no_index = $self->{META_CONTENT}{no_index}
- || $self->{META_CONTENT}{private}; # backward compat
- if (ref($no_index) eq 'HASH') {
- my %map = (
- package => qr{\z},
- namespace => qr{::},
- );
- for my $k (qw(package namespace)) {
- next unless my $v = $no_index->{$k};
- my $rest = $map{$k};
- if (ref $v eq "ARRAY") {
- for my $ve (@$v) {
- $ve =~ s|::$||;
- if ($ppp =~ /^$ve$rest/){
- $self->_verbose(1,"Skipping ppp[$ppp] due to ve[$ve]");
- next MANI;
- } else {
- $self->_verbose(1,"NOT skipping ppp[$ppp] due to ve[$ve]");
- }
- }
- } else {
- $v =~ s|::$||;
- if ($ppp =~ /^$v$rest/){
- $self->_verbose(1,"Skipping ppp[$ppp] due to v[$v]");
- next MANI;
- } else {
- $self->_verbose(1,"NOT skipping ppp[$ppp] due to v[$v]");
- }
- }
- }
- } else {
- $self->_verbose(1,"No keyword 'no_index' or 'private' in META_CONTENT");
- }
- } else {
- # $self->_verbose(1,"no META_CONTENT"); # too noisy
- }
- push @res, $ppp;
- }
- $self->_verbose(1,"Result of filter_ppps: res[@res]");
- @res;
- }
-
- # from PAUSE::pmfile;
- sub _simile {
- my($self,$file,$package) = @_;
- # MakeMaker gives them the chance to have the file Simple.pm in
- # this directory but have the package HTML::Simple in it.
- # Afaik, they wouldn't be able to do so with deeper nested packages
- $file =~ s|.*/||;
- $file =~ s|\.pm(?:\.PL)?||;
- my $ret = $package =~ m/\b\Q$file\E$/;
- $ret ||= 0;
- unless ($ret) {
- # Apache::mod_perl_guide stuffs it into Version.pm
- $ret = 1 if lc $file eq 'version';
- }
- $self->_verbose(1,"Result of simile(): file[$file] package[$package] ret[$ret]\n");
- $ret;
- }
-
- # from PAUSE::pmfile
- sub _normalize_version {
- my($self,$v) = @_;
- $v = "undef" unless defined $v;
- my $dv = Dumpvalue->new;
- my $sdv = $dv->stringify($v,1); # second argument prevents ticks
- $self->_verbose(1,"Result of normalize_version: sdv[$sdv]\n");
+ # Plack@1.2 -> Plack~"==1.2"
+ # BUT don't expand @ in git URLs
+ $module =~ s/^([A-Za-z0-9_:]+)@([v\d\._]+)$/$1~== $2/;
- return $v if $v eq "undef";
- return $v if $v =~ /^\{.*\}$/; # JSON object
- $v =~ s/^\s+//;
- $v =~ s/\s+\z//;
- if ($v =~ /_/) {
- # XXX should pass something like EDEVELOPERRELEASE up e.g.
- # SIXTEASE/XML-Entities-0.0306.tar.gz had nothing but one
- # such modules and the mesage was not helpful that "nothing
- # was found".
- return $v ;
- }
- # may warn "Integer overflow"
- my $vv = eval { no warnings; version->new($v)->numify };
- if ($@) {
- # warn "$v: $@";
- return "undef";
- }
- if ($vv eq $v) {
- # the boring 3.14
+ # Plack~1.20, DBI~"> 1.0, <= 2.0"
+ if ($module =~ /\~[v\d\._,\!<>= ]+$/) {
+ return split /\~/, $module, 2;
} else {
- my $forced = $self->_force_numeric($v);
- if ($forced eq $vv) {
- } elsif ($forced =~ /^v(.+)/) {
- # rare case where a v1.0.23 slipped in (JANL/w3mir-1.0.10.tar.gz)
- $vv = version->new($1)->numify;
- } else {
- # warn "Unequal forced[$forced] and vv[$vv]";
- if ($forced == $vv) {
- # the trailing zeroes would cause unnecessary havoc
- $vv = $forced;
- }
- }
+ return $module, undef;
}
- return $vv;
}
- # from PAUSE::pmfile;
- sub _force_numeric {
- my($self,$v) = @_;
- $v = App::cpanminus::CPANVersion->readable($v);
+ sub doit {
+ my $self = shift;
- if (
- $v =~
- /^(\+?)(\d*)(\.(\d*))?/ &&
- # "$2$4" ne ''
- (
- defined $2 && length $2
- ||
- defined $4 && length $4
- )
- ) {
- my $two = defined $2 ? $2 : "";
- my $three = defined $3 ? $3 : "";
- $v = "$two$three";
+ my $code;
+ eval {
+ $code = ($self->_doit == 0);
+ }; if (my $e = $@) {
+ warn $e;
+ $code = 1;
}
- # no else branch! We simply say, everything else is a string.
- $v;
+
+ return $code;
}
- # from PAUSE::dist
- sub _version_from_meta_ok {
- my($self) = @_;
- return $self->{VERSION_FROM_META_OK} if exists $self->{VERSION_FROM_META_OK};
- my $c = $self->{META_CONTENT};
+ sub _doit {
+ my $self = shift;
- # If there's no provides hash, we can't get our module versions from the
- # provides hash! -- rjbs, 2012-03-31
- return($self->{VERSION_FROM_META_OK} = 0) unless $c->{provides};
+ $self->setup_home;
+ $self->init_tools;
+ $self->setup_verify if $self->{verify};
- # Some versions of Module::Build geneated an empty provides hash. If we're
- # *not* looking at a Module::Build-generated metafile, then it's okay.
- my ($mb_v) = (defined $c->{generated_by} ? $c->{generated_by} : '') =~ /Module::Build version ([\d\.]+)/;
- return($self->{VERSION_FROM_META_OK} = 1) unless $mb_v;
+ if (my $action = $self->{action}) {
+ $self->$action() and return 1;
+ }
- # ??? I don't know why this is here.
- return($self->{VERSION_FROM_META_OK} = 1) if $mb_v eq '0.250.0';
+ return $self->show_help(1)
+ unless @{$self->{argv}} or $self->{load_from_stdin};
- if ($mb_v >= 0.19 && $mb_v < 0.26 && ! keys %{$c->{provides}}) {
- # RSAVAGE/Javascript-SHA1-1.01.tgz had an empty provides hash. Ron
- # did not find the reason why this happened, but let's not go
- # overboard, 0.26 seems a good threshold from the statistics: there
- # are not many empty provides hashes from 0.26 up.
- return($self->{VERSION_FROM_META_OK} = 0);
- }
+ $self->configure_mirrors;
- # We're not in the suspect range of M::B versions. It's good to go.
- return($self->{VERSION_FROM_META_OK} = 1);
- }
+ my $cwd = Cwd::cwd;
- sub _verbose {
- my($self,$level,@what) = @_;
- warn @what if $level <= $VERBOSE;
- }
+ 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;
+ }
- 1;
+ ($module, my $version) = $self->parse_module_args($module);
- __END__
-APP_CPANMINUS_PARSEPM
-
-$fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS_SCRIPT';
- package App::cpanminus::script;
- use strict;
- use Config;
- use Cwd ();
- use App::cpanminus;
- use File::Basename ();
- use File::Find ();
- use File::Path ();
- use File::Spec ();
- use File::Copy ();
- use File::Temp ();
- use Getopt::Long ();
- use Parse::CPAN::Meta;
- use Symbol ();
- use String::ShellQuote ();
- use version ();
+ $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;
+ }
+ }
- use aliased 'App::cpanminus::Dependency';
+ if ($self->{base} && $self->{auto_cleanup}) {
+ $self->cleanup_workdirs;
+ }
- use constant WIN32 => $^O eq 'MSWin32';
- use constant SUNOS => $^O eq 'solaris';
- use constant CAN_SYMLINK => eval { symlink("", ""); 1 };
+ if ($self->{installed_dists}) {
+ my $dists = $self->{installed_dists} > 1 ? "distributions" : "distribution";
+ $self->diag("$self->{installed_dists} $dists installed\n", 1);
+ }
- our $VERSION = $App::cpanminus::VERSION;
+ if ($self->{scandeps}) {
+ $self->dump_scandeps();
+ }
+ # Workaround for older File::Temp's
+ # where creating a tempdir with an implicit $PWD
+ # causes tempdir non-cleanup if $PWD changes
+ # as paths are stored internally without being resolved
+ # absolutely.
+ # https://rt.cpan.org/Public/Bug/Display.html?id=44924
+ $self->chdir($cwd);
- if ($INC{"App/FatPacker/Trace.pm"}) {
- require JSON::PP;
- require CPAN::Meta::YAML;
- require CPAN::Meta::Prereqs;
- require version::vpp;
- require File::pushd;
+ return !@fail;
}
- my $quote = WIN32 ? q/"/ : q/'/;
-
- sub agent {
+ sub setup_home {
my $self = shift;
- my $agent = "cpanminus/$VERSION";
- $agent .= " perl/$]" if $self->{report_perl_version};
- $agent;
- }
-
- sub determine_home {
- my $class = shift;
- my $homedir = $ENV{HOME}
- || eval { require File::HomeDir; File::HomeDir->my_home }
- || join('', @ENV{qw(HOMEDRIVE HOMEPATH)}); # Win32
+ $self->{home} = $self->env('HOME') if $self->env('HOME');
- if (WIN32) {
- require Win32; # no fatpack
- $homedir = Win32::GetShortPathName($homedir);
+ unless (_writable($self->{home})) {
+ die "Can't write to cpanm home '$self->{home}': You should fix it with chown/chmod first.\n";
}
- return "$homedir/.cpanm";
- }
-
- sub new {
- my $class = shift;
+ $self->{base} = "$self->{home}/work/" . time . ".$$";
+ File::Path::mkpath([ $self->{base} ], 0, 0777);
- bless {
- home => $class->determine_home,
- cmd => 'install',
- seen => {},
- notest => undef,
- test_only => undef,
- installdeps => undef,
- force => undef,
- sudo => undef,
- make => undef,
- verbose => undef,
- quiet => undef,
- interactive => undef,
- log => undef,
- mirrors => [],
- mirror_only => undef,
- mirror_index => undef,
- cpanmetadb => "http://cpanmetadb.plackperl.org/v1.0/",
- perl => $^X,
- argv => [],
- local_lib => undef,
- self_contained => undef,
- prompt_timeout => 0,
- prompt => undef,
- configure_timeout => 60,
- build_timeout => 3600,
- test_timeout => 1800,
- try_lwp => 1,
- try_wget => 1,
- try_curl => 1,
- uninstall_shadows => ($] < 5.012),
- skip_installed => 1,
- skip_satisfied => 0,
- auto_cleanup => 7, # days
- pod2man => 1,
- installed_dists => 0,
- install_types => ['requires'],
- with_develop => 0,
- showdeps => 0,
- scandeps => 0,
- scandeps_tree => [],
- format => 'tree',
- save_dists => undef,
- skip_configure => 0,
- verify => 0,
- report_perl_version => 1,
- build_args => {},
- features => {},
- pure_perl => 0,
- cpanfile_path => 'cpanfile',
- @_,
- }, $class;
- }
+ # native path because we use shell redirect
+ $self->{log} = File::Spec->catfile($self->{base}, "build.log");
+ my $final_log = "$self->{home}/build.log";
- sub env {
- my($self, $key) = @_;
- $ENV{"PERL_CPANM_" . $key};
- }
+ { open my $out, ">$self->{log}" or die "$self->{log}: $!" }
- sub install_type_handlers {
- my $self = shift;
+ if (CAN_SYMLINK) {
+ my $build_link = "$self->{home}/latest-build";
+ unlink $build_link;
+ symlink $self->{base}, $build_link;
- 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}} ];
- };
+ 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);
+ }
}
- @handlers;
+ $self->chat("cpanm (App::cpanminus) $VERSION on perl $] built for $Config{archname}\n" .
+ "Work directory is $self->{base}\n");
}
- 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 package_index_for {
+ my ($self, $mirror) = @_;
+ return $self->source_for($mirror) . "/02packages.details.txt";
}
- 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,
- );
+ 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];
- 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;
+ 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;
+ }
- $self->{argv} = \@ARGV;
+ sub search_mirror_index {
+ my ($self, $mirror, $module, $version) = @_;
+ $self->search_mirror_index_file($self->package_index_for($mirror), $module, $version);
}
- sub check_upgrade {
- my $self = shift;
- my $install_base = $ENV{PERL_LOCAL_LIB_ROOT} ? $self->local_lib_target($ENV{PERL_LOCAL_LIB_ROOT}) : $Config{installsitebin};
- if ($0 eq '-') {
- # run from curl, that's fine
- return;
- } elsif ($0 !~ /^$install_base/) {
- if ($0 =~ m!perlbrew/bin!) {
- die <<DIE;
- It appears your cpanm executable was installed via `perlbrew install-cpanm`.
- cpanm --self-upgrade won't upgrade the version of cpanm you're running.
+ sub search_mirror_index_file {
+ my($self, $file, $module, $version) = @_;
- Run the following command to get it upgraded.
+ 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;
+ }
+ }
- perlbrew install-cpanm
+ return $found unless $self->{cascade_search};
- DIE
+ if ($found) {
+ if ($self->satisfy_version($module, $found->{module_version}, $version)) {
+ return $found;
} else {
- die <<DIE;
- You are running cpanm from the path where your current perl won't install executables to.
- Because of that, cpanm --self-upgrade won't upgrade the version of cpanm you're running.
-
- cpanm path : $0
- Install path : $Config{installsitebin}
-
- It means you either installed cpanm globally with system perl, or use distro packages such
- as rpm or apt-get, and you have to use them again to upgrade cpanm.
- DIE
+ $self->chat("Found $module $found->{module_version} which doesn't satisfy $version.\n");
}
}
- }
-
- sub check_libs {
- my $self = shift;
- return if $self->{_checked}++;
-
- $self->bootstrap_local_lib;
- if (@{$self->{bootstrap_deps} || []}) {
- local $self->{notest} = 1; # test failure in bootstrap should be tolerated
- local $self->{scandeps} = 0;
- $self->install_deps(Cwd::cwd, 0, @{$self->{bootstrap_deps}});
- }
- }
-
- sub setup_verify {
- my $self = shift;
-
- my $has_modules = eval { require Module::Signature; require Digest::SHA; 1 };
- $self->{cpansign} = $self->which('cpansign');
-
- unless ($has_modules && $self->{cpansign}) {
- warn "WARNING: Module::Signature and Digest::SHA is required for distribution verifications.\n";
- $self->{verify} = 0;
- }
- }
-
- sub parse_module_args {
- my($self, $module) = @_;
-
- # Plack@1.2 -> Plack~"==1.2"
- # BUT don't expand @ in git URLs
- $module =~ s/^([A-Za-z0-9_:]+)@([v\d\._]+)$/$1~== $2/;
-
- # Plack~1.20, DBI~"> 1.0, <= 2.0"
- if ($module =~ /\~[v\d\._,\!<>= ]+$/) {
- return split /\~/, $module, 2;
- } else {
- return $module, undef;
- }
- }
-
- sub _exit {
- my($self, $code) = @_;
- die App::cpanminus::CommandExit->new($code);
- }
-
- sub doit {
- my $self = shift;
-
- my $code;
- eval {
- $code = ($self->_doit == 0);
- }; if (my $e = $@) {
- if (ref $e eq 'App::cpanminus::CommandExit') {
- $code = $e->code;
- } else {
- warn $e;
- $code = 1;
- }
- }
-
- return $code;
- }
-
- sub _doit {
- my $self = shift;
-
- $self->setup_home;
- $self->init_tools;
- $self->setup_verify if $self->{verify};
-
- if (my $action = $self->{action}) {
- $self->$action() and return 1;
- }
-
- $self->show_help(1)
- unless @{$self->{argv}} or $self->{load_from_stdin};
-
- $self->configure_mirrors;
-
- my $cwd = Cwd::cwd;
-
- my @fail;
- for my $module (@{$self->{argv}}) {
- if ($module =~ s/\.pm$//i) {
- my ($volume, $dirs, $file) = File::Spec->splitpath($module);
- $module = join '::', grep { $_ } File::Spec->splitdir($dirs), $file;
- }
-
- ($module, my $version) = $self->parse_module_args($module);
-
- $self->chdir($cwd);
- if ($self->{cmd} eq 'uninstall') {
- $self->uninstall_module($module)
- or push @fail, $module;
- } else {
- $self->install_module($module, 0, $version)
- or push @fail, $module;
- }
- }
-
- if ($self->{base} && $self->{auto_cleanup}) {
- $self->cleanup_workdirs;
- }
-
- if ($self->{installed_dists}) {
- my $dists = $self->{installed_dists} > 1 ? "distributions" : "distribution";
- $self->diag("$self->{installed_dists} $dists installed\n", 1);
- }
-
- if ($self->{scandeps}) {
- $self->dump_scandeps();
- }
- # Workaround for older File::Temp's
- # where creating a tempdir with an implicit $PWD
- # causes tempdir non-cleanup if $PWD changes
- # as paths are stored internally without being resolved
- # absolutely.
- # https://rt.cpan.org/Public/Bug/Display.html?id=44924
- $self->chdir($cwd);
-
- return !@fail;
- }
-
- sub setup_home {
- my $self = shift;
-
- $self->{home} = $self->env('HOME') if $self->env('HOME');
-
- unless (_writable($self->{home})) {
- die "Can't write to cpanm home '$self->{home}': You should fix it with chown/chmod first.\n";
- }
-
- $self->{base} = "$self->{home}/work/" . time . ".$$";
- File::Path::mkpath([ $self->{base} ], 0, 0777);
-
- # native path because we use shell redirect
- $self->{log} = File::Spec->catfile($self->{base}, "build.log");
- my $final_log = "$self->{home}/build.log";
-
- { open my $out, ">$self->{log}" or die "$self->{log}: $!" }
-
- if (CAN_SYMLINK) {
- my $build_link = "$self->{home}/latest-build";
- unlink $build_link;
- symlink $self->{base}, $build_link;
-
- unlink $final_log;
- symlink $self->{log}, $final_log;
- } else {
- my $log = $self->{log}; my $home = $self->{home};
- $self->{at_exit} = sub {
- my $self = shift;
- my $temp_log = "$home/build.log." . time . ".$$";
- File::Copy::copy($log, $temp_log)
- && unlink($final_log);
- rename($temp_log, $final_log);
- }
- }
-
- $self->chat("cpanm (App::cpanminus) $VERSION on perl $] built for $Config{archname}\n" .
- "Work directory is $self->{base}\n");
- }
-
- sub package_index_for {
- my ($self, $mirror) = @_;
- return $self->source_for($mirror) . "/02packages.details.txt";
- }
-
- sub generate_mirror_index {
- my ($self, $mirror) = @_;
- my $file = $self->package_index_for($mirror);
- my $gz_file = $file . '.gz';
- my $index_mtime = (stat $gz_file)[9];
-
- unless (-e $file && (stat $file)[9] >= $index_mtime) {
- $self->chat("Uncompressing index file...\n");
- if (eval {require Compress::Zlib}) {
- my $gz = Compress::Zlib::gzopen($gz_file, "rb")
- or do { $self->diag_fail("$Compress::Zlib::gzerrno opening compressed index"); return};
- open my $fh, '>', $file
- or do { $self->diag_fail("$! opening uncompressed index for write"); return };
- my $buffer;
- while (my $status = $gz->gzread($buffer)) {
- if ($status < 0) {
- $self->diag_fail($gz->gzerror . " reading compressed index");
- return;
- }
- print $fh $buffer;
- }
- } else {
- if (system("gunzip -c $gz_file > $file")) {
- $self->diag_fail("Cannot uncompress -- please install gunzip or Compress::Zlib");
- return;
- }
- }
- utime $index_mtime, $index_mtime, $file;
- }
- return 1;
- }
-
- sub search_mirror_index {
- my ($self, $mirror, $module, $version) = @_;
- $self->search_mirror_index_file($self->package_index_for($mirror), $module, $version);
- }
-
- sub search_mirror_index_file {
- my($self, $file, $module, $version) = @_;
-
- open my $fh, '<', $file or return;
- my $found;
- while (<$fh>) {
- if (m!^\Q$module\E\s+([\w\.]+)\s+(\S*)!m) {
- $found = $self->cpan_module($module, $2, $1);
- last;
- }
- }
-
- return $found unless $self->{cascade_search};
-
- if ($found) {
- if ($self->satisfy_version($module, $found->{module_version}, $version)) {
- return $found;
- } else {
- $self->chat("Found $module $found->{module_version} which doesn't satisfy $version.\n");
- }
- }
-
- return;
+
+ return;
}
sub with_version_range {
@@ -1557,7 +1004,7 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
};
} elsif ($req !~ /\s/) {
return {
- range => { 'module.version_numified' => { 'gte' => $self->numify_ver($req) } },
+ range => { 'module.version_numified' => { 'gte' => $self->numify_ver_metacpan($req) } },
};
} else {
my %ops = qw(< lt <= lte > gt >= gte);
@@ -1565,9 +1012,9 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
my @requirements = split /,\s*/, $req;
for my $r (@requirements) {
if ($r =~ s/^([<>]=?)\s*//) {
- $range{$ops{$1}} = $self->numify_ver($r);
+ $range{$ops{$1}} = $self->numify_ver_metacpan($r);
} elsif ($r =~ s/\!=\s*//) {
- push @exclusion, $self->numify_ver($r);
+ push @exclusion, $self->numify_ver_metacpan($r);
}
}
@@ -1577,7 +1024,7 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
if (@exclusion) {
push @filters, {
- not => { or => [ map { +{ term => { 'module.version_numified' => $self->numify_ver($_) } } } @exclusion ] },
+ not => { or => [ map { +{ term => { 'module.version_numified' => $self->numify_ver_metacpan($_) } } } @exclusion ] },
};
}
@@ -1585,11 +1032,19 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
}
}
- sub numify_ver {
+ # Apparently MetaCPAN numifies devel releases by stripping _ first
+ sub numify_ver_metacpan {
my($self, $ver) = @_;
+ $ver =~ s/_//g;
version->new($ver)->numify;
}
+ # version->new("1.00_00")->numify => "1.00_00" :/
+ sub numify_ver {
+ my($self, $ver) = @_;
+ eval version->new($ver)->numify;
+ }
+
sub maturity_filter {
my($self, $module, $version) = @_;
@@ -1664,16 +1119,17 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
my $module_uri = "$metacpan_uri/file/_search?source=";
$module_uri .= $self->encode_json({
query => $query,
- fields => [ 'date', 'release', 'module', 'status' ],
+ fields => [ 'date', 'release', 'author', 'module', 'status' ],
});
- my($release, $module_version);
+ my($release, $author, $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};
+ $author = $match->{author};
my $module_matched = (grep { $_->{name} eq $module } @{$match->{module}})[0];
$module_version = $module_matched->{version};
}
@@ -1685,9 +1141,10 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
my $dist_uri = "$metacpan_uri/release/_search?source=";
$dist_uri .= $self->encode_json({
- filter => {
- term => { 'release.name' => $release },
- },
+ filter => { and => [
+ { term => { 'release.name' => $release } },
+ { term => { 'release.author' => $author } },
+ ]},
fields => [ 'download_url', 'stat', 'status' ],
});
@@ -1718,7 +1175,7 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
my $found;
my $range = ($self->with_version_range($version) || $self->{dev_release});
- if ($range or $self->{metacpan}) {
+ if ($range) {
$found = $self->search_metacpan($module, $version) and return $found;
$found = $self->search_cpanmetadb($module, $version) and return $found;
} else {
@@ -1730,11 +1187,13 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
sub search_cpanmetadb {
my($self, $module, $version) = @_;
+ require CPAN::Meta::YAML;
+
$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);
+ my $meta = eval { CPAN::Meta::YAML::Load($yaml) };
if ($meta && $meta->{distfile}) {
return $self->cpan_module($module, $meta->{distfile}, $meta->{version});
}
@@ -1843,7 +1302,7 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
Try `cpanm --help` or `man cpanm` for more options.
USAGE
- $self->_exit(1);
+ return;
}
print <<HELP;
@@ -2027,8 +1486,8 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
sub bootstrap_local_lib_deps {
my $self = shift;
push @{$self->{bootstrap_deps}},
- Dependency->new('ExtUtils::MakeMaker' => 6.31),
- Dependency->new('ExtUtils::Install' => 1.46);
+ App::cpanminus::Dependency->new('ExtUtils::MakeMaker' => 6.58),
+ App::cpanminus::Dependency->new('ExtUtils::Install' => 1.46);
}
sub prompt_bool {
@@ -2624,7 +2083,7 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
while ($try++ < 3) {
$file = $fetch->();
last if $cancelled or $file;
- $self->diag_fail("Download $uri failed. Retrying ... ");
+ $self->mask_output( diag_fail => "Download $uri failed. Retrying ... ");
}
if ($cancelled) {
@@ -2633,7 +2092,7 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
}
unless ($file) {
- $self->diag_fail("Failed to download $uri");
+ $self->mask_output( diag_fail => "Failed to download $uri");
next;
}
@@ -2698,6 +2157,7 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
unless ($dist->{cpanid}) {
$self->chat("Archive '$file' does not seem to be from PAUSE. Skip verification.\n");
+ return 1;
}
(my $mirror = $uri) =~ s!/authors/id.*$!!;
@@ -2934,12 +2394,23 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
return $Module::CoreList::version{$]+0}{$module};
}
+ sub search_inc {
+ my $self = shift;
+ $self->{search_inc} ||= do {
+ # strip lib/ and fatlib/ from search path when booted from dev
+ if (defined $::Bin) {
+ [grep !/^\Q$::Bin\E\/..\/(?:fat)?lib$/, @INC]
+ } else {
+ [@INC]
+ }
+ };
+ }
sub check_module {
my($self, $mod, $want_ver) = @_;
require Module::Metadata;
- my $meta = Module::Metadata->new_from_module($mod, inc => $self->{search_inc})
+ my $meta = Module::Metadata->new_from_module($mod, inc => $self->search_inc)
or return 0, undef;
my $version = $meta->version;
@@ -3120,21 +2591,16 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
$dist->{meta} = $dist->{cpanmeta} ? $dist->{cpanmeta}->as_struct : {};
my @config_deps;
-
if ($dist->{cpanmeta}) {
- push @config_deps, Dependency->from_prereqs(
+ push @config_deps, App::cpanminus::Dependency->from_prereqs(
$dist->{cpanmeta}->effective_prereqs, ['configure'], $self->{install_types},
);
- } else {
- push @config_deps, Dependency->from_versions(
- $dist->{meta}{configure_requires} || {}, 'configure',
- );
}
# workaround for bad M::B based dists with no configure_requires
# https://github.com/miyagawa/cpanminus/issues/273
- if (-e 'Build.PL' && !$self->should_use_mm($dist->{dist})) {
- push @config_deps, Dependency->from_versions(
+ if (-e 'Build.PL' && !$self->should_use_mm($dist->{dist}) && !@config_deps) {
+ push @config_deps, App::cpanminus::Dependency->from_versions(
{ 'Module::Build' => '0.36' }, 'configure',
);
}
@@ -3265,7 +2731,7 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
my @perl;
for my $requires (grep defined, @requires) {
if (exists $requires->{perl}) {
- push @perl, Dependency->new(perl => $requires->{perl});
+ push @perl, App::cpanminus::Dependency->new(perl => $requires->{perl});
}
}
@@ -3405,20 +2871,21 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
my $try = sub {
my $file = shift;
+ return 0 if $file =~ m!^(?:x?t|inc|local|perl5|fatlib|_build)/!;
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;
+ require Parse::PMFile;
my @files = grep { /\.pm(?:\.PL)?$/ && $try->($_) } $self->list_files;
my $provides = {};
for my $file (@files) {
- my $parser = App::cpanminus::ParsePM->new($meta);
+ my $parser = Parse::PMFile->new($meta);
my $packages = $parser->parse($file);
while (my($package, $meta) = each %$packages) {
@@ -3558,28 +3025,19 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
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});
+ return App::cpanminus::Dependency->from_prereqs($prereqs, $dist->{want_phases}, $self->{install_types});
}
- my $meta = $dist->{meta};
+ require CPAN::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');
+ my($meta_file) = grep -f, qw(MYMETA.json MYMETA.yml);
+ if ($meta_file) {
+ $self->chat("Checking dependencies from $meta_file ...\n");
+ my $mymeta = eval { CPAN::Meta->load_file($meta_file, { lazy_validation => 1 }) };
if ($mymeta) {
- $meta->{$_} = $mymeta->{$_} for qw(name version);
+ $dist->{meta}{name} = $mymeta->name;
+ $dist->{meta}{version} = $mymeta->version;
return $self->extract_prereqs($mymeta, $dist);
}
}
@@ -3587,7 +3045,11 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
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);
+ my $meta = CPAN::Meta->new(
+ { name => $dist->{meta}{name}, version => $dist->{meta}{version}, %$prereqs },
+ { lazy_validation => 1 },
+ );
+ @deps = $self->extract_prereqs($meta, $dist);
} elsif (-e 'Makefile') {
$self->chat("Finding PREREQ from Makefile ...\n");
open my $mf, "Makefile";
@@ -3601,7 +3063,7 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
}
my $list = join ", ", map { "'$_->[0]' => $_->[1]" } @all;
my $prereq = $self->safe_eval("no strict; +{ $list }");
- push @deps, Dependency->from_versions($prereq) if $prereq;
+ push @deps, App::cpanminus::Dependency->from_versions($prereq) if $prereq;
last;
}
}
@@ -3631,7 +3093,7 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
$in_contents = 0;
} elsif ($in_contents) {
/^(\S+)\s*(\S+)?/
- and push @deps, Dependency->new($1, $self->maybe_version($2));
+ and push @deps, App::cpanminus::Dependency->new($1, $self->maybe_version($2));
}
}
}
@@ -3645,13 +3107,10 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
}
sub extract_prereqs {
- my($self, $metadata, $dist) = @_;
+ my($self, $meta, $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});
+ return App::cpanminus::Dependency->from_prereqs($meta->effective_prereqs(\@features), $dist->{want_phases}, $self->{install_types});
}
sub cleanup_workdirs {
@@ -3671,7 +3130,7 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
if (@targets) {
if (@targets >= 64) {
- $self->diag("Expiring " . scalar(@targets) . " work directories. This might take long...\n");
+ $self->diag("Expiring " . scalar(@targets) . " work directories. This might take a while...\n");
} else {
$self->chat("Expiring " . scalar(@targets) . " work directories.\n");
}
@@ -3755,11 +3214,15 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
sub which {
my($self, $name) = @_;
- return $name if File::Spec->file_name_is_absolute($name) && -x $name;
+ if (File::Spec->file_name_is_absolute($name)) {
+ if (-x $name && !-d _) {
+ return $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 ((-x $fullpath || -x ($fullpath .= $exe_ext)) && !-d _) {
if ($fullpath =~ /\s/) {
$fullpath = $self->shell_quote($fullpath);
}
@@ -3918,7 +3381,7 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
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) };
+ my $maybe_bad_tar = sub { WIN32 || BAD_TAR || (($tar_ver = `$tar --version 2>/dev/null`) =~ /GNU.*1\.13/i) };
if ($tar && !$maybe_bad_tar->()) {
chomp $tar_ver;
@@ -4073,27 +3536,10 @@ $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
sub mask_uri_passwords {
my($self, @strings) = @_;
- s{ (https?://) ([^:/]+) : [^@/]+ @ }{$1$2:*password*@}gx for @strings;
+ s{ (https?://) ([^:/]+) : [^@/]+ @ }{$1$2:********@}gx for @strings;
return @strings;
}
- sub parse_meta {
- my($self, $file) = @_;
- return eval { Parse::CPAN::Meta->load_file($file) };
- }
-
- sub parse_meta_string {
- my($self, $yaml) = @_;
- return eval { Parse::CPAN::Meta->load_yaml_string($yaml) };
- }
-
- package App::cpanminus::CommandExit;
- sub new {
- bless { code => $_[1] }, $_[0];
- }
-
- sub code { $_[0]->{code} }
-
1;
APP_CPANMINUS_SCRIPT
@@ -4310,18 +3756,81 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
use strict;
use warnings;
package CPAN::Meta;
- our $VERSION = '2.132510'; # VERSION
-
+ # VERSION
+ $CPAN::Meta::VERSION = '2.142690';
+ #pod =head1 SYNOPSIS
+ #pod
+ #pod use v5.10;
+ #pod use strict;
+ #pod use warnings;
+ #pod use CPAN::Meta;
+ #pod use Module::Load;
+ #pod
+ #pod my $meta = CPAN::Meta->load_file('META.json');
+ #pod
+ #pod printf "testing requirements for %s version %s\n",
+ #pod $meta->name,
+ #pod $meta->version;
+ #pod
+ #pod my $prereqs = $meta->effective_prereqs;
+ #pod
+ #pod for my $phase ( qw/configure runtime build test/ ) {
+ #pod say "Requirements for $phase:";
+ #pod my $reqs = $prereqs->requirements_for($phase, "requires");
+ #pod for my $module ( sort $reqs->required_modules ) {
+ #pod my $status;
+ #pod if ( eval { load $module unless $module eq 'perl'; 1 } ) {
+ #pod my $version = $module eq 'perl' ? $] : $module->VERSION;
+ #pod $status = $reqs->accepts_module($module, $version)
+ #pod ? "$version ok" : "$version not ok";
+ #pod } else {
+ #pod $status = "missing"
+ #pod };
+ #pod say " $module ($status)";
+ #pod }
+ #pod }
+ #pod
+ #pod =head1 DESCRIPTION
+ #pod
+ #pod Software distributions released to the CPAN include a F<META.json> or, for
+ #pod older distributions, F<META.yml>, which describes the distribution, its
+ #pod contents, and the requirements for building and installing the distribution.
+ #pod The data structure stored in the F<META.json> file is described in
+ #pod L<CPAN::Meta::Spec>.
+ #pod
+ #pod CPAN::Meta provides a simple class to represent this distribution metadata (or
+ #pod I<distmeta>), along with some helpful methods for interrogating that data.
+ #pod
+ #pod The documentation below is only for the methods of the CPAN::Meta object. For
+ #pod information on the meaning of individual fields, consult the spec.
+ #pod
+ #pod =cut
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 ();
+ use Parse::CPAN::Meta 1.4414 ();
BEGIN { *_dclone = \&CPAN::Meta::Converter::_dclone }
+ #pod =head1 STRING DATA
+ #pod
+ #pod The following methods return a single value, which is the value for the
+ #pod corresponding entry in the distmeta structure. Values should be either undef
+ #pod or strings.
+ #pod
+ #pod =for :list
+ #pod * abstract
+ #pod * description
+ #pod * dynamic_config
+ #pod * generated_by
+ #pod * name
+ #pod * release_status
+ #pod * version
+ #pod
+ #pod =cut
BEGIN {
my @STRING_READERS = qw(
@@ -4340,6 +3849,20 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
}
}
+ #pod =head1 LIST DATA
+ #pod
+ #pod These methods return lists of string values, which might be represented in the
+ #pod distmeta structure as arrayrefs or scalars:
+ #pod
+ #pod =for :list
+ #pod * authors
+ #pod * keywords
+ #pod * licenses
+ #pod
+ #pod The C<authors> and C<licenses> methods may also be called as C<author> and
+ #pod C<license>, respectively, to match the field name in the distmeta structure.
+ #pod
+ #pod =cut
BEGIN {
my @LIST_READERS = qw(
@@ -4363,6 +3886,20 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
sub authors { $_[0]->author }
sub licenses { $_[0]->license }
+ #pod =head1 MAP DATA
+ #pod
+ #pod These readers return hashrefs of arbitrary unblessed data structures, each
+ #pod described more fully in the specification:
+ #pod
+ #pod =for :list
+ #pod * meta_spec
+ #pod * resources
+ #pod * provides
+ #pod * no_index
+ #pod * prereqs
+ #pod * optional_features
+ #pod
+ #pod =cut
BEGIN {
my @MAP_READERS = qw(
@@ -4386,6 +3923,16 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
}
}
+ #pod =head1 CUSTOM DATA
+ #pod
+ #pod A list of custom keys are available from the C<custom_keys> method and
+ #pod particular keys may be retrieved with the C<custom> method.
+ #pod
+ #pod say $meta->custom($_) for $meta->custom_keys;
+ #pod
+ #pod If a custom key refers to a data structure, a deep clone is returned.
+ #pod
+ #pod =cut
sub custom_keys {
return grep { /^x_/i } keys %{$_[0]};
@@ -4398,6 +3945,29 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
return $value;
}
+ #pod =method new
+ #pod
+ #pod my $meta = CPAN::Meta->new($distmeta_struct, \%options);
+ #pod
+ #pod Returns a valid CPAN::Meta object or dies if the supplied metadata hash
+ #pod reference fails to validate. Older-format metadata will be up-converted to
+ #pod version 2 if they validate against the original stated specification.
+ #pod
+ #pod It takes an optional hashref of options. Valid options include:
+ #pod
+ #pod =over
+ #pod
+ #pod =item *
+ #pod
+ #pod lazy_validation -- if true, new will attempt to convert the given metadata
+ #pod to version 2 before attempting to validate it. This means than any
+ #pod fixable errors will be handled by CPAN::Meta::Converter before validation.
+ #pod (Note that this might result in invalid optional data being silently
+ #pod dropped.) The default is false.
+ #pod
+ #pod =back
+ #pod
+ #pod =cut
sub _new {
my ($class, $struct, $options) = @_;
@@ -4438,6 +4008,15 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
return $self;
}
+ #pod =method create
+ #pod
+ #pod my $meta = CPAN::Meta->create($distmeta_struct, \%options);
+ #pod
+ #pod This is same as C<new()>, except that C<generated_by> and C<meta-spec> fields
+ #pod will be generated if not provided. This means the metadata structure is
+ #pod assumed to otherwise follow the latest L<CPAN::Meta::Spec>.
+ #pod
+ #pod =cut
sub create {
my ($class, $struct, $options) = @_;
@@ -4449,6 +4028,19 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
return $self;
}
+ #pod =method load_file
+ #pod
+ #pod my $meta = CPAN::Meta->load_file($distmeta_file, \%options);
+ #pod
+ #pod Given a pathname to a file containing metadata, this deserializes the file
+ #pod according to its file suffix and constructs a new C<CPAN::Meta> object, just
+ #pod like C<new()>. It will die if the deserialized version fails to validate
+ #pod against its stated specification version.
+ #pod
+ #pod It takes the same options as C<new()> but C<lazy_validation> defaults to
+ #pod true.
+ #pod
+ #pod =cut
sub load_file {
my ($class, $file, $options) = @_;
@@ -4466,6 +4058,14 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
return $self;
}
+ #pod =method load_yaml_string
+ #pod
+ #pod my $meta = CPAN::Meta->load_yaml_string($yaml, \%options);
+ #pod
+ #pod This method returns a new CPAN::Meta object using the first document in the
+ #pod given YAML string. In other respects it is identical to C<load_file()>.
+ #pod
+ #pod =cut
sub load_yaml_string {
my ($class, $yaml, $options) = @_;
@@ -4480,6 +4080,14 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
return $self;
}
+ #pod =method load_json_string
+ #pod
+ #pod my $meta = CPAN::Meta->load_json_string($json, \%options);
+ #pod
+ #pod This method returns a new CPAN::Meta object using the structure represented by
+ #pod the given JSON string. In other respects it is identical to C<load_file()>.
+ #pod
+ #pod =cut
sub load_json_string {
my ($class, $json, $options) = @_;
@@ -4494,6 +4102,50 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
return $self;
}
+ #pod =method load_string
+ #pod
+ #pod my $meta = CPAN::Meta->load_string($string, \%options);
+ #pod
+ #pod If you don't know if a string contains YAML or JSON, this method will use
+ #pod L<Parse::CPAN::Meta> to guess. In other respects it is identical to
+ #pod C<load_file()>.
+ #pod
+ #pod =cut
+
+ sub load_string {
+ my ($class, $string, $options) = @_;
+ $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
+
+ my $self;
+ eval {
+ my $struct = Parse::CPAN::Meta->load_string( $string );
+ $self = $class->_new($struct, $options);
+ };
+ croak($@) if $@;
+ return $self;
+ }
+
+ #pod =method save
+ #pod
+ #pod $meta->save($distmeta_file, \%options);
+ #pod
+ #pod Serializes the object as JSON and writes it to the given file. The only valid
+ #pod option is C<version>, which defaults to '2'. On Perl 5.8.1 or later, the file
+ #pod is saved with UTF-8 encoding.
+ #pod
+ #pod For C<version> 2 (or higher), the filename should end in '.json'. L<JSON::PP>
+ #pod is the default JSON backend. Using another JSON backend requires L<JSON> 2.5 or
+ #pod later and you must set the C<$ENV{PERL_JSON_BACKEND}> to a supported alternate
+ #pod backend like L<JSON::XS>.
+ #pod
+ #pod For C<version> less than 2, the filename should end in '.yml'.
+ #pod L<CPAN::Meta::Converter> is used to generate an older metadata structure, which
+ #pod is serialized to YAML. CPAN::Meta::YAML is the default YAML backend. You may
+ #pod set the C<$ENV{PERL_YAML_BACKEND}> to a supported alternative backend, though
+ #pod this is not recommended due to subtle incompatibilities between YAML parsers on
+ #pod CPAN.
+ #pod
+ #pod =cut
sub save {
my ($self, $file, $options) = @_;
@@ -4521,12 +4173,32 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
return 1;
}
+ #pod =method meta_spec_version
+ #pod
+ #pod This method returns the version part of the C<meta_spec> entry in the distmeta
+ #pod structure. It is equivalent to:
+ #pod
+ #pod $meta->meta_spec->{version};
+ #pod
+ #pod =cut
sub meta_spec_version {
my ($self) = @_;
return $self->meta_spec->{version};
}
+ #pod =method effective_prereqs
+ #pod
+ #pod my $prereqs = $meta->effective_prereqs;
+ #pod
+ #pod my $prereqs = $meta->effective_prereqs( \@feature_identifiers );
+ #pod
+ #pod This method returns a L<CPAN::Meta::Prereqs> object describing all the
+ #pod prereqs for the distribution. If an arrayref of feature identifiers is given,
+ #pod the prereqs for the identified features are merged together with the
+ #pod distribution's core prereqs before the CPAN::Meta::Prereqs object is returned.
+ #pod
+ #pod =cut
sub effective_prereqs {
my ($self, $features) = @_;
@@ -4541,6 +4213,17 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
return $prereq->with_merged_prereqs(\@other);
}
+ #pod =method should_index_file
+ #pod
+ #pod ... if $meta->should_index_file( $filename );
+ #pod
+ #pod This method returns true if the given file should be indexed. It decides this
+ #pod by checking the C<file> and C<directory> keys in the C<no_index> property of
+ #pod the distmeta structure.
+ #pod
+ #pod C<$filename> should be given in unix format.
+ #pod
+ #pod =cut
sub should_index_file {
my ($self, $filename) = @_;
@@ -4557,6 +4240,15 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
return 1;
}
+ #pod =method should_index_package
+ #pod
+ #pod ... if $meta->should_index_package( $package );
+ #pod
+ #pod This method returns true if the given package should be indexed. It decides
+ #pod this by checking the C<package> and C<namespace> keys in the C<no_index>
+ #pod property of the distmeta structure.
+ #pod
+ #pod =cut
sub should_index_package {
my ($self, $package) = @_;
@@ -4572,6 +4264,14 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
return 1;
}
+ #pod =method features
+ #pod
+ #pod my @feature_objects = $meta->features;
+ #pod
+ #pod This method returns a list of L<CPAN::Meta::Feature> objects, one for each
+ #pod optional feature described by the distribution's metadata.
+ #pod
+ #pod =cut
sub features {
my ($self) = @_;
@@ -4583,6 +4283,15 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
return @features;
}
+ #pod =method feature
+ #pod
+ #pod my $feature_object = $meta->feature( $identifier );
+ #pod
+ #pod This method returns a L<CPAN::Meta::Feature> object for the optional feature
+ #pod with the given identifier. If no feature with that identifier exists, an
+ #pod exception will be raised.
+ #pod
+ #pod =cut
sub feature {
my ($self, $ident) = @_;
@@ -4593,6 +4302,18 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
return CPAN::Meta::Feature->new($ident, $f);
}
+ #pod =method as_struct
+ #pod
+ #pod my $copy = $meta->as_struct( \%options );
+ #pod
+ #pod This method returns a deep copy of the object's metadata as an unblessed hash
+ #pod reference. It takes an optional hashref of options. If the hashref contains
+ #pod a C<version> argument, the copied metadata will be converted to the version
+ #pod of the specification and returned. For example:
+ #pod
+ #pod my $old_spec = $meta->as_struct( {version => "1.4"} );
+ #pod
+ #pod =cut
sub as_struct {
my ($self, $options) = @_;
@@ -4604,6 +4325,24 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
return $struct;
}
+ #pod =method as_string
+ #pod
+ #pod my $string = $meta->as_string( \%options );
+ #pod
+ #pod This method returns a serialized copy of the object's metadata as a character
+ #pod string. (The strings are B<not> UTF-8 encoded.) It takes an optional hashref
+ #pod of options. If the hashref contains a C<version> argument, the copied metadata
+ #pod will be converted to the version of the specification and returned. For
+ #pod example:
+ #pod
+ #pod my $string = $meta->as_string( {version => "1.4"} );
+ #pod
+ #pod For C<version> greater than or equal to 2, the string will be serialized as
+ #pod JSON. For C<version> less than 2, the string will be serialized as YAML. In
+ #pod both cases, the same rules are followed as in the C<save()> method for choosing
+ #pod a serialization backend.
+ #pod
+ #pod =cut
sub as_string {
my ($self, $options) = @_;
@@ -4648,7 +4387,7 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
=pod
- =encoding utf-8
+ =encoding UTF-8
=head1 NAME
@@ -4656,7 +4395,7 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
=head1 VERSION
- version 2.132510
+ version 2.142690
=head1 SYNOPSIS
@@ -4762,6 +4501,14 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
This method returns a new CPAN::Meta object using the structure represented by
the given JSON string. In other respects it is identical to C<load_file()>.
+ =head2 load_string
+
+ my $meta = CPAN::Meta->load_string($string, \%options);
+
+ If you don't know if a string contains YAML or JSON, this method will use
+ L<Parse::CPAN::Meta> to guess. In other respects it is identical to
+ C<load_file()>.
+
=head2 save
$meta->save($distmeta_file, \%options);
@@ -4854,7 +4601,7 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
will be converted to the version of the specification and returned. For
example:
- my $string = $meta->as_struct( {version => "1.4"} );
+ my $string = $meta->as_string( {version => "1.4"} );
For C<version> greater than or equal to 2, the string will be serialized as
JSON. For C<version> less than 2, the string will be serialized as YAML. In
@@ -5027,6 +4774,8 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
=head1 CONTRIBUTORS
+ =for stopwords Ansgar Burchardt Avar Arnfjord Bjarmason Christopher J. Madsen Chuck Adams Cory G Watson Damyan Ivanov Eric Wilhelm Graham Knop Gregor Hermann Karen Etheridge Kenichi Ishigaki Ken Williams Lars Dieckow Leon Timmermans majensen Mark Fowler Matt S Trout Michael G. Schwern moznion Olaf Alders Olivier Mengue Randy Sims
+
=over 4
=item *
@@ -5043,6 +4792,10 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
=item *
+ Chuck Adams <cja987@gmail.com>
+
+ =item *
+
Cory G Watson <gphat@cpan.org>
=item *
@@ -5055,6 +4808,10 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
=item *
+ Graham Knop <haarg@haarg.org>
+
+ =item *
+
Gregor Hermann <gregoa@debian.org>
=item *
@@ -5063,11 +4820,11 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
=item *
- Ken Williams <kwilliams@cpan.org>
+ Kenichi Ishigaki <ishigaki@cpan.org>
=item *
- Kenichi Ishigaki <ishigaki@cpan.org>
+ Ken Williams <kwilliams@cpan.org>
=item *
@@ -5079,19 +4836,31 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
=item *
+ majensen <maj@fortinbras.us>
+
+ =item *
+
Mark Fowler <markf@cpan.org>
=item *
+ Matt S Trout <mst@shadowcat.co.uk>
+
+ =item *
+
Michael G. Schwern <mschwern@cpan.org>
=item *
+ moznion <moznion@gmail.com>
+
+ =item *
+
Olaf Alders <olaf@wundersolutions.com>
=item *
- Olivier Mengué <dolmen@cpan.org>
+ Olivier Mengue <dolmen@cpan.org>
=item *
@@ -5111,9 +4880,7 @@ CPAN_META
$fatpacked{"CPAN/Meta/Check.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_CHECK';
package CPAN::Meta::Check;
- {
- $CPAN::Meta::Check::VERSION = '0.007';
- }
+ $CPAN::Meta::Check::VERSION = '0.009';
use strict;
use warnings;
@@ -5128,11 +4895,11 @@ $fatpacked{"CPAN/Meta/Check.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
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 };
- };
+ $module eq 'perl' and return ($reqs->accepts_module($module, $]) ? () : sprintf "Your Perl (%s) is not in the range '%s'", $], $reqs->requirements_for_module($module));
+
+ my $metadata = Module::Metadata->new_from_module($module, inc => $dirs);
+ return "Module '$module' is not installed" if not defined $metadata;
+ my $version = 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;
@@ -5151,16 +4918,7 @@ $fatpacked{"CPAN/Meta/Check.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
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;
- }
+ return $prereqs->merged_requirements(ref($phases) ? $phases : [ $phases ], [ $type ]);
}
sub check_requirements {
@@ -5196,17 +4954,19 @@ $fatpacked{"CPAN/Meta/Check.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
=pod
+ =encoding UTF-8
+
=head1 NAME
CPAN::Meta::Check - Verify requirements in a CPAN::Meta object
=head1 VERSION
- version 0.007
+ version 0.009
=head1 SYNOPSIS
- warn "$_\n" for verify_requirements($meta, [qw/runtime build test/], 'requires');
+ warn "$_\n" for verify_dependencies($meta, [qw/runtime build test/], 'requires');
=head1 DESCRIPTION
@@ -5214,17 +4974,19 @@ $fatpacked{"CPAN/Meta/Check.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
=head1 FUNCTIONS
- =head2 check_requirements($reqs, $type)
+ =head2 check_requirements($reqs, $type, $incdirs)
- This function checks if all dependencies in C<$reqs> (a L<CPAN::Meta::Requirements|CPAN::Meta::Requirements> object) are met, taking into account that 'conflicts' dependencies have to be checked in reverse. It returns a hash with the modules as keys and any problems as values; the value for a successfully found module will be undef.
+ This function checks if all dependencies in C<$reqs> (a L<CPAN::Meta::Requirements|CPAN::Meta::Requirements> object) are met, taking into account that 'conflicts' dependencies have to be checked in reverse. It returns a hash with the modules as keys and any problems as values; the value for a successfully found module will be undef. Modules are searched for in C<@$incdirs>, defaulting to C<@INC>.
=head2 verify_dependencies($meta, $phases, $types, $incdirs)
- Check all requirements in C<$meta> for phases C<$phases> and types C<$types>. Modules are searched for in C<@$incdirs>, defaulting to C<@INC>.
+ Check all requirements in C<$meta> for phases C<$phases> and type C<$type>. Modules are searched for in C<@$incdirs>, defaulting to C<@INC>. C<$meta> should be a L<CPAN::Meta::Prereqs> or L<CPAN::Meta> object.
+
+ =head2 requirements_for($meta, $phases, $types)
- =head2 requirements_for($meta, $phases, $types, incdirs)
+ B<< This function is deprecated and may be removed at some point in the future, please use CPAN::Meta::Prereqs->merged_requirements instead. >>
- This function returns a unified L<CPAN::Meta::Requirements|CPAN::Meta::Requirements> object for all C<$type> requirements for C<$phases>. $phases may be either one (scalar) value or an arrayref of valid values as defined by the L<CPAN::Meta spec|CPAN::Meta::Spec>. C<$type> must be a relationship as defined by the same spec. Modules are searched for in C<@$incdirs>, defaulting to C<@INC>.
+ This function returns a unified L<CPAN::Meta::Requirements|CPAN::Meta::Requirements> object for all C<$type> requirements for C<$phases>. C<$phases> may be either one (scalar) value or an arrayref of valid values as defined by the L<CPAN::Meta spec|CPAN::Meta::Spec>. C<$type> must be a relationship as defined by the same spec. C<$meta> should be a L<CPAN::Meta::Prereqs> or L<CPAN::Meta> object.
=head1 SEE ALSO
@@ -5255,14 +5017,46 @@ $fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
use strict;
use warnings;
package CPAN::Meta::Converter;
- our $VERSION = '2.132510'; # VERSION
-
+ # VERSION
+ $CPAN::Meta::Converter::VERSION = '2.142690';
+ #pod =head1 SYNOPSIS
+ #pod
+ #pod my $struct = decode_json_file('META.json');
+ #pod
+ #pod my $cmc = CPAN::Meta::Converter->new( $struct );
+ #pod
+ #pod my $new_struct = $cmc->convert( version => "2" );
+ #pod
+ #pod =head1 DESCRIPTION
+ #pod
+ #pod This module converts CPAN Meta structures from one form to another. The
+ #pod primary use is to convert older structures to the most modern version of
+ #pod the specification, but other transformations may be implemented in the
+ #pod future as needed. (E.g. stripping all custom fields or stripping all
+ #pod optional fields.)
+ #pod
+ #pod =cut
use CPAN::Meta::Validator;
use CPAN::Meta::Requirements;
- use version 0.88 ();
use Parse::CPAN::Meta 1.4400 ();
+ # To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls
+ # before 5.10, we fall back to the EUMM bundled compatibility version module if
+ # that's the only thing available. This shouldn't ever happen in a normal CPAN
+ # install of CPAN::Meta::Requirements, as version.pm will be picked up from
+ # prereqs and be available at runtime.
+
+ BEGIN {
+ eval "use version ()"; ## no critic
+ if ( my $err = $@ ) {
+ eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic
+ }
+ }
+
+ # Perl 5.10.0 didn't have "is_qv" in version.pm
+ *_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} };
+
sub _dclone {
my $ref = shift;
@@ -5271,12 +5065,14 @@ $fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
# right thing for typical things that might be there, like version objects,
# Path::Class objects, etc.
no warnings 'once';
- local *UNIVERSAL::TO_JSON = sub { return "$_[0]" };
+ no warnings 'redefine';
+ local *UNIVERSAL::TO_JSON = sub { "$_[0]" };
- my $backend = Parse::CPAN::Meta->json_backend();
- return $backend->new->utf8->decode(
- $backend->new->utf8->allow_blessed->convert_blessed->encode($ref)
- );
+ my $json = Parse::CPAN::Meta->json_backend()->new
+ ->utf8
+ ->allow_blessed
+ ->convert_blessed;
+ $json->decode($json->encode($ref))
}
my %known_specs = (
@@ -5313,7 +5109,7 @@ $fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
my $sig = __PACKAGE__ . " version " . (__PACKAGE__->VERSION || "<dev>");
return $sig unless defined $gen and length $gen;
- return $gen if $gen =~ /(, )\Q$sig/;
+ return $gen if $gen =~ /\Q$sig/;
return "$gen, $sig";
}
@@ -5341,12 +5137,13 @@ $fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
sub _change_meta_spec {
my ($element, undef, undef, $version) = @_;
- $element->{version} = $version;
- $element->{url} = $known_specs{$version};
- return $element;
+ return {
+ version => $version,
+ url => $known_specs{$version},
+ };
}
- my @valid_licenses_1 = (
+ my @open_source = (
'perl',
'gpl',
'apache',
@@ -5358,6 +5155,12 @@ $fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
'mit',
'mozilla',
'open_source',
+ );
+
+ my %is_open_source = map {; $_ => 1 } @open_source;
+
+ my @valid_licenses_1 = (
+ @open_source,
'unrestricted',
'restrictive',
'unknown',
@@ -5374,7 +5177,9 @@ $fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
if ( $license_map_1{lc $element} ) {
return $license_map_1{lc $element};
}
- return 'unknown';
+ else {
+ return 'unknown';
+ }
}
my @valid_licenses_2 = qw(
@@ -5472,12 +5277,20 @@ $fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
return "unknown";
}
elsif( ref $element eq 'ARRAY' ) {
- if ( @$element == 1 ) {
- return $license_downgrade_map{$element->[0]} || "unknown";
+ if ( @$element > 1) {
+ if (grep { !$is_open_source{ $license_downgrade_map{lc $_} || 'unknown' } } @$element) {
+ return 'unknown';
+ }
+ else {
+ return 'open_source';
+ }
+ }
+ elsif ( @$element == 1 ) {
+ return $license_downgrade_map{lc $element->[0]} || "unknown";
}
}
elsif ( ! ref $element ) {
- return $license_downgrade_map{$element} || "unknown";
+ return $license_downgrade_map{lc $element} || "unknown";
}
return "unknown";
}
@@ -5580,7 +5393,7 @@ $fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
# XXX check defined $v and not just $v because version objects leak memory
# in boolean context -- dagolden, 2012-02-03
if ( defined $v ) {
- return $v->is_qv ? $v->normal : $element;
+ return _is_qv($v) ? $v->normal : $element;
}
else {
return 0;
@@ -5590,8 +5403,8 @@ $fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
sub _bad_version_hook {
my ($v) = @_;
$v =~ s{[a-z]+$}{}; # strip trailing alphabetics
- my $vobj = eval { version->parse($v) };
- return defined($vobj) ? $vobj : version->parse(0); # or give up
+ my $vobj = eval { version->new($v) };
+ return defined($vobj) ? $vobj : version->new(0); # or give up
}
sub _version_map {
@@ -5601,7 +5414,7 @@ $fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
# XXX turn this into CPAN::Meta::Requirements with bad version hook
# and then turn it back into a hash
my $new_map = CPAN::Meta::Requirements->new(
- { bad_version_hook => sub { version->new(0) } } # punt
+ { bad_version_hook => \&_bad_version_hook } # punt
);
while ( my ($k,$v) = each %$element ) {
next unless _is_module_name($k);
@@ -5900,7 +5713,7 @@ $fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
my (undef, undef, $meta) = @_;
my $resources = $meta->{resources} || {};
if ( $meta->{license_url} && ! $resources->{license} ) {
- $resources->{license} = $meta->license_url
+ $resources->{license} = $meta->{license_url}
if _is_urlish($meta->{license_url});
}
return unless keys %$resources;
@@ -5958,12 +5771,15 @@ $fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
}
sub _convert {
- my ($data, $spec, $to_version) = @_;
+ my ($data, $spec, $to_version, $is_fragment) = @_;
my $new_data = {};
for my $key ( keys %$spec ) {
next if $key eq ':custom' || $key eq ':drop';
next unless my $fcn = $spec->{$key};
+ if ( $is_fragment && $key eq 'generated_by' ) {
+ $fcn = \&_keep;
+ }
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);
@@ -6448,40 +6264,172 @@ $fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
},
);
+ # for a given field in a spec version, what fields will it feed
+ # into in the *latest* spec (i.e. v2); meta-spec omitted because
+ # we always expect a meta-spec to be generated
+ my %fragments_generate = (
+ '2' => {
+ 'abstract' => 'abstract',
+ 'author' => 'author',
+ 'generated_by' => 'generated_by',
+ 'license' => 'license',
+ 'name' => 'name',
+ 'version' => 'version',
+ 'dynamic_config' => 'dynamic_config',
+ 'release_status' => 'release_status',
+ 'keywords' => 'keywords',
+ 'no_index' => 'no_index',
+ 'optional_features' => 'optional_features',
+ 'provides' => 'provides',
+ 'resources' => 'resources',
+ 'description' => 'description',
+ 'prereqs' => 'prereqs',
+ },
+ '1.4' => {
+ 'abstract' => 'abstract',
+ 'author' => 'author',
+ 'generated_by' => 'generated_by',
+ 'license' => 'license',
+ 'name' => 'name',
+ 'version' => 'version',
+ 'build_requires' => 'prereqs',
+ 'conflicts' => 'prereqs',
+ 'distribution_type' => 'distribution_type',
+ 'dynamic_config' => 'dynamic_config',
+ 'keywords' => 'keywords',
+ 'no_index' => 'no_index',
+ 'optional_features' => 'optional_features',
+ 'provides' => 'provides',
+ 'recommends' => 'prereqs',
+ 'requires' => 'prereqs',
+ 'resources' => 'resources',
+ 'configure_requires' => 'prereqs',
+ },
+ );
+ # this is not quite true but will work well enough
+ # as 1.4 is a superset of earlier ones
+ $fragments_generate{$_} = $fragments_generate{'1.4'} for qw/1.3 1.2 1.1 1.0/;
+
#--------------------------------------------------------------------------#
# Code
#--------------------------------------------------------------------------#
+ #pod =method new
+ #pod
+ #pod my $cmc = CPAN::Meta::Converter->new( $struct );
+ #pod
+ #pod The constructor should be passed a valid metadata structure but invalid
+ #pod structures are accepted. If no meta-spec version is provided, version 1.0 will
+ #pod be assumed.
+ #pod
+ #pod Optionally, you can provide a C<default_version> argument after C<$struct>:
+ #pod
+ #pod my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" );
+ #pod
+ #pod This is only needed when converting a metadata fragment that does not include a
+ #pod C<meta-spec> field.
+ #pod
+ #pod =cut
sub new {
- my ($class,$data) = @_;
+ my ($class,$data,%args) = @_;
# create an attributes hash
my $self = {
'data' => $data,
- 'spec' => $data->{'meta-spec'}{'version'} || "1.0",
+ 'spec' => _extract_spec_version($data, $args{default_version}),
};
# create the object
return bless $self, $class;
}
+ sub _extract_spec_version {
+ my ($data, $default) = @_;
+ my $spec = $data->{'meta-spec'};
+
+ # is meta-spec there and valid?
+ return( $default || "1.0" ) unless defined $spec && ref $spec eq 'HASH'; # before meta-spec?
+
+ # does the version key look like a valid version?
+ my $v = $spec->{version};
+ if ( defined $v && $v =~ /^\d+(?:\.\d+)?$/ ) {
+ return $v if defined $v && grep { $v eq $_ } keys %known_specs; # known spec
+ return $v+0 if defined $v && grep { $v == $_ } keys %known_specs; # 2.0 => 2
+ }
+
+ # otherwise, use heuristics: look for 1.x vs 2.0 fields
+ return "2" if exists $data->{prereqs};
+ return "1.4" if exists $data->{configure_requires};
+ return( $default || "1.2" ); # when meta-spec was first defined
+ }
+
+ #pod =method convert
+ #pod
+ #pod my $new_struct = $cmc->convert( version => "2" );
+ #pod
+ #pod Returns a new hash reference with the metadata converted to a different form.
+ #pod C<convert> will die if any conversion/standardization still results in an
+ #pod invalid structure.
+ #pod
+ #pod Valid parameters include:
+ #pod
+ #pod =over
+ #pod
+ #pod =item *
+ #pod
+ #pod C<version> -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2").
+ #pod Defaults to the latest version of the CPAN Meta Spec.
+ #pod
+ #pod =back
+ #pod
+ #pod Conversion proceeds through each version in turn. For example, a version 1.2
+ #pod structure might be converted to 1.3 then 1.4 then finally to version 2. The
+ #pod conversion process attempts to clean-up simple errors and standardize data.
+ #pod For example, if C<author> is given as a scalar, it will converted to an array
+ #pod reference containing the item. (Converting a structure to its own version will
+ #pod also clean-up and standardize.)
+ #pod
+ #pod When data are cleaned and standardized, missing or invalid fields will be
+ #pod replaced with sensible defaults when possible. This may be lossy or imprecise.
+ #pod For example, some badly structured META.yml files on CPAN have prerequisite
+ #pod modules listed as both keys and values:
+ #pod
+ #pod requires => { 'Foo::Bar' => 'Bam::Baz' }
+ #pod
+ #pod These would be split and each converted to a prerequisite with a minimum
+ #pod version of zero.
+ #pod
+ #pod When some mandatory fields are missing or invalid, the conversion will attempt
+ #pod to provide a sensible default or will fill them with a value of 'unknown'. For
+ #pod example a missing or unrecognized C<license> field will result in a C<license>
+ #pod field of 'unknown'. Fields that may get an 'unknown' include:
+ #pod
+ #pod =for :list
+ #pod * abstract
+ #pod * author
+ #pod * license
+ #pod
+ #pod =cut
sub convert {
my ($self, %args) = @_;
my $args = { %args };
my $new_version = $args->{version} || $HIGHEST;
+ my $is_fragment = $args->{is_fragment};
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";
+ $converted = _convert( $converted, $cleanup{$old_version}, $old_version, $is_fragment );
+ unless ( $args->{is_fragment} ) {
+ 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;
}
@@ -6491,11 +6439,13 @@ $fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
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";
+ $converted = _convert( $converted, $down_convert{$spec_string}, $vers[$i+1], $is_fragment );
+ unless ( $args->{is_fragment} ) {
+ 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;
@@ -6506,26 +6456,52 @@ $fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
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";
+ $converted = _convert( $converted, $up_convert{$spec_string}, $vers[$i+1], $is_fragment );
+ unless ( $args->{is_fragment} ) {
+ 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;
}
}
+ #pod =method upgrade_fragment
+ #pod
+ #pod my $new_struct = $cmc->upgrade_fragment;
+ #pod
+ #pod Returns a new hash reference with the metadata converted to the latest version
+ #pod of the CPAN Meta Spec. No validation is done on the result -- you must
+ #pod validate after merging fragments into a complete metadata document.
+ #pod
+ #pod =cut
+
+ sub upgrade_fragment {
+ my ($self) = @_;
+ my ($old_version) = $self->{spec};
+ my %expected =
+ map {; $_ => 1 }
+ grep { defined }
+ map { $fragments_generate{$old_version}{$_} }
+ keys %{ $self->{data} };
+ my $converted = $self->convert( version => $HIGHEST, is_fragment => 1 );
+ for my $key ( keys %$converted ) {
+ next if $key =~ /^x_/i || $key eq 'meta-spec';
+ delete $converted->{$key} unless $expected{$key};
+ }
+ return $converted;
+ }
+
1;
# ABSTRACT: Convert CPAN distribution metadata structures
- __END__
-
=pod
- =encoding utf-8
+ =encoding UTF-8
=head1 NAME
@@ -6533,7 +6509,7 @@ $fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
=head1 VERSION
- version 2.132510
+ version 2.142690
=head1 SYNOPSIS
@@ -6561,6 +6537,13 @@ $fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
structures are accepted. If no meta-spec version is provided, version 1.0 will
be assumed.
+ Optionally, you can provide a C<default_version> argument after C<$struct>:
+
+ my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" );
+
+ This is only needed when converting a metadata fragment that does not include a
+ C<meta-spec> field.
+
=head2 convert
my $new_struct = $cmc->convert( version => "2" );
@@ -6618,6 +6601,14 @@ $fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
=back
+ =head2 upgrade_fragment
+
+ my $new_struct = $cmc->upgrade_fragment;
+
+ Returns a new hash reference with the metadata converted to the latest version
+ of the CPAN Meta Spec. No validation is done on the result -- you must
+ validate after merging fragments into a complete metadata document.
+
=head1 BUGS
Please report any bugs or feature using the CPAN Request Tracker.
@@ -6649,6 +6640,11 @@ $fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
the same terms as the Perl 5 programming language system itself.
=cut
+
+ __END__
+
+
+ # vim: ts=2 sts=2 sw=2 et:
CPAN_META_CONVERTER
$fatpacked{"CPAN/Meta/Feature.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_FEATURE';
@@ -6656,10 +6652,28 @@ $fatpacked{"CPAN/Meta/Feature.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
use strict;
use warnings;
package CPAN::Meta::Feature;
- our $VERSION = '2.132510'; # VERSION
-
+ # VERSION
+ $CPAN::Meta::Feature::VERSION = '2.142690';
use CPAN::Meta::Prereqs;
+ #pod =head1 DESCRIPTION
+ #pod
+ #pod A CPAN::Meta::Feature object describes an optional feature offered by a CPAN
+ #pod distribution and specified in the distribution's F<META.json> (or F<META.yml>)
+ #pod file.
+ #pod
+ #pod For the most part, this class will only be used when operating on the result of
+ #pod the C<feature> or C<features> methods on a L<CPAN::Meta> object.
+ #pod
+ #pod =method new
+ #pod
+ #pod my $feature = CPAN::Meta::Feature->new( $identifier => \%spec );
+ #pod
+ #pod This returns a new Feature object. The C<%spec> argument to the constructor
+ #pod should be the same as the value of the C<optional_feature> entry in the
+ #pod distmeta. It must contain entries for C<description> and C<prereqs>.
+ #pod
+ #pod =cut
sub new {
my ($class, $identifier, $spec) = @_;
@@ -6673,12 +6687,28 @@ $fatpacked{"CPAN/Meta/Feature.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
bless \%guts => $class;
}
+ #pod =method identifier
+ #pod
+ #pod This method returns the feature's identifier.
+ #pod
+ #pod =cut
sub identifier { $_[0]{identifier} }
+ #pod =method description
+ #pod
+ #pod This method returns the feature's long description.
+ #pod
+ #pod =cut
sub description { $_[0]{description} }
+ #pod =method prereqs
+ #pod
+ #pod This method returns the feature's prerequisites as a L<CPAN::Meta::Prereqs>
+ #pod object.
+ #pod
+ #pod =cut
sub prereqs { $_[0]{prereqs} }
@@ -6690,7 +6720,7 @@ $fatpacked{"CPAN/Meta/Feature.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
=pod
- =encoding utf-8
+ =encoding UTF-8
=head1 NAME
@@ -6698,7 +6728,7 @@ $fatpacked{"CPAN/Meta/Feature.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
=head1 VERSION
- version 2.132510
+ version 2.142690
=head1 DESCRIPTION
@@ -6771,8 +6801,8 @@ $fatpacked{"CPAN/Meta/History.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
use strict;
use warnings;
package CPAN::Meta::History;
- our $VERSION = '2.132510'; # VERSION
-
+ # VERSION
+ $CPAN::Meta::History::VERSION = '2.142690';
1;
# ABSTRACT: history of CPAN Meta Spec changes
@@ -6781,7 +6811,7 @@ $fatpacked{"CPAN/Meta/History.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
=pod
- =encoding utf-8
+ =encoding UTF-8
=head1 NAME
@@ -6789,7 +6819,7 @@ $fatpacked{"CPAN/Meta/History.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
=head1 VERSION
- version 2.132510
+ version 2.142690
=head1 DESCRIPTION
@@ -7083,18 +7113,302 @@ $fatpacked{"CPAN/Meta/History.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
=cut
CPAN_META_HISTORY
+$fatpacked{"CPAN/Meta/Merge.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_MERGE';
+ use strict;
+ use warnings;
+
+ package CPAN::Meta::Merge;
+ # VERSION
+ $CPAN::Meta::Merge::VERSION = '2.142690';
+ use Carp qw/croak/;
+ use Scalar::Util qw/blessed/;
+ use CPAN::Meta::Converter;
+
+ sub _identical {
+ my ($left, $right, $path) = @_;
+ croak "Can't merge attribute " . join '.', @{$path} unless $left eq $right;
+ return $left;
+ }
+
+ sub _merge {
+ my ($current, $next, $mergers, $path) = @_;
+ for my $key (keys %{$next}) {
+ if (not exists $current->{$key}) {
+ $current->{$key} = $next->{$key};
+ }
+ elsif (my $merger = $mergers->{$key}) {
+ $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
+ }
+ elsif ($merger = $mergers->{':default'}) {
+ $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
+ }
+ else {
+ croak sprintf "Can't merge unknown attribute '%s'", join '.', @{$path}, $key;
+ }
+ }
+ return $current;
+ }
+
+ sub _uniq {
+ my %seen = ();
+ return grep { not $seen{$_}++ } @_;
+ }
+
+ sub _set_addition {
+ my ($left, $right) = @_;
+ return [ +_uniq(@{$left}, @{$right}) ];
+ }
+
+ sub _uniq_map {
+ my ($left, $right, $path) = @_;
+ for my $key (keys %{$right}) {
+ if (not exists $left->{$key}) {
+ $left->{$key} = $right->{$key};
+ }
+ else {
+ croak 'Duplication of element ' . join '.', @{$path}, $key;
+ }
+ }
+ return $left;
+ }
+
+ sub _improvize {
+ my ($left, $right, $path) = @_;
+ my ($name) = reverse @{$path};
+ if ($name =~ /^x_/) {
+ if (ref($left) eq 'ARRAY') {
+ return _set_addition($left, $right, $path);
+ }
+ elsif (ref($left) eq 'HASH') {
+ return _uniq_map($left, $right, $path);
+ }
+ else {
+ return _identical($left, $right, $path);
+ }
+ }
+ croak sprintf "Can't merge '%s'", join '.', @{$path};
+ }
+
+ my %default = (
+ abstract => \&_identical,
+ author => \&_set_addition,
+ dynamic_config => sub {
+ my ($left, $right) = @_;
+ return $left || $right;
+ },
+ generated_by => sub {
+ my ($left, $right) = @_;
+ return join ', ', _uniq(split(/, /, $left), split(/, /, $right));
+ },
+ license => \&_set_addition,
+ 'meta-spec' => {
+ version => \&_identical,
+ url => \&_identical
+ },
+ name => \&_identical,
+ release_status => \&_identical,
+ version => \&_identical,
+ description => \&_identical,
+ keywords => \&_set_addition,
+ no_index => { map { ($_ => \&_set_addition) } qw/file directory package namespace/ },
+ optional_features => \&_uniq_map,
+ prereqs => sub {
+ require CPAN::Meta::Prereqs;
+ my ($left, $right) = map { CPAN::Meta::Prereqs->new($_) } @_[0,1];
+ return $left->with_merged_prereqs($right)->as_string_hash;
+ },
+ provides => \&_uniq_map,
+ resources => {
+ license => \&_set_addition,
+ homepage => \&_identical,
+ bugtracker => \&_uniq_map,
+ repository => \&_uniq_map,
+ ':default' => \&_improvize,
+ },
+ ':default' => \&_improvize,
+ );
+
+ sub new {
+ my ($class, %arguments) = @_;
+ croak 'default version required' if not exists $arguments{default_version};
+ my %mapping = %default;
+ my %extra = %{ $arguments{extra_mappings} || {} };
+ for my $key (keys %extra) {
+ if (ref($mapping{$key}) eq 'HASH') {
+ $mapping{$key} = { %{ $mapping{$key} }, %{ $extra{$key} } };
+ }
+ else {
+ $mapping{$key} = $extra{$key};
+ }
+ }
+ return bless {
+ default_version => $arguments{default_version},
+ mapping => _coerce_mapping(\%mapping, []),
+ }, $class;
+ }
+
+ my %coderef_for = (
+ set_addition => \&_set_addition,
+ uniq_map => \&_uniq_map,
+ identical => \&_identical,
+ improvize => \&_improvize,
+ );
+
+ sub _coerce_mapping {
+ my ($orig, $map_path) = @_;
+ my %ret;
+ for my $key (keys %{$orig}) {
+ my $value = $orig->{$key};
+ if (ref($orig->{$key}) eq 'CODE') {
+ $ret{$key} = $value;
+ }
+ elsif (ref($value) eq 'HASH') {
+ my $mapping = _coerce_mapping($value, [ @{$map_path}, $key ]);
+ $ret{$key} = sub {
+ my ($left, $right, $path) = @_;
+ return _merge($left, $right, $mapping, [ @{$path}, $key ]);
+ };
+ }
+ elsif ($coderef_for{$value}) {
+ $ret{$key} = $coderef_for{$value};
+ }
+ else {
+ croak "Don't know what to do with " . join '.', @{$map_path}, $key;
+ }
+ }
+ return \%ret;
+ }
+
+ sub merge {
+ my ($self, @items) = @_;
+ my $current = {};
+ for my $next (@items) {
+ if ( blessed($next) && $next->isa('CPAN::Meta') ) {
+ $next = $next->as_struct;
+ }
+ elsif ( ref($next) eq 'HASH' ) {
+ my $cmc = CPAN::Meta::Converter->new(
+ $next, default_version => $self->{default_version}
+ );
+ $next = $cmc->upgrade_fragment;
+ }
+ else {
+ croak "Don't know how to merge '$next'";
+ }
+ $current = _merge($current, $next, $self->{mapping}, []);
+ }
+ return $current;
+ }
+
+ 1;
+
+ # ABSTRACT: Merging CPAN Meta fragments
+
+ __END__
+
+ =pod
+
+ =encoding UTF-8
+
+ =head1 NAME
+
+ CPAN::Meta::Merge - Merging CPAN Meta fragments
+
+ =head1 VERSION
+
+ version 2.142690
+
+ =head1 SYNOPSIS
+
+ my $merger = CPAN::Meta::Merge->new(default_version => "2");
+ my $meta = $merger->merge($base, @additional);
+
+ =head1 DESCRIPTION
+
+ =head1 METHODS
+
+ =head2 new
+
+ This creates a CPAN::Meta::Merge object. It takes one mandatory named
+ argument, C<version>, declaring the version of the meta-spec that must be
+ used for the merge. It can optionally take an C<extra_mappings> argument
+ that allows one to add additional merging functions for specific elements.
+
+ =head2 merge(@fragments)
+
+ Merge all C<@fragments> together. It will accept both CPAN::Meta objects and
+ (possibly incomplete) hashrefs of metadata.
+
+ =head1 AUTHORS
+
+ =over 4
+
+ =item *
+
+ David Golden <dagolden@cpan.org>
+
+ =item *
+
+ Ricardo Signes <rjbs@cpan.org>
+
+ =back
+
+ =head1 COPYRIGHT AND LICENSE
+
+ This software is copyright (c) 2010 by David Golden and Ricardo Signes.
+
+ This is free software; you can redistribute it and/or modify it under
+ the same terms as the Perl 5 programming language system itself.
+
+ =cut
+CPAN_META_MERGE
+
$fatpacked{"CPAN/Meta/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_PREREQS';
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Prereqs;
- our $VERSION = '2.132510'; # VERSION
-
+ # VERSION
+ $CPAN::Meta::Prereqs::VERSION = '2.142690';
+ #pod =head1 DESCRIPTION
+ #pod
+ #pod A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN
+ #pod distribution or one of its optional features. Each set of prereqs is
+ #pod organized by phase and type, as described in L<CPAN::Meta::Prereqs>.
+ #pod
+ #pod =cut
use Carp qw(confess);
use Scalar::Util qw(blessed);
use CPAN::Meta::Requirements 2.121;
+ #pod =method new
+ #pod
+ #pod my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec );
+ #pod
+ #pod This method returns a new set of Prereqs. The input should look like the
+ #pod contents of the C<prereqs> field described in L<CPAN::Meta::Spec>, meaning
+ #pod something more or less like this:
+ #pod
+ #pod my $prereq = CPAN::Meta::Prereqs->new({
+ #pod runtime => {
+ #pod requires => {
+ #pod 'Some::Module' => '1.234',
+ #pod ...,
+ #pod },
+ #pod ...,
+ #pod },
+ #pod ...,
+ #pod });
+ #pod
+ #pod You can also construct an empty set of prereqs with:
+ #pod
+ #pod my $prereqs = CPAN::Meta::Prereqs->new;
+ #pod
+ #pod This empty set of prereqs is useful for accumulating new prereqs before finally
+ #pod dumping the whole set into a structure or string.
+ #pod
+ #pod =cut
sub __legal_phases { qw(configure build test runtime develop) }
sub __legal_types { qw(requires recommends suggests conflicts) }
@@ -7130,6 +7444,19 @@ $fatpacked{"CPAN/Meta/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
return bless \%guts => $class;
}
+ #pod =method requirements_for
+ #pod
+ #pod my $requirements = $prereqs->requirements_for( $phase, $type );
+ #pod
+ #pod This method returns a L<CPAN::Meta::Requirements> object for the given
+ #pod phase/type combination. If no prerequisites are registered for that
+ #pod combination, a new CPAN::Meta::Requirements object will be returned, and it may
+ #pod be added to as needed.
+ #pod
+ #pod If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will
+ #pod be raised.
+ #pod
+ #pod =cut
sub requirements_for {
my ($self, $phase, $type) = @_;
@@ -7152,6 +7479,21 @@ $fatpacked{"CPAN/Meta/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
return $req;
}
+ #pod =method with_merged_prereqs
+ #pod
+ #pod my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs );
+ #pod
+ #pod my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs );
+ #pod
+ #pod This method returns a new CPAN::Meta::Prereqs objects in which all the
+ #pod other prerequisites given are merged into the current set. This is primarily
+ #pod provided for combining a distribution's core prereqs with the prereqs of one of
+ #pod its optional features.
+ #pod
+ #pod The new prereqs object has no ties to the originals, and altering it further
+ #pod will not alter them.
+ #pod
+ #pod =cut
sub with_merged_prereqs {
my ($self, $other) = @_;
@@ -7182,6 +7524,56 @@ $fatpacked{"CPAN/Meta/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
return (ref $self)->new(\%new_arg);
}
+ #pod =method merged_requirements
+ #pod
+ #pod my $new_reqs = $prereqs->merged_requirements( \@phases, \@types );
+ #pod my $new_reqs = $prereqs->merged_requirements( \@phases );
+ #pod my $new_reqs = $preerqs->merged_requirements();
+ #pod
+ #pod This method joins together all requirements across a number of phases
+ #pod and types into a new L<CPAN::Meta::Requirements> object. If arguments
+ #pod are omitted, it defaults to "runtime", "build" and "test" for phases
+ #pod and "requires" and "recommends" for types.
+ #pod
+ #pod =cut
+
+ sub merged_requirements {
+ my ($self, $phases, $types) = @_;
+ $phases = [qw/runtime build test/] unless defined $phases;
+ $types = [qw/requires recommends/] unless defined $types;
+
+ confess "merged_requirements phases argument must be an arrayref"
+ unless ref $phases eq 'ARRAY';
+ confess "merged_requirements types argument must be an arrayref"
+ unless ref $types eq 'ARRAY';
+
+ my $req = CPAN::Meta::Requirements->new;
+
+ for my $phase ( @$phases ) {
+ unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) {
+ confess "requested requirements for unknown phase: $phase";
+ }
+ for my $type ( @$types ) {
+ unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) {
+ confess "requested requirements for unknown type: $type";
+ }
+ $req->add_requirements( $self->requirements_for($phase, $type) );
+ }
+ }
+
+ $req->finalize if $self->is_finalized;
+
+ return $req;
+ }
+
+
+ #pod =method as_string_hash
+ #pod
+ #pod This method returns a hashref containing structures suitable for dumping into a
+ #pod distmeta data structure. It is made up of hashes and strings, only; there will
+ #pod be no Prereqs, CPAN::Meta::Requirements, or C<version> objects inside it.
+ #pod
+ #pod =cut
sub as_string_hash {
my ($self) = @_;
@@ -7200,9 +7592,22 @@ $fatpacked{"CPAN/Meta/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
return \%hash;
}
+ #pod =method is_finalized
+ #pod
+ #pod This method returns true if the set of prereqs has been marked "finalized," and
+ #pod cannot be altered.
+ #pod
+ #pod =cut
sub is_finalized { $_[0]{finalized} }
+ #pod =method finalize
+ #pod
+ #pod Calling C<finalize> on a Prereqs object will close it for further modification.
+ #pod Attempting to make any changes that would actually alter the prereqs will
+ #pod result in an exception being thrown.
+ #pod
+ #pod =cut
sub finalize {
my ($self) = @_;
@@ -7214,6 +7619,16 @@ $fatpacked{"CPAN/Meta/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
}
}
+ #pod =method clone
+ #pod
+ #pod my $cloned_prereqs = $prereqs->clone;
+ #pod
+ #pod This method returns a Prereqs object that is identical to the original object,
+ #pod but can be altered without affecting the original object. Finalization does
+ #pod not survive cloning, meaning that you may clone a finalized set of prereqs and
+ #pod then modify the clone.
+ #pod
+ #pod =cut
sub clone {
my ($self) = @_;
@@ -7229,7 +7644,7 @@ $fatpacked{"CPAN/Meta/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
=pod
- =encoding utf-8
+ =encoding UTF-8
=head1 NAME
@@ -7237,7 +7652,7 @@ $fatpacked{"CPAN/Meta/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
=head1 VERSION
- version 2.132510
+ version 2.142690
=head1 DESCRIPTION
@@ -7299,6 +7714,17 @@ $fatpacked{"CPAN/Meta/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
The new prereqs object has no ties to the originals, and altering it further
will not alter them.
+ =head2 merged_requirements
+
+ my $new_reqs = $prereqs->merged_requirements( \@phases, \@types );
+ my $new_reqs = $prereqs->merged_requirements( \@phases );
+ my $new_reqs = $preerqs->merged_requirements();
+
+ This method joins together all requirements across a number of phases
+ and types into a new L<CPAN::Meta::Requirements> object. If arguments
+ are omitted, it defaults to "runtime", "build" and "test" for phases
+ and "requires" and "recommends" for types.
+
=head2 as_string_hash
This method returns a hashref containing structures suitable for dumping into a
@@ -7362,16 +7788,72 @@ $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
use strict;
use warnings;
package CPAN::Meta::Requirements;
- our $VERSION = '2.123'; # VERSION
+ our $VERSION = '2.128'; # VERSION
# ABSTRACT: a set of version requirements for a CPAN dist
+ #pod =head1 SYNOPSIS
+ #pod
+ #pod use CPAN::Meta::Requirements;
+ #pod
+ #pod my $build_requires = CPAN::Meta::Requirements->new;
+ #pod
+ #pod $build_requires->add_minimum('Library::Foo' => 1.208);
+ #pod
+ #pod $build_requires->add_minimum('Library::Foo' => 2.602);
+ #pod
+ #pod $build_requires->add_minimum('Module::Bar' => 'v1.2.3');
+ #pod
+ #pod $METAyml->{build_requires} = $build_requires->as_string_hash;
+ #pod
+ #pod =head1 DESCRIPTION
+ #pod
+ #pod A CPAN::Meta::Requirements object models a set of version constraints like
+ #pod those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
+ #pod and as defined by L<CPAN::Meta::Spec>;
+ #pod It can be built up by adding more and more constraints, and it will reduce them
+ #pod to the simplest representation.
+ #pod
+ #pod Logically impossible constraints will be identified immediately by thrown
+ #pod exceptions.
+ #pod
+ #pod =cut
use Carp ();
use Scalar::Util ();
- use version 0.77 (); # the ->parse method
+ # To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls
+ # before 5.10, we fall back to the EUMM bundled compatibility version module if
+ # that's the only thing available. This shouldn't ever happen in a normal CPAN
+ # install of CPAN::Meta::Requirements, as version.pm will be picked up from
+ # prereqs and be available at runtime.
- my @valid_options = qw( bad_version_hook );
+ BEGIN {
+ eval "use version ()"; ## no critic
+ if ( my $err = $@ ) {
+ eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic
+ }
+ }
+
+ # Perl 5.10.0 didn't have "is_qv" in version.pm
+ *_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} };
+
+ #pod =method new
+ #pod
+ #pod my $req = CPAN::Meta::Requirements->new;
+ #pod
+ #pod This returns a new CPAN::Meta::Requirements object. It takes an optional
+ #pod hash reference argument. Currently, only one key is supported:
+ #pod
+ #pod =for :list
+ #pod * C<bad_version_hook> -- if provided, when a version cannot be parsed into
+ #pod a version object, this code reference will be called with the invalid version
+ #pod string as an argument. It must return a valid version object.
+ #pod
+ #pod All other keys are ignored.
+ #pod
+ #pod =cut
+
+ my @valid_options = qw( bad_version_hook );
sub new {
my ($class, $options) = @_;
@@ -7383,14 +7865,41 @@ $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
return bless \%self => $class;
}
+ # from version::vpp
+ sub _find_magic_vstring {
+ my $value = shift;
+ my $tvalue = '';
+ require B;
+ my $sv = B::svref_2object(\$value);
+ my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
+ while ( $magic ) {
+ if ( $magic->TYPE eq 'V' ) {
+ $tvalue = $magic->PTR;
+ $tvalue =~ s/^v?(.+)$/v$1/;
+ last;
+ }
+ else {
+ $magic = $magic->MOREMAGIC;
+ }
+ }
+ return $tvalue;
+ }
+
sub _version_object {
my ($self, $version) = @_;
my $vobj;
+ # hack around version::vpp not handling <3 character vstring literals
+ if ( $INC{'version/vpp.pm'} || $INC{'ExtUtils/MakeMaker/version/vpp.pm'} ) {
+ my $magic = _find_magic_vstring( $version );
+ $version = $magic if length $magic;
+ }
+
eval {
- $vobj = (! defined $version) ? version->parse(0)
- : (! Scalar::Util::blessed($version)) ? version->parse($version)
+ local $SIG{__WARN__} = sub { die "Invalid version: $_[0]" };
+ $vobj = (! defined $version) ? version->new(0)
+ : (! Scalar::Util::blessed($version)) ? version->new($version)
: $version;
};
@@ -7406,17 +7915,68 @@ $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
# ensure no leading '.'
if ( $vobj =~ m{\A\.} ) {
- $vobj = version->parse("0$vobj");
+ $vobj = version->new("0$vobj");
}
# ensure normal v-string form
- if ( $vobj->is_qv ) {
- $vobj = version->parse($vobj->normal);
+ if ( _is_qv($vobj) ) {
+ $vobj = version->new($vobj->normal);
}
return $vobj;
}
+ #pod =method add_minimum
+ #pod
+ #pod $req->add_minimum( $module => $version );
+ #pod
+ #pod This adds a new minimum version requirement. If the new requirement is
+ #pod redundant to the existing specification, this has no effect.
+ #pod
+ #pod Minimum requirements are inclusive. C<$version> is required, along with any
+ #pod greater version number.
+ #pod
+ #pod This method returns the requirements object.
+ #pod
+ #pod =method add_maximum
+ #pod
+ #pod $req->add_maximum( $module => $version );
+ #pod
+ #pod This adds a new maximum version requirement. If the new requirement is
+ #pod redundant to the existing specification, this has no effect.
+ #pod
+ #pod Maximum requirements are inclusive. No version strictly greater than the given
+ #pod version is allowed.
+ #pod
+ #pod This method returns the requirements object.
+ #pod
+ #pod =method add_exclusion
+ #pod
+ #pod $req->add_exclusion( $module => $version );
+ #pod
+ #pod This adds a new excluded version. For example, you might use these three
+ #pod method calls:
+ #pod
+ #pod $req->add_minimum( $module => '1.00' );
+ #pod $req->add_maximum( $module => '1.82' );
+ #pod
+ #pod $req->add_exclusion( $module => '1.75' );
+ #pod
+ #pod Any version between 1.00 and 1.82 inclusive would be acceptable, except for
+ #pod 1.75.
+ #pod
+ #pod This method returns the requirements object.
+ #pod
+ #pod =method exact_version
+ #pod
+ #pod $req->exact_version( $module => $version );
+ #pod
+ #pod This sets the version required for the given module to I<exactly> the given
+ #pod version. No other version would be considered acceptable.
+ #pod
+ #pod This method returns the requirements object.
+ #pod
+ #pod =cut
BEGIN {
for my $type (qw(minimum maximum exclusion exact_version)) {
@@ -7438,6 +7998,17 @@ $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
}
}
+ #pod =method add_requirements
+ #pod
+ #pod $req->add_requirements( $another_req_object );
+ #pod
+ #pod This method adds all the requirements in the given CPAN::Meta::Requirements object
+ #pod to the requirements object on which it was called. If there are any conflicts,
+ #pod an exception is thrown.
+ #pod
+ #pod This method returns the requirements object.
+ #pod
+ #pod =cut
sub add_requirements {
my ($self, $req) = @_;
@@ -7453,6 +8024,22 @@ $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
return $self;
}
+ #pod =method accepts_module
+ #pod
+ #pod my $bool = $req->accepts_module($module => $version);
+ #pod
+ #pod Given an module and version, this method returns true if the version
+ #pod specification for the module accepts the provided version. In other words,
+ #pod given:
+ #pod
+ #pod Module => '>= 1.00, < 2.00'
+ #pod
+ #pod We will accept 1.00 and 1.75 but not 0.50 or 2.00.
+ #pod
+ #pod For modules that do not appear in the requirements, this method will return
+ #pod true.
+ #pod
+ #pod =cut
sub accepts_module {
my ($self, $module, $version) = @_;
@@ -7463,6 +8050,15 @@ $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
return $range->_accepts($version);
}
+ #pod =method clear_requirement
+ #pod
+ #pod $req->clear_requirement( $module );
+ #pod
+ #pod This removes the requirement for a given module from the object.
+ #pod
+ #pod This method returns the requirements object.
+ #pod
+ #pod =cut
sub clear_requirement {
my ($self, $module) = @_;
@@ -7477,6 +8073,17 @@ $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
return $self;
}
+ #pod =method requirements_for_module
+ #pod
+ #pod $req->requirements_for_module( $module );
+ #pod
+ #pod This returns a string containing the version requirements for a given module in
+ #pod the format described in L<CPAN::Meta::Spec> or undef if the given module has no
+ #pod requirements. This should only be used for informational purposes such as error
+ #pod messages and should not be interpreted or used for comparison (see
+ #pod L</accepts_module> instead.)
+ #pod
+ #pod =cut
sub requirements_for_module {
my ($self, $module) = @_;
@@ -7485,9 +8092,23 @@ $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
return $entry->as_string;
}
+ #pod =method required_modules
+ #pod
+ #pod This method returns a list of all the modules for which requirements have been
+ #pod specified.
+ #pod
+ #pod =cut
sub required_modules { keys %{ $_[0]{requirements} } }
+ #pod =method clone
+ #pod
+ #pod $req->clone;
+ #pod
+ #pod This method returns a clone of the invocant. The clone and the original object
+ #pod can then be changed independent of one another.
+ #pod
+ #pod =cut
sub clone {
my ($self) = @_;
@@ -7516,6 +8137,12 @@ $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
$self->{requirements}{ $name } = $new;
}
+ #pod =method is_simple
+ #pod
+ #pod This method returns true if and only if all requirements are inclusive minimums
+ #pod -- that is, if their string expression is just the version number.
+ #pod
+ #pod =cut
sub is_simple {
my ($self) = @_;
@@ -7527,12 +8154,61 @@ $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
return 1;
}
+ #pod =method is_finalized
+ #pod
+ #pod This method returns true if the requirements have been finalized by having the
+ #pod C<finalize> method called on them.
+ #pod
+ #pod =cut
sub is_finalized { $_[0]{finalized} }
+ #pod =method finalize
+ #pod
+ #pod This method marks the requirements finalized. Subsequent attempts to change
+ #pod the requirements will be fatal, I<if> they would result in a change. If they
+ #pod would not alter the requirements, they have no effect.
+ #pod
+ #pod If a finalized set of requirements is cloned, the cloned requirements are not
+ #pod also finalized.
+ #pod
+ #pod =cut
sub finalize { $_[0]{finalized} = 1 }
+ #pod =method as_string_hash
+ #pod
+ #pod This returns a reference to a hash describing the requirements using the
+ #pod strings in the L<CPAN::Meta::Spec> specification.
+ #pod
+ #pod For example after the following program:
+ #pod
+ #pod my $req = CPAN::Meta::Requirements->new;
+ #pod
+ #pod $req->add_minimum('CPAN::Meta::Requirements' => 0.102);
+ #pod
+ #pod $req->add_minimum('Library::Foo' => 1.208);
+ #pod
+ #pod $req->add_maximum('Library::Foo' => 2.602);
+ #pod
+ #pod $req->add_minimum('Module::Bar' => 'v1.2.3');
+ #pod
+ #pod $req->add_exclusion('Module::Bar' => 'v1.2.8');
+ #pod
+ #pod $req->exact_version('Xyzzy' => '6.01');
+ #pod
+ #pod my $hashref = $req->as_string_hash;
+ #pod
+ #pod C<$hashref> would contain:
+ #pod
+ #pod {
+ #pod 'CPAN::Meta::Requirements' => '0.102',
+ #pod 'Library::Foo' => '>= 1.208, <= 2.206',
+ #pod 'Module::Bar' => '>= v1.2.3, != v1.2.8',
+ #pod 'Xyzzy' => '== 6.01',
+ #pod }
+ #pod
+ #pod =cut
sub as_string_hash {
my ($self) = @_;
@@ -7543,6 +8219,38 @@ $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
return \%hash;
}
+ #pod =method add_string_requirement
+ #pod
+ #pod $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206');
+ #pod
+ #pod This method parses the passed in string and adds the appropriate requirement
+ #pod for the given module. It understands version ranges as described in the
+ #pod L<CPAN::Meta::Spec/Version Ranges>. For example:
+ #pod
+ #pod =over 4
+ #pod
+ #pod =item 1.3
+ #pod
+ #pod =item >= 1.3
+ #pod
+ #pod =item <= 1.3
+ #pod
+ #pod =item == 1.3
+ #pod
+ #pod =item != 1.3
+ #pod
+ #pod =item > 1.3
+ #pod
+ #pod =item < 1.3
+ #pod
+ #pod =item >= 1.3, != 1.5, <= 2.0
+ #pod
+ #pod A version number without an operator is equivalent to specifying a minimum
+ #pod (C<E<gt>=>). Extra whitespace is allowed.
+ #pod
+ #pod =back
+ #pod
+ #pod =cut
my %methods_for_op = (
'==' => [ qw(exact_version) ],
@@ -7576,6 +8284,15 @@ $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
}
}
+ #pod =method from_string_hash
+ #pod
+ #pod my $req = CPAN::Meta::Requirements->from_string_hash( \%hash );
+ #pod
+ #pod This is an alternate constructor for a CPAN::Meta::Requirements object. It takes
+ #pod a hash of module names and version requirement strings and returns a new
+ #pod CPAN::Meta::Requirements object.
+ #pod
+ #pod =cut
sub from_string_hash {
my ($class, $hash) = @_;
@@ -7797,7 +8514,7 @@ $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
=pod
- =encoding utf-8
+ =encoding UTF-8
=head1 NAME
@@ -7805,7 +8522,7 @@ $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
=head1 VERSION
- version 2.123
+ version 2.128
=head1 SYNOPSIS
@@ -7824,7 +8541,8 @@ $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
=head1 DESCRIPTION
A CPAN::Meta::Requirements object models a set of version constraints like
- those specified in the F<META.yml> or F<META.json> files in CPAN distributions.
+ those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
+ and as defined by L<CPAN::Meta::Spec>;
It can be built up by adding more and more constraints, and it will reduce them
to the simplest representation.
@@ -7838,16 +8556,13 @@ $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
my $req = CPAN::Meta::Requirements->new;
This returns a new CPAN::Meta::Requirements object. It takes an optional
- hash reference argument. The following keys are supported:
+ hash reference argument. Currently, only one key is supported:
=over 4
=item *
- <bad_version_hook> -- if provided, when a version cannot be parsed into
-
- a version object, this code reference will be called with the invalid version
- string as an argument. It must return a valid version object.
+ C<bad_version_hook> -- if provided, when a version cannot be parsed into a version object, this code reference will be called with the invalid version string as an argument. It must return a valid version object.
=back
@@ -7915,7 +8630,7 @@ $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
=head2 accepts_module
- my $bool = $req->accepts_modules($module => $version);
+ my $bool = $req->accepts_module($module => $version);
Given an module and version, this method returns true if the version
specification for the module accepts the provided version. In other words,
@@ -7980,7 +8695,7 @@ $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
=head2 as_string_hash
This returns a reference to a hash describing the requirements using the
- strings in the F<META.yml> specification.
+ strings in the L<CPAN::Meta::Spec> specification.
For example after the following program:
@@ -8055,7 +8770,7 @@ $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
=head2 Bugs / Feature Requests
Please report any bugs or feature requests through the issue tracker
- at L<https://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta-Requirements>.
+ at L<https://github.com/dagolden/CPAN-Meta-Requirements/issues>.
You will be notified automatically of any progress on your issue.
=head2 Source Code
@@ -8063,9 +8778,9 @@ $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
This is open source software. The code repository is available for
public review and contribution under the terms of the license.
- L<https://github.com/dagolden/cpan-meta-requirements>
+ L<https://github.com/dagolden/CPAN-Meta-Requirements>
- git clone git://github.com/dagolden/cpan-meta-requirements.git
+ git clone https://github.com/dagolden/CPAN-Meta-Requirements.git
=head1 AUTHORS
@@ -8081,6 +8796,22 @@ $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
=back
+ =head1 CONTRIBUTORS
+
+ =for stopwords Karen Etheridge robario
+
+ =over 4
+
+ =item *
+
+ Karen Etheridge <ether@cpan.org>
+
+ =item *
+
+ robario <webmaster@robario.com>
+
+ =back
+
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden and Ricardo Signes.
@@ -8101,8 +8832,8 @@ $fatpacked{"CPAN/Meta/Spec.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
use strict;
use warnings;
package CPAN::Meta::Spec;
- our $VERSION = '2.132510'; # VERSION
-
+ # VERSION
+ $CPAN::Meta::Spec::VERSION = '2.142690';
1;
# ABSTRACT: specification for CPAN distribution metadata
@@ -8114,7 +8845,7 @@ $fatpacked{"CPAN/Meta/Spec.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
=pod
- =encoding utf-8
+ =encoding UTF-8
=head1 NAME
@@ -8122,7 +8853,7 @@ $fatpacked{"CPAN/Meta/Spec.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
=head1 VERSION
- version 2.132510
+ version 2.142690
=head1 SYNOPSIS
@@ -8176,7 +8907,7 @@ $fatpacked{"CPAN/Meta/Spec.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
keywords => [ qw/ toolchain cpan dual-life / ],
'meta-spec' => {
version => '2',
- url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
+ url => 'https://metacpan.org/pod/CPAN::Meta::Spec',
},
generated_by => 'Module::Build version 0.36',
};
@@ -8383,11 +9114,17 @@ $fatpacked{"CPAN/Meta/Spec.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
value to indicate that prerequisites included in metadata may be
considered final and valid for static analysis.
+ Note: when this field is true, post-configuration prerequisites are not
+ guaranteed to bear any relation whatsoever to those stated in the metadata,
+ and relying on them doing so is an error. See also
+ L</Prerequisites for dynamically configured distributions> in the implementors'
+ notes.
+
This field explicitly B<does not> indicate whether installation may be
safely performed without using a Makefile or Build file, as there may be
special files to install or custom installation targets (e.g. for
dual-life modules that exist on CPAN as well as in the Perl core). This
- field only defines whether prerequisites are complete as given in the
+ field only defines whether or not prerequisites are exactly as given in the
metadata.
=head3 generated_by
@@ -8409,7 +9146,7 @@ $fatpacked{"CPAN/Meta/Spec.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
license => [ 'perl_5' ]
- license => [ 'apache_2', 'mozilla_1_0' ]
+ license => [ 'apache_2_0', 'mozilla_1_0' ]
(Spec 2) [required] {List of one or more License Strings}
@@ -8489,6 +9226,20 @@ $fatpacked{"CPAN/Meta/Spec.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
the given version. This is strictly for human-consumption and should
not impact the interpretation of the document.
+ For the version 2 spec, either of these are recommended:
+
+ =over 4
+
+ =item *
+
+ C<https://metacpan.org/pod/CPAN::Meta::Spec>
+
+ =item *
+
+ C<http://search.cpan.org/perldoc?CPAN::Meta::Spec>
+
+ =back
+
=back
=head3 name
@@ -8502,7 +9253,8 @@ $fatpacked{"CPAN/Meta/Spec.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
This field is the name of the distribution. This is often created by
taking the "main package" in the distribution and changing C<::> to
C<->, but the name may be completely unrelated to the packages within
- the distribution. C.f. L<http://search.cpan.org/dist/libwww-perl/>.
+ the distribution. For example, L<LWP::UserAgent> is distributed as part
+ of the distribution name "libwww-perl".
=head3 release_status
@@ -8599,7 +9351,10 @@ $fatpacked{"CPAN/Meta/Spec.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
This Map describes any files, directories, packages, and namespaces that
are private to the packaging or implementation of the distribution and
- should be ignored by indexing or search tools.
+ should be ignored by indexing or search tools. Note that this is a list of
+ exclusions, and the spec does not define what to I<include> - see
+ L</Indexing distributions a la PAUSE> in the implementors notes for more
+ information.
Valid subkeys are as follows:
@@ -8756,8 +9511,8 @@ $fatpacked{"CPAN/Meta/Spec.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
This describes all packages provided by this distribution. This
information is used by distribution and automation mechanisms like
- PAUSE, CPAN, and search.cpan.org to build indexes saying in which
- distribution various packages can be found.
+ PAUSE, CPAN, metacpan.org and search.cpan.org to build indexes saying in
+ which distribution various packages can be found.
The keys of C<provides> are package names that can be found within
the distribution. If a package name key is provided, it must
@@ -8769,7 +9524,8 @@ $fatpacked{"CPAN/Meta/Spec.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
This field is required. It must contain a Unix-style relative file path
from the root of the distribution directory to a file that contains or
- generates the package.
+ generates the package. It may be given as C<META.yml> or C<META.json>
+ to claim a package for indexing without needing a C<*.pm>.
=item version
@@ -9182,24 +9938,90 @@ $fatpacked{"CPAN/Meta/Spec.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
If the values of C<$mod> and C<$prereq> have not been scrubbed, however,
this presents security implications.
- =head1 SEE ALSO
+ =head2 Prerequisites for dynamically configured distributions
- CPAN, L<http://www.cpan.org/>
+ When C<dynamic_config> is true, it is an error to presume that the
+ prerequisites given in distribution metadata will have any relationship
+ whatsoever to the actual prerequisites of the distribution.
+
+ In practice, however, one can generally expect such prerequisites to be
+ one of two things:
+
+ =over 4
+
+ =item *
+
+ The minimum prerequisites for the distribution, to which dynamic configuration will only add items
+
+ =item *
+
+ Whatever the distribution configured with on the releaser's machine at release time
+
+ =back
+
+ The second case often turns out to have identical results to the first case,
+ albeit only by accident.
+
+ As such, consumers may use this data for informational analysis, but
+ presenting it to the user as canonical or relying on it as such is
+ invariably the height of folly.
+
+ =head2 Indexing distributions a la PAUSE
+
+ While no_index tells you what must be ignored when indexing, this spec holds
+ no opinion on how you should get your initial candidate list of things to
+ possibly index. For "normal" distributions you might consider simply indexing
+ the contents of lib/, but there are many fascinating oddities on CPAN and
+ many dists from the days when it was normal to put the main .pm file in the
+ root of the distribution archive - so PAUSE currently indexes all .pm and .PL
+ files that are not either (a) specifically excluded by no_index (b) in
+ C<inc>, C<xt>, or C<t> directories, or common 'mistake' directories such as
+ C<perl5>.
- CPAN.pm, L<http://search.cpan.org/dist/CPAN/>
+ Or: If you're trying to be PAUSE-like, make sure you skip C<inc>, C<xt> and
+ C<t> as well as anything marked as no_index.
- CPANPLUS, L<http://search.cpan.org/dist/CPANPLUS/>
+ Also remember: If the META file contains a provides field, you shouldn't be
+ indexing anything in the first place - just use that.
- ExtUtils::MakeMaker, L<http://search.cpan.org/dist/ExtUtils-MakeMaker/>
+ =head1 SEE ALSO
+
+ =over 4
+
+ =item *
- Module::Build, L<http://search.cpan.org/dist/Module-Build/>
+ CPAN, L<http://www.cpan.org/>
- Module::Install, L<http://search.cpan.org/dist/Module-Install/>
+ =item *
JSON, L<http://json.org/>
+ =item *
+
YAML, L<http://www.yaml.org/>
+ =item *
+
+ L<CPAN>
+
+ =item *
+
+ L<CPANPLUS>
+
+ =item *
+
+ L<ExtUtils::MakeMaker>
+
+ =item *
+
+ L<Module::Build>
+
+ =item *
+
+ L<Module::Install>
+
+ =back
+
=head1 HISTORY
Ken Williams wrote the original CPAN Meta Spec (also known as the
@@ -9242,8 +10064,26 @@ $fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
use strict;
use warnings;
package CPAN::Meta::Validator;
- our $VERSION = '2.132510'; # VERSION
-
+ # VERSION
+ $CPAN::Meta::Validator::VERSION = '2.142690';
+ #pod =head1 SYNOPSIS
+ #pod
+ #pod my $struct = decode_json_file('META.json');
+ #pod
+ #pod my $cmv = CPAN::Meta::Validator->new( $struct );
+ #pod
+ #pod unless ( $cmv->is_valid ) {
+ #pod my $msg = "Invalid META structure. Errors found:\n";
+ #pod $msg .= join( "\n", $cmv->errors );
+ #pod die $msg;
+ #pod }
+ #pod
+ #pod =head1 DESCRIPTION
+ #pod
+ #pod This module validates a CPAN Meta structure against the version of the
+ #pod the specification claimed in the C<meta-spec> field of the structure.
+ #pod
+ #pod =cut
#--------------------------------------------------------------------------#
# This code copied and adapted from Test::CPAN::Meta
@@ -9318,10 +10158,10 @@ $fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
'2' => {
# REQUIRED
'abstract' => { mandatory => 1, value => \&string },
- 'author' => { mandatory => 1, lazylist => { value => \&string } },
+ 'author' => { mandatory => 1, list => { value => \&string } },
'dynamic_config' => { mandatory => 1, value => \&boolean },
'generated_by' => { mandatory => 1, value => \&string },
- 'license' => { mandatory => 1, lazylist => { value => \&license } },
+ 'license' => { mandatory => 1, list => { value => \&license } },
'meta-spec' => {
mandatory => 1,
'map' => {
@@ -9336,7 +10176,7 @@ $fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
# OPTIONAL
'description' => { value => \&string },
- 'keywords' => { lazylist => { value => \&string } },
+ 'keywords' => { list => { value => \&string } },
'no_index' => $no_index_2,
'optional_features' => {
'map' => {
@@ -9365,7 +10205,7 @@ $fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
},
'resources' => {
'map' => {
- license => { lazylist => { value => \&url } },
+ license => { list => { value => \&url } },
homepage => { value => \&url },
bugtracker => {
'map' => {
@@ -9659,6 +10499,13 @@ $fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
# Code
#--------------------------------------------------------------------------#
+ #pod =method new
+ #pod
+ #pod my $cmv = CPAN::Meta::Validator->new( $struct )
+ #pod
+ #pod The constructor must be passed a metadata structure.
+ #pod
+ #pod =cut
sub new {
my ($class,$data) = @_;
@@ -9666,7 +10513,7 @@ $fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
# create an attributes hash
my $self = {
'data' => $data,
- 'spec' => $data->{'meta-spec'}{'version'} || "1.0",
+ 'spec' => eval { $data->{'meta-spec'}{'version'} } || "1.0",
'errors' => undef,
};
@@ -9674,6 +10521,16 @@ $fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
return bless $self, $class;
}
+ #pod =method is_valid
+ #pod
+ #pod if ( $cmv->is_valid ) {
+ #pod ...
+ #pod }
+ #pod
+ #pod Returns a boolean value indicating whether the metadata provided
+ #pod is valid.
+ #pod
+ #pod =cut
sub is_valid {
my $self = shift;
@@ -9683,6 +10540,13 @@ $fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
return ! $self->errors;
}
+ #pod =method errors
+ #pod
+ #pod warn( join "\n", $cmv->errors );
+ #pod
+ #pod Returns a list of errors seen during validation.
+ #pod
+ #pod =cut
sub errors {
my $self = shift;
@@ -9690,9 +10554,34 @@ $fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
return @{$self->{errors}};
}
+ #pod =begin :internals
+ #pod
+ #pod =head2 Check Methods
+ #pod
+ #pod =over
+ #pod
+ #pod =item *
+ #pod
+ #pod check_map($spec,$data)
+ #pod
+ #pod Checks whether a map (or hash) part of the data structure conforms to the
+ #pod appropriate specification definition.
+ #pod
+ #pod =item *
+ #pod
+ #pod check_list($spec,$data)
+ #pod
+ #pod Checks whether a list (or array) part of the data structure conforms to
+ #pod the appropriate specification definition.
+ #pod
+ #pod =item *
+ #pod
+ #pod =back
+ #pod
+ #pod =cut
my $spec_error = "Missing validation action in specification. "
- . "Must be one of 'map', 'list', 'lazylist', or 'value'";
+ . "Must be one of 'map', 'list', or 'value'";
sub check_map {
my ($self,$spec,$data) = @_;
@@ -9724,8 +10613,6 @@ $fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
$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'" );
}
@@ -9738,8 +10625,6 @@ $fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
$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'" );
}
@@ -9752,17 +10637,6 @@ $fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
}
}
- # 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) = @_;
@@ -9785,8 +10659,6 @@ $fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
$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 {
@@ -9796,6 +10668,113 @@ $fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
}
}
+ #pod =head2 Validator Methods
+ #pod
+ #pod =over
+ #pod
+ #pod =item *
+ #pod
+ #pod header($self,$key,$value)
+ #pod
+ #pod Validates that the header is valid.
+ #pod
+ #pod Note: No longer used as we now read the data structure, not the file.
+ #pod
+ #pod =item *
+ #pod
+ #pod url($self,$key,$value)
+ #pod
+ #pod Validates that a given value is in an acceptable URL format
+ #pod
+ #pod =item *
+ #pod
+ #pod urlspec($self,$key,$value)
+ #pod
+ #pod Validates that the URL to a META specification is a known one.
+ #pod
+ #pod =item *
+ #pod
+ #pod string_or_undef($self,$key,$value)
+ #pod
+ #pod Validates that the value is either a string or an undef value. Bit of a
+ #pod catchall function for parts of the data structure that are completely user
+ #pod defined.
+ #pod
+ #pod =item *
+ #pod
+ #pod string($self,$key,$value)
+ #pod
+ #pod Validates that a string exists for the given key.
+ #pod
+ #pod =item *
+ #pod
+ #pod file($self,$key,$value)
+ #pod
+ #pod Validate that a file is passed for the given key. This may be made more
+ #pod thorough in the future. For now it acts like \&string.
+ #pod
+ #pod =item *
+ #pod
+ #pod exversion($self,$key,$value)
+ #pod
+ #pod Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'.
+ #pod
+ #pod =item *
+ #pod
+ #pod version($self,$key,$value)
+ #pod
+ #pod Validates a single version string. Versions of the type '5.8.8' and '0.00_00'
+ #pod are both valid. A leading 'v' like 'v1.2.3' is also valid.
+ #pod
+ #pod =item *
+ #pod
+ #pod boolean($self,$key,$value)
+ #pod
+ #pod Validates for a boolean value. Currently these values are '1', '0', 'true',
+ #pod 'false', however the latter 2 may be removed.
+ #pod
+ #pod =item *
+ #pod
+ #pod license($self,$key,$value)
+ #pod
+ #pod Validates that a value is given for the license. Returns 1 if an known license
+ #pod type, or 2 if a value is given but the license type is not a recommended one.
+ #pod
+ #pod =item *
+ #pod
+ #pod custom_1($self,$key,$value)
+ #pod
+ #pod Validates that the given key is in CamelCase, to indicate a user defined
+ #pod keyword and only has characters in the class [-_a-zA-Z]. In version 1.X
+ #pod of the spec, this was only explicitly stated for 'resources'.
+ #pod
+ #pod =item *
+ #pod
+ #pod custom_2($self,$key,$value)
+ #pod
+ #pod Validates that the given key begins with 'x_' or 'X_', to indicate a user
+ #pod defined keyword and only has characters in the class [-_a-zA-Z]
+ #pod
+ #pod =item *
+ #pod
+ #pod identifier($self,$key,$value)
+ #pod
+ #pod Validates that key is in an acceptable format for the META specification,
+ #pod for an identifier, i.e. any that matches the regular expression
+ #pod qr/[a-z][a-z_]/i.
+ #pod
+ #pod =item *
+ #pod
+ #pod module($self,$key,$value)
+ #pod
+ #pod Validates that a given key is in an acceptable module name format, e.g.
+ #pod 'Test::CPAN::Meta::Version'.
+ #pod
+ #pod =back
+ #pod
+ #pod =end :internals
+ #pod
+ #pod =cut
sub header {
my ($self,$key,$value) = @_;
@@ -10072,7 +11051,7 @@ $fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
=pod
- =encoding utf-8
+ =encoding UTF-8
=head1 NAME
@@ -10080,7 +11059,7 @@ $fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
=head1 VERSION
- version 2.132510
+ version 2.142690
=head1 SYNOPSIS
@@ -10144,10 +11123,6 @@ $fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
=item *
- check_lazylist($spec,$data)
-
- Checks whether a list conforms, but converts strings to a single-element list
-
=back
=head2 Validator Methods
@@ -10256,7 +11231,7 @@ $fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
=end :internals
- =for Pod::Coverage anything boolean check_lazylist check_list custom_1 custom_2 exversion file
+ =for Pod::Coverage anything boolean check_list custom_1 custom_2 exversion file
identifier license module phase relation release_status string string_or_undef
url urlspec version header check_map
@@ -10294,657 +11269,890 @@ $fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
CPAN_META_VALIDATOR
$fatpacked{"CPAN/Meta/YAML.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_YAML';
+ use 5.008001; # sane UTF-8 support
+ use strict;
+ use warnings;
package CPAN::Meta::YAML;
- {
- $CPAN::Meta::YAML::VERSION = '0.008';
+ $CPAN::Meta::YAML::VERSION = '0.012';
+ BEGIN {
+ $CPAN::Meta::YAML::AUTHORITY = 'cpan:ADAMK';
}
+ # git description: v1.60-1-g1c16a0a
+ ; # original $VERSION removed by Doppelgaenger
+ # XXX-INGY is 5.8.1 too old/broken for utf8?
+ # XXX-XDG Lancaster consensus was that it was sufficient until
+ # proven otherwise
- use strict;
- # UTF Support?
- sub HAVE_UTF8 () { $] >= 5.007003 }
+ #####################################################################
+ # The CPAN::Meta::YAML API.
+ #
+ # These are the currently documented API functions/methods and
+ # exports:
+
+ use Exporter;
+ our @ISA = qw{ Exporter };
+ our @EXPORT = qw{ Load Dump };
+ our @EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };
+
+ ###
+ # Functional/Export API:
+
+ sub Dump {
+ return CPAN::Meta::YAML->new(@_)->_dump_string;
+ }
+
+ # XXX-INGY Returning last document seems a bad behavior.
+ # XXX-XDG I think first would seem more natural, but I don't know
+ # that it's worth changing now
+ sub Load {
+ my $self = CPAN::Meta::YAML->_load_string(@_);
+ if ( wantarray ) {
+ return @$self;
+ } else {
+ # To match YAML.pm, return the last document
+ return $self->[-1];
+ }
+ }
+
+ # XXX-INGY Do we really need freeze and thaw?
+ # XXX-XDG I don't think so. I'd support deprecating them.
BEGIN {
- if ( HAVE_UTF8 ) {
- # The string eval helps hide this from Test::MinimumVersion
- eval "require utf8;";
- die "Failed to load UTF-8 support" if $@;
- }
+ *freeze = \&Dump;
+ *thaw = \&Load;
+ }
- # 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 };
+ sub DumpFile {
+ my $file = shift;
+ return CPAN::Meta::YAML->new(@_)->_dump_file($file);
+ }
+
+ sub LoadFile {
+ my $file = shift;
+ my $self = CPAN::Meta::YAML->_load_file($file);
+ if ( wantarray ) {
+ return @$self;
+ } else {
+ # Return only the last document to match YAML.pm,
+ return $self->[-1];
+ }
+ }
+
+
+ ###
+ # Object Oriented API:
+
+ # Create an empty CPAN::Meta::YAML object
+ # XXX-INGY Why do we use ARRAY object?
+ # NOTE: I get it now, but I think it's confusing and not needed.
+ # Will change it on a branch later, for review.
+ #
+ # XXX-XDG I don't support changing it yet. It's a very well-documented
+ # "API" of CPAN::Meta::YAML. I'd support deprecating it, but Adam suggested
+ # we not change it until YAML.pm's own OO API is established so that
+ # users only have one API change to digest, not two
+ sub new {
+ my $class = shift;
+ bless [ @_ ], $class;
+ }
+
+ # XXX-INGY It probably doesn't matter, and it's probably too late to
+ # change, but 'read/write' are the wrong names. Read and Write
+ # are actions that take data from storage to memory
+ # characters/strings. These take the data to/from storage to native
+ # Perl objects, which the terms dump and load are meant. As long as
+ # this is a legacy quirk to CPAN::Meta::YAML it's ok, but I'd prefer not
+ # to add new {read,write}_* methods to this API.
+
+ sub read_string {
+ my $self = shift;
+ $self->_load_string(@_);
+ }
- # Error storage
- $CPAN::Meta::YAML::errstr = '';
+ sub write_string {
+ my $self = shift;
+ $self->_dump_string(@_);
+ }
+
+ sub read {
+ my $self = shift;
+ $self->_load_file(@_);
+ }
+
+ sub write {
+ my $self = shift;
+ $self->_dump_file(@_);
}
- # 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]';
+
+
+
+ #####################################################################
+ # Constants
# 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
+ 0 x01 x02 x03 x04 x05 x06 a
+ b t n v f r x0E x0F
+ x10 x11 x12 x13 x14 x15 x16 x17
+ x18 x19 x1A e x1C x1D x1E x1F
);
# Printable characters for escapes
my %UNESCAPES = (
- z => "\x00", a => "\x07", t => "\x09",
- n => "\x0a", v => "\x0b", f => "\x0c",
- r => "\x0d", e => "\x1b", '\\' => '\\',
+ 0 => "\x00", z => "\x00", N => "\x85",
+ a => "\x07", b => "\x08", t => "\x09",
+ n => "\x0a", v => "\x0b", f => "\x0c",
+ r => "\x0d", e => "\x1b", '\\' => '\\',
);
- # Special magic boolean words
+ # XXX-INGY
+ # I(ngy) need to decide if these values should be quoted in
+ # CPAN::Meta::YAML or not. Probably yes.
+
+ # These 3 values have special meaning when unquoted and using the
+ # default YAML schema. They need quotes if they are strings.
my %QUOTE = map { $_ => 1 } qw{
- null Null NULL
- y Y yes Yes YES n N no No NO
- true True TRUE false False FALSE
- on On ON off Off OFF
+ null true false
};
+ # The commented out form is simpler, but overloaded the Perl regex
+ # engine due to recursion and backtracking problems on strings
+ # larger than 32,000ish characters. Keep it for reference purposes.
+ # qr/\"((?:\\.|[^\"])*)\"/
+ my $re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;
+ my $re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/;
+ # unquoted re gets trailing space that needs to be stripped
+ my $re_capture_unquoted_key = qr/([^:]+(?::+\S[^:]*)*)(?=\s*\:(?:\s+|$))/;
+ my $re_trailing_comment = qr/(?:\s+\#.*)?/;
+ my $re_key_value_separator = qr/\s*:(?:\s+(?:\#.*)?|$)/;
+
#####################################################################
- # Implementation
+ # CPAN::Meta::YAML Implementation.
+ #
+ # These are the private methods that do all the work. They may change
+ # at any time.
- # Create an empty CPAN::Meta::YAML object
- sub new {
- my $class = shift;
- bless [ @_ ], $class;
- }
+
+ ###
+ # Loader functions:
# 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': $!");
- }
+ sub _load_file {
+ my $class = ref $_[0] ? ref shift : shift;
+
+ # Check the file
+ my $file = shift or $class->_error( 'You did not specify a file name' );
+ $class->_error( "File '$file' does not exist" )
+ unless -e $file;
+ $class->_error( "'$file' is a directory, not a file" )
+ unless -f _;
+ $class->_error( "Insufficient permissions to read '$file'" )
+ unless -r _;
+
+ # Open unbuffered with strict UTF-8 decoding and no translation layers
+ open( my $fh, "<:unix:encoding(UTF-8)", $file );
+ unless ( $fh ) {
+ $class->_error("Failed to open file '$file': $!");
+ }
+
+ # flock if available (or warn if not possible for OS-specific reasons)
+ if ( _can_flock() ) {
+ flock( $fh, Fcntl::LOCK_SH() )
+ or warn "Couldn't lock '$file' for reading: $!";
+ }
+
+ # slurp the contents
+ my $contents = eval {
+ use warnings FATAL => 'utf8';
+ local $/;
+ <$fh>
+ };
+ if ( my $err = $@ ) {
+ $class->_error("Error reading from file '$file': $err");
+ }
+
+ # close the file (release the lock)
+ unless ( close $fh ) {
+ $class->_error("Failed to close file '$file': $!");
+ }
- $class->read_string( $contents );
+ $class->_load_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";
- }
+ sub _load_string {
+ my $class = ref $_[0] ? ref shift : shift;
+ my $self = bless [], $class;
+ my $string = $_[0];
+ eval {
+ unless ( defined $string ) {
+ die \"Did not provide a string to load";
+ }
- # 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;
- }
- }
+ # Check if Perl has it marked as characters, but it's internally
+ # inconsistent. E.g. maybe latin1 got read on a :utf8 layer
+ if ( utf8::is_utf8($string) && ! utf8::valid($string) ) {
+ die \<<'...';
+ Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set).
+ Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"?
+ ...
+ }
- 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($@);
- }
+ # Ensure Unicode character semantics, even for 0x80-0xff
+ utf8::upgrade($string);
- return $self;
- }
+ # Check for and strip any leading UTF-8 BOM
+ $string =~ s/^\x{FEFF}//;
- # Deparse a scalar string to the actual scalar
- sub _read_scalar {
- my ($self, $string, $indent, $lines) = @_;
+ # Check for some special cases
+ return $self unless length $string;
- # Trim trailing whitespace
- $string =~ s/\s*\z//;
+ # Split the file into lines
+ my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
+ split /(?:\015{1,2}\012|\015|\012)/, $string;
- # Explitic null/undef
- return undef if $string eq '~';
+ # Strip the initial YAML header
+ @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
- # Single quote
- if ( $string =~ /^\'(.*?)\'(?:\s+\#.*)?\z/ ) {
- return '' unless defined $1;
- $string = $1;
- $string =~ s/\'\'/\'/g;
- return $string;
- }
+ # A nibbling parser
+ my $in_document = 0;
+ while ( @lines ) {
+ # Do we have a document header?
+ if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
+ # Handle scalar documents
+ shift @lines;
+ if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
+ push @$self,
+ $self->_load_scalar( "$1", [ undef ], \@lines );
+ next;
+ }
+ $in_document = 1;
+ }
- # 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;
- }
+ if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
+ # A naked document
+ push @$self, undef;
+ while ( @lines and $lines[0] !~ /^---/ ) {
+ shift @lines;
+ }
+ $in_document = 0;
+
+ # XXX The final '-+$' is to look for -- which ends up being an
+ # error later.
+ } elsif ( ! $in_document && @$self ) {
+ # only the first document can be explicit
+ die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
+ } elsif ( $lines[0] =~ /^\s*\-(?:\s|$|-+$)/ ) {
+ # An array at the root
+ my $document = [ ];
+ push @$self, $document;
+ $self->_load_array( $document, [ 0 ], \@lines );
+
+ } elsif ( $lines[0] =~ /^(\s*)\S/ ) {
+ # A hash at the root
+ my $document = { };
+ push @$self, $document;
+ $self->_load_hash( $document, [ length($1) ], \@lines );
- # 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;
- }
+ } else {
+ # Shouldn't get here. @lines have whitespace-only lines
+ # stripped, and previous match is a line with any
+ # non-whitespace. So this clause should only be reachable via
+ # a perlbug where \s is not symmetric with \S
- # Error
- die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines;
+ # uncoverable statement
+ die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
+ }
+ }
+ };
+ if ( ref $@ eq 'SCALAR' ) {
+ $self->_error(${$@});
+ } elsif ( $@ ) {
+ $self->_error($@);
+ }
- # 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]'";
- }
+ return $self;
+ }
- # Pull the lines
- my @multiline = ();
- while ( @$lines ) {
- $lines->[0] =~ /^(\s*)/;
- last unless length($1) >= $indent->[-1];
- push @multiline, substr(shift(@$lines), length($1));
- }
+ sub _unquote_single {
+ my ($self, $string) = @_;
+ return '' unless length $string;
+ $string =~ s/\'\'/\'/g;
+ return $string;
+ }
- my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
- my $t = (substr($string, 1, 1) eq '-') ? '' : "\n";
- return join( $j, @multiline ) . $t;
+ sub _unquote_double {
+ my ($self, $string) = @_;
+ return '' unless length $string;
+ $string =~ s/\\"/"/g;
+ $string =~
+ s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))}
+ {(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex;
+ return $string;
}
- # Parse an array
- sub _read_array {
- my ($self, $array, $indent, $lines) = @_;
+ # Load a YAML scalar string to the actual Perl scalar
+ sub _load_scalar {
+ my ($self, $string, $indent, $lines) = @_;
- while ( @$lines ) {
- # Check for a new document
- if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
- while ( @$lines and $lines->[0] !~ /^---/ ) {
- shift @$lines;
- }
- return 1;
- }
+ # Trim trailing whitespace
+ $string =~ s/\s*\z//;
- # 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]'";
- }
+ # Explitic null/undef
+ return undef if $string eq '~';
- 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]'";
- }
+ # Single quote
+ if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) {
+ return $self->_unquote_single($1);
+ }
- } 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]'";
- }
- }
+ # Double quote.
+ if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) {
+ return $self->_unquote_double($1);
+ }
- return 1;
- }
+ # Special cases
+ if ( $string =~ /^[\'\"!&]/ ) {
+ die \"CPAN::Meta::YAML does not support a feature in line '$string'";
+ }
+ return {} if $string =~ /^{}(?:\s+\#.*)?\z/;
+ return [] if $string =~ /^\[\](?:\s+\#.*)?\z/;
- # Parse an array
- sub _read_hash {
- my ($self, $hash, $indent, $lines) = @_;
+ # Regular unquoted string
+ if ( $string !~ /^[>|]/ ) {
+ die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'"
+ if $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or
+ $string =~ /:(?:\s|$)/;
+ $string =~ s/\s+#.*\z//;
+ return $string;
+ }
- while ( @$lines ) {
- # Check for a new document
- if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
- while ( @$lines and $lines->[0] !~ /^---/ ) {
- shift @$lines;
- }
- return 1;
- }
+ # Error
+ die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines;
- # 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]'";
- }
+ # 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]'";
+ }
- # 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 );
- }
- }
- }
- }
+ # Pull the lines
+ my @multiline = ();
+ while ( @$lines ) {
+ $lines->[0] =~ /^(\s*)/;
+ last unless length($1) >= $indent->[-1];
+ push @multiline, substr(shift(@$lines), length($1));
+ }
- return 1;
+ my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
+ my $t = (substr($string, 1, 1) eq '-') ? '' : "\n";
+ return join( $j, @multiline ) . $t;
}
- # Save an object to a file
- sub write {
- my $self = shift;
- my $file = shift or return $self->_error('No file name provided');
+ # Load an array
+ sub _load_array {
+ my ($self, $array, $indent, $lines) = @_;
- # 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;
+ while ( @$lines ) {
+ # Check for a new document
+ if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
+ while ( @$lines and $lines->[0] !~ /^---/ ) {
+ shift @$lines;
+ }
+ return 1;
+ }
- 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]'";
+ }
- # 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, {} );
+ if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
+ # Inline nested hash
+ my $indent2 = length("$1");
+ $lines->[0] =~ s/-/ /;
+ push @$array, { };
+ $self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
+
+ } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
+ shift @$lines;
+ unless ( @$lines ) {
+ push @$array, undef;
+ return 1;
+ }
+ if ( $lines->[0] =~ /^(\s*)\-/ ) {
+ my $indent2 = length("$1");
+ if ( $indent->[-1] == $indent2 ) {
+ # Null array entry
+ push @$array, undef;
+ } else {
+ # Naked indenter
+ push @$array, [ ];
+ $self->_load_array(
+ $array->[-1], [ @$indent, $indent2 ], $lines
+ );
+ }
- # A hash at the root
- } elsif ( ref $cursor eq 'HASH' ) {
- unless ( %$cursor ) {
- $lines[-1] .= ' {}';
- next;
- }
- push @lines, $self->_write_hash( $cursor, $indent, {} );
+ } elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
+ push @$array, { };
+ $self->_load_hash(
+ $array->[-1], [ @$indent, length("$1") ], $lines
+ );
- } else {
- Carp::croak("Cannot serialize " . ref($cursor));
- }
- }
+ } else {
+ die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
+ }
+
+ } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
+ # Array entry with a value
+ shift @$lines;
+ push @$array, $self->_load_scalar(
+ "$2", [ @$indent, undef ], $lines
+ );
+
+ } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
+ # This is probably a structure like the following...
+ # ---
+ # foo:
+ # - list
+ # bar: value
+ #
+ # ... so lets return and let the hash parser handle it
+ return 1;
+
+ } else {
+ die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
+ }
+ }
- join '', map { "$_\n" } @lines;
+ return 1;
}
- 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;
+ # Load a hash
+ sub _load_hash {
+ my ($self, $hash, $indent, $lines) = @_;
+
+ while ( @$lines ) {
+ # Check for a new document
+ if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
+ while ( @$lines and $lines->[0] !~ /^---/ ) {
+ shift @$lines;
+ }
+ return 1;
+ }
+
+ # Check the indent level
+ $lines->[0] =~ /^(\s*)/;
+ if ( length($1) < $indent->[-1] ) {
+ return 1;
+ } elsif ( length($1) > $indent->[-1] ) {
+ die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
+ }
+
+ # Find the key
+ my $key;
+
+ # Quoted keys
+ if ( $lines->[0] =~
+ s/^\s*$re_capture_single_quoted$re_key_value_separator//
+ ) {
+ $key = $self->_unquote_single($1);
+ }
+ elsif ( $lines->[0] =~
+ s/^\s*$re_capture_double_quoted$re_key_value_separator//
+ ) {
+ $key = $self->_unquote_double($1);
+ }
+ elsif ( $lines->[0] =~
+ s/^\s*$re_capture_unquoted_key$re_key_value_separator//
+ ) {
+ $key = $1;
+ $key =~ s/\s+$//;
+ }
+ elsif ( $lines->[0] =~ /^\s*\?/ ) {
+ die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'";
+ }
+ else {
+ die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
+ }
+
+ # Do we have a value?
+ if ( length $lines->[0] ) {
+ # Yes
+ $hash->{$key} = $self->_load_scalar(
+ shift(@$lines), [ @$indent, undef ], $lines
+ );
+ } else {
+ # An indent
+ shift @$lines;
+ unless ( @$lines ) {
+ $hash->{$key} = undef;
+ return 1;
+ }
+ if ( $lines->[0] =~ /^(\s*)-/ ) {
+ $hash->{$key} = [];
+ $self->_load_array(
+ $hash->{$key}, [ @$indent, length($1) ], $lines
+ );
+ } elsif ( $lines->[0] =~ /^(\s*)./ ) {
+ my $indent2 = length("$1");
+ if ( $indent->[-1] >= $indent2 ) {
+ # Null hash entry
+ $hash->{$key} = undef;
+ } else {
+ $hash->{$key} = {};
+ $self->_load_hash(
+ $hash->{$key}, [ @$indent, length($1) ], $lines
+ );
+ }
+ }
+ }
+ }
+
+ return 1;
}
- 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;
- }
+ ###
+ # Dumper functions:
- } else {
- die "CPAN::Meta::YAML does not support $type references";
- }
- }
+ # Save an object to a file
+ sub _dump_file {
+ my $self = shift;
+
+ require Fcntl;
+
+ # Check the file
+ my $file = shift or $self->_error( 'You did not specify a file name' );
+
+ my $fh;
+ # flock if available (or warn if not possible for OS-specific reasons)
+ if ( _can_flock() ) {
+ # Open without truncation (truncate comes after lock)
+ my $flags = Fcntl::O_WRONLY()|Fcntl::O_CREAT();
+ sysopen( $fh, $file, $flags );
+ unless ( $fh ) {
+ $self->_error("Failed to open file '$file' for writing: $!");
+ }
+
+ # Use no translation and strict UTF-8
+ binmode( $fh, ":raw:encoding(UTF-8)");
+
+ flock( $fh, Fcntl::LOCK_EX() )
+ or warn "Couldn't lock '$file' for reading: $!";
+
+ # truncate and spew contents
+ truncate $fh, 0;
+ seek $fh, 0, 0;
+ }
+ else {
+ open $fh, ">:unix:encoding(UTF-8)", $file;
+ }
+
+ # serialize and spew to the handle
+ print {$fh} $self->_dump_string;
+
+ # close the file (release the lock)
+ unless ( close $fh ) {
+ $self->_error("Failed to close file '$file': $!");
+ }
- @lines;
+ return 1;
}
- 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;
- }
+ # Save an object to a string
+ sub _dump_string {
+ my $self = shift;
+ return '' unless ref $self && @$self;
- } elsif ( $type eq 'HASH' ) {
- if ( keys %$el ) {
- push @lines, $line;
- push @lines, $self->_write_hash( $el, $indent + 1, $seen );
- } else {
- $line .= ' {}';
- push @lines, $line;
- }
+ # Iterate over the documents
+ my $indent = 0;
+ my @lines = ();
- } else {
- die "CPAN::Meta::YAML does not support $type references";
- }
- }
+ eval {
+ foreach my $cursor ( @$self ) {
+ push @lines, '---';
+
+ # An empty document
+ if ( ! defined $cursor ) {
+ # Do nothing
+
+ # A scalar document
+ } elsif ( ! ref $cursor ) {
+ $lines[-1] .= ' ' . $self->_dump_scalar( $cursor );
+
+ # A list at the root
+ } elsif ( ref $cursor eq 'ARRAY' ) {
+ unless ( @$cursor ) {
+ $lines[-1] .= ' []';
+ next;
+ }
+ push @lines, $self->_dump_array( $cursor, $indent, {} );
+
+ # A hash at the root
+ } elsif ( ref $cursor eq 'HASH' ) {
+ unless ( %$cursor ) {
+ $lines[-1] .= ' {}';
+ next;
+ }
+ push @lines, $self->_dump_hash( $cursor, $indent, {} );
+
+ } else {
+ die \("Cannot serialize " . ref($cursor));
+ }
+ }
+ };
+ if ( ref $@ eq 'SCALAR' ) {
+ $self->_error(${$@});
+ } elsif ( $@ ) {
+ $self->_error($@);
+ }
- @lines;
+ join '', map { "$_\n" } @lines;
}
- # Set error
- sub _error {
- $CPAN::Meta::YAML::errstr = $_[1];
- undef;
+ sub _has_internal_string_value {
+ my $value = shift;
+ my $b_obj = B::svref_2object(\$value); # for round trip problem
+ return $b_obj->FLAGS & B::SVf_POK();
+ }
+
+ sub _dump_scalar {
+ my $string = $_[1];
+ my $is_key = $_[2];
+ # Check this before checking length or it winds up looking like a string!
+ my $has_string_flag = _has_internal_string_value($string);
+ return '~' unless defined $string;
+ return "''" unless length $string;
+ if (Scalar::Util::looks_like_number($string)) {
+ # keys and values that have been used as strings get quoted
+ if ( $is_key || $has_string_flag ) {
+ return qq['$string'];
+ }
+ else {
+ return $string;
+ }
+ }
+ if ( $string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/ ) {
+ $string =~ s/\\/\\\\/g;
+ $string =~ s/"/\\"/g;
+ $string =~ s/\n/\\n/g;
+ $string =~ s/[\x85]/\\N/g;
+ $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
+ $string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge;
+ return qq|"$string"|;
+ }
+ if ( $string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or
+ $QUOTE{$string}
+ ) {
+ return "'$string'";
+ }
+ return $string;
}
- # Retrieve error
- sub errstr {
- $CPAN::Meta::YAML::errstr;
+ sub _dump_array {
+ my ($self, $array, $indent, $seen) = @_;
+ if ( $seen->{refaddr($array)}++ ) {
+ die \"CPAN::Meta::YAML does not support circular references";
+ }
+ my @lines = ();
+ foreach my $el ( @$array ) {
+ my $line = (' ' x $indent) . '-';
+ my $type = ref $el;
+ if ( ! $type ) {
+ $line .= ' ' . $self->_dump_scalar( $el );
+ push @lines, $line;
+
+ } elsif ( $type eq 'ARRAY' ) {
+ if ( @$el ) {
+ push @lines, $line;
+ push @lines, $self->_dump_array( $el, $indent + 1, $seen );
+ } else {
+ $line .= ' []';
+ push @lines, $line;
+ }
+
+ } elsif ( $type eq 'HASH' ) {
+ if ( keys %$el ) {
+ push @lines, $line;
+ push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
+ } else {
+ $line .= ' {}';
+ push @lines, $line;
+ }
+
+ } else {
+ die \"CPAN::Meta::YAML does not support $type references";
+ }
+ }
+
+ @lines;
}
+ sub _dump_hash {
+ my ($self, $hash, $indent, $seen) = @_;
+ if ( $seen->{refaddr($hash)}++ ) {
+ die \"CPAN::Meta::YAML does not support circular references";
+ }
+ my @lines = ();
+ foreach my $name ( sort keys %$hash ) {
+ my $el = $hash->{$name};
+ my $line = (' ' x $indent) . $self->_dump_scalar($name, 1) . ":";
+ my $type = ref $el;
+ if ( ! $type ) {
+ $line .= ' ' . $self->_dump_scalar( $el );
+ push @lines, $line;
+
+ } elsif ( $type eq 'ARRAY' ) {
+ if ( @$el ) {
+ push @lines, $line;
+ push @lines, $self->_dump_array( $el, $indent + 1, $seen );
+ } else {
+ $line .= ' []';
+ push @lines, $line;
+ }
+
+ } elsif ( $type eq 'HASH' ) {
+ if ( keys %$el ) {
+ push @lines, $line;
+ push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
+ } else {
+ $line .= ' {}';
+ push @lines, $line;
+ }
+
+ } else {
+ die \"CPAN::Meta::YAML does not support $type references";
+ }
+ }
+ @lines;
+ }
#####################################################################
- # YAML Compatibility
+ # DEPRECATED API methods:
- sub Dump {
- CPAN::Meta::YAML->new(@_)->write_string;
- }
+ # Error storage (DEPRECATED as of 1.57)
+ our $errstr = '';
- 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];
- }
+ # Set error
+ sub _error {
+ require Carp;
+ $errstr = $_[1];
+ $errstr =~ s/ at \S+ line \d+.*//;
+ Carp::croak( $errstr );
}
- BEGIN {
- *freeze = *Dump;
- *thaw = *Load;
+ # Retrieve error
+ my $errstr_warned;
+ sub errstr {
+ require Carp;
+ Carp::carp( "CPAN::Meta::YAML->errstr and \$CPAN::Meta::YAML::errstr is deprecated" )
+ unless $errstr_warned++;
+ $errstr;
}
- 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];
- }
- }
+ #####################################################################
+ # Helper functions. Possibly not needed.
+
+
+ # Use to detect nv or iv
+ use B;
+ # XXX-INGY Is flock CPAN::Meta::YAML's responsibility?
+ # Some platforms can't flock :-(
+ # XXX-XDG I think it is. When reading and writing files, we ought
+ # to be locking whenever possible. People (foolishly) use YAML
+ # files for things like session storage, which has race issues.
+ my $HAS_FLOCK;
+ sub _can_flock {
+ if ( defined $HAS_FLOCK ) {
+ return $HAS_FLOCK;
+ }
+ else {
+ require Config;
+ my $c = \%Config::Config;
+ $HAS_FLOCK = grep { $c->{$_} } qw/d_flock d_fcntl_can_lock d_lockf/;
+ require Fcntl if $HAS_FLOCK;
+ return $HAS_FLOCK;
+ }
+ }
+ # XXX-INGY Is this core in 5.8.1? Can we remove this?
+ # XXX-XDG Scalar::Util 1.18 didn't land until 5.8.8, so we need this
#####################################################################
# Use Scalar::Util if possible, otherwise emulate it
BEGIN {
- local $@;
- eval {
- require Scalar::Util;
- };
- my $v = eval("$Scalar::Util::VERSION") || 0;
- if ( $@ or $v < 1.18 ) {
- eval <<'END_PERL';
+ local $@;
+ if ( eval { require Scalar::Util }
+ && $Scalar::Util::VERSION
+ && eval($Scalar::Util::VERSION) >= 1.18
+ ) {
+ *refaddr = *Scalar::Util::refaddr;
+ }
+ else {
+ eval <<'END_PERL';
# Scalar::Util failed to load or too old
sub refaddr {
- my $pkg = ref($_[0]) or return undef;
- if ( !! UNIVERSAL::can($_[0], 'can') ) {
- bless $_[0], 'Scalar::Util::Fake';
- } else {
- $pkg = undef;
- }
- "$_[0]" =~ /0x(\w+)/;
- my $i = do { local $^W; hex $1 };
- bless $_[0], $pkg if defined $pkg;
- $i;
+ my $pkg = ref($_[0]) or return undef;
+ if ( !! UNIVERSAL::can($_[0], 'can') ) {
+ bless $_[0], 'Scalar::Util::Fake';
+ } else {
+ $pkg = undef;
+ }
+ "$_[0]" =~ /0x(\w+)/;
+ my $i = do { no warnings 'portable'; hex $1 };
+ bless $_[0], $pkg if defined $pkg;
+ $i;
}
END_PERL
- } else {
- *refaddr = *Scalar::Util::refaddr;
- }
+ }
}
- 1;
+ 1;
+
+ # XXX-INGY Doc notes I'm putting up here. Changing the doc when it's wrong
+ # but leaving grey area stuff up here.
+ #
+ # I would like to change Read/Write to Load/Dump below without
+ # changing the actual API names.
+ #
+ # It might be better to put Load/Dump API in the SYNOPSIS instead of the
+ # dubious OO API.
+ #
+ # null and bool explanations may be outdated.
+
=pod
+ =encoding UTF-8
+
=head1 NAME
CPAN::Meta::YAML - Read and write a subset of YAML for CPAN Meta files
=head1 VERSION
- version 0.008
+ version 0.012
=head1 SYNOPSIS
@@ -10980,7 +12188,7 @@ $fatpacked{"CPAN/Meta/YAML.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
This module is currently derived from L<YAML::Tiny> by Adam Kennedy. If
there are bugs in how it parses a particular META.yml file, please file
a bug report in the YAML::Tiny bugtracker:
- L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=YAML-Tiny>
+ L<https://rt.cpan.org/Public/Dist/Display.html?Name=YAML-Tiny>
=head1 SEE ALSO
@@ -10993,7 +12201,7 @@ $fatpacked{"CPAN/Meta/YAML.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
=head2 Bugs / Feature Requests
Please report any bugs or feature requests through the issue tracker
- at L<http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta-YAML>.
+ at L<https://github.com/dagolden/CPAN-Meta-YAML/issues>.
You will be notified automatically of any progress on your issue.
=head2 Source Code
@@ -11001,9 +12209,9 @@ $fatpacked{"CPAN/Meta/YAML.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
This is open source software. The code repository is available for
public review and contribution under the terms of the license.
- L<https://github.com/dagolden/cpan-meta-yaml>
+ L<https://github.com/dagolden/CPAN-Meta-YAML>
- git clone https://github.com/dagolden/cpan-meta-yaml.git
+ git clone https://github.com/dagolden/CPAN-Meta-YAML.git
=head1 AUTHORS
@@ -11028,7 +12236,6 @@ $fatpacked{"CPAN/Meta/YAML.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
=cut
-
__END__
@@ -11049,7 +12256,7 @@ $fatpacked{"Exporter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORT
our $Debug = 0;
our $ExportLevel = 0;
our $Verbose ||= 0;
- our $VERSION = '5.68';
+ our $VERSION = '5.70';
our (%Cache);
sub as_heavy {
@@ -11320,7 +12527,7 @@ $fatpacked{"Exporter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORT
package A;
@ISA = qw(Exporter);
- @EXPORT_OK = qw ($b);
+ @EXPORT_OK = qw($b);
sub import
{
@@ -11334,7 +12541,7 @@ $fatpacked{"Exporter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORT
package A;
@ISA = qw(Exporter);
- @EXPORT_OK = qw ($b);
+ @EXPORT_OK = qw($b);
sub import
{
@@ -11352,10 +12559,10 @@ $fatpacked{"Exporter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORT
By including Exporter in your C<@ISA> you inherit an Exporter's import() method
but you also inherit several other helper methods which you probably don't
- want. To avoid this you can do
+ want. To avoid this you can do:
package YourModule;
- use Exporter qw( import );
+ use Exporter qw(import);
which will export Exporter's own import() method into YourModule.
Everything will work as before but you won't need to include Exporter in
@@ -11511,7 +12718,7 @@ $fatpacked{"Exporter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORT
There are some caveats with the use of runtime statements
like C<require Exporter> and the assignment to package
- variables, which can very subtle for the unaware programmer.
+ variables, which can be very subtle for the unaware programmer.
This may happen for instance with mutually recursive
modules, which are affected by the time the relevant
constructions are executed.
@@ -11540,9 +12747,9 @@ $fatpacked{"Exporter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORT
With respect to loading C<Exporter> and inheriting, there
are alternatives with the use of modules like C<base> and C<parent>.
- use base qw( Exporter );
+ use base qw(Exporter);
# or
- use parent qw( Exporter );
+ use parent qw(Exporter);
Any of these statements are nice replacements for
C<BEGIN { require Exporter; @ISA = qw(Exporter); }>
@@ -11593,11 +12800,11 @@ $fatpacked{"Exporter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORT
export variable names. Just because C<Exporter> lets you
do that, it does not mean you should.
- @EXPORT_OK = qw( $svar @avar %hvar ); # DON'T!
+ @EXPORT_OK = qw($svar @avar %hvar); # DON'T!
Exporting variables is not a good idea. They can
change under the hood, provoking horrible
- effects at-a-distance, that are too hard to track
+ effects at-a-distance that are too hard to track
and to fix. Trust me: they are not worth it.
To provide the capability to set/get class-wide
@@ -11609,7 +12816,7 @@ $fatpacked{"Exporter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORT
C<Exporter> is definitely not the only module with
symbol exporter capabilities. At CPAN, you may find
a bunch of them. Some are lighter. Some
- provide improved APIs and features. Peek the one
+ provide improved APIs and features. Pick the one
that fits your needs. The following is
a sample list of such modules.
@@ -11672,8 +12879,13 @@ $fatpacked{"Exporter/Heavy.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
sub heavy_export {
+ # Save the old __WARN__ handler in case it was defined
+ my $oldwarn = $SIG{__WARN__};
+
# First make import warnings look like they're coming from the "use".
local $SIG{__WARN__} = sub {
+ # restore it back so proper stacking occurs
+ local $SIG{__WARN__} = $oldwarn;
my $text = shift;
if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) {
require Carp;
@@ -11885,30 +13097,31 @@ EXPORTER_HEAVY
$fatpacked{"File/pushd.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE_PUSHD';
use strict;
use warnings;
+
package File::pushd;
# ABSTRACT: change directory temporarily for a limited scope
- our $VERSION = '1.005'; # VERSION
+ our $VERSION = '1.009'; # VERSION
- our @EXPORT = qw( pushd tempd );
- our @ISA = qw( Exporter );
+ 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 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;
+ q{""} => sub { File::Spec->canonpath( $_[0]->{_pushd} ) },
+ fallback => 1;
#--------------------------------------------------------------------------#
# pushd()
#--------------------------------------------------------------------------#
sub pushd {
- my ($target_dir, $options) = @_;
+ my ( $target_dir, $options ) = @_;
$options->{untaint_pattern} ||= qr{^([-+@\w./]+)$};
$target_dir = "." unless defined $target_dir;
@@ -11917,32 +13130,33 @@ $fatpacked{"File/pushd.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE
my $tainted_orig = getcwd;
my $orig;
if ( $tainted_orig =~ $options->{untaint_pattern} ) {
- $orig = $1;
+ $orig = $1;
}
else {
- $orig = $tainted_orig;
+ $orig = $tainted_orig;
}
my $tainted_dest;
- eval { $tainted_dest = $target_dir ? abs_path( $target_dir ) : $orig };
+ 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;
+ $dest = $1;
}
else {
- $dest = $tainted_dest;
+ $dest = $tainted_dest;
}
- if ($dest ne $orig) {
+ if ( $dest ne $orig ) {
chdir $dest or croak "Can't chdir to $dest\: $!";
}
my $self = bless {
- _pushd => $dest,
+ _pushd => $dest,
_original => $orig
- }, __PACKAGE__;
+ },
+ __PACKAGE__;
return $self;
}
@@ -11966,7 +13180,7 @@ $fatpacked{"File/pushd.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE
sub preserve {
my $self = shift;
- return 1 if ! $self->{"_tempd"};
+ return 1 if !$self->{"_tempd"};
if ( @_ == 0 ) {
return $self->{_preserve} = 1;
}
@@ -11985,8 +13199,9 @@ $fatpacked{"File/pushd.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE
my ($self) = @_;
my $orig = $self->{_original};
chdir $orig if $orig; # should always be so, but just in case...
- if ( $self->{_tempd} &&
- !$self->{_preserve} ) {
+ if ( $self->{_tempd}
+ && !$self->{_preserve} )
+ {
# don't destroy existing $@ if there is no error.
my $err = do {
local $@;
@@ -11999,49 +13214,49 @@ $fatpacked{"File/pushd.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE
1;
- __END__
-
=pod
+ =encoding UTF-8
+
=head1 NAME
File::pushd - change directory temporarily for a limited scope
=head1 VERSION
- version 1.005
+ version 1.009
=head1 SYNOPSIS
- use File::pushd;
-
- chdir $ENV{HOME};
-
- # change directory again for a limited scope
- {
- my $dir = pushd( '/tmp' );
- # working directory changed to /tmp
- }
- # working directory has reverted to $ENV{HOME}
-
- # tempd() is equivalent to pushd( File::Temp::tempdir )
- {
- my $dir = tempd();
- }
-
- # object stringifies naturally as an absolute path
- {
+ use File::pushd;
+
+ chdir $ENV{HOME};
+
+ # change directory again for a limited scope
+ {
my $dir = pushd( '/tmp' );
- my $filename = File::Spec->catfile( $dir, "somefile.txt" );
- # gives /tmp/somefile.txt
- }
+ # working directory changed to /tmp
+ }
+ # working directory has reverted to $ENV{HOME}
+
+ # tempd() is equivalent to pushd( File::Temp::tempdir )
+ {
+ my $dir = tempd();
+ }
+
+ # object stringifies naturally as an absolute path
+ {
+ my $dir = pushd( '/tmp' );
+ my $filename = File::Spec->catfile( $dir, "somefile.txt" );
+ # gives /tmp/somefile.txt
+ }
=head1 DESCRIPTION
- File::pushd does a temporary C<<< chdir >>> that is easily and automatically
- reverted, similar to C<<< pushd >>> in some Unix command shells. It works by
+ File::pushd does a temporary C<chdir> that is easily and automatically
+ reverted, similar to C<pushd> in some Unix command shells. It works by
creating an object that caches the original working directory. When the object
- is destroyed, the destructor calls C<<< chdir >>> to revert to the original working
+ is destroyed, the destructor calls C<chdir> to revert to the original working
directory. By storing the object in a lexical variable with a limited scope,
this happens automatically at the end of the scope.
@@ -12052,19 +13267,23 @@ $fatpacked{"File/pushd.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE
For convenience, the object stringifies as the canonical form of the absolute
pathname of the directory entered.
+ B<Warning>: if you create multiple C<pushd> objects in the same lexical scope,
+ their destruction order is not guaranteed and you might not wind up in the
+ directory you expect.
+
=head1 USAGE
- use File::pushd;
+ use File::pushd;
- Using File::pushd automatically imports the C<<< pushd >>> and C<<< tempd >>> functions.
+ Using File::pushd automatically imports the C<pushd> and C<tempd> functions.
=head2 pushd
- {
- my $dir = pushd( $target_directory );
- }
+ {
+ my $dir = pushd( $target_directory );
+ }
- Caches the current working directory, calls C<<< chdir >>> to change to the target
+ Caches the current working directory, calls C<chdir> to change to the target
directory, and returns a File::pushd object. When the object is
destroyed, the working directory reverts to the original directory.
@@ -12073,52 +13292,52 @@ $fatpacked{"File/pushd.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE
returns to the current directory when the object is destroyed.
If the target directory does not exist or if the directory change fails
- for some reason, C<<< pushd >>> will die with an error message.
+ for some reason, C<pushd> will die with an error message.
Can be given a hashref as an optional second argument. The only supported
- option is C<<< untaint_pattern >>>, which is used to untaint file paths involved.
- It defaults to C<<< qr{^([-+@\w./]+)$} >>>, which is reasonably restrictive (e.g.
+ option is C<untaint_pattern>, which is used to untaint file paths involved.
+ It defaults to {qr{^(L<-+@\w./>+)$}}, which is reasonably restrictive (e.g.
it does not even allow spaces in the path). Change this to suit your
- circumstances and security needs if running under taint mode. B<Note>: you
+ circumstances and security needs if running under taint mode. *Note*: you
must include the parentheses in the pattern to capture the untainted
portion of the path.
=head2 tempd
- {
- my $dir = tempd();
- }
+ {
+ my $dir = tempd();
+ }
- This function is like C<<< pushd >>> but automatically creates and calls C<<< chdir >>> to
+ This function is like C<pushd> but automatically creates and calls C<chdir> to
a temporary directory created by L<File::Temp>. Unlike normal L<File::Temp>
cleanup which happens at the end of the program, this temporary directory is
- removed when the object is destroyed. (But also see C<<< preserve >>>.) A warning
+ removed when the object is destroyed. (But also see C<preserve>.) A warning
will be issued if the directory cannot be removed.
- As with C<<< pushd >>>, C<<< tempd >>> will die if C<<< chdir >>> fails.
+ As with C<pushd>, C<tempd> will die if C<chdir> fails.
It may be given a single options hash that will be passed internally
- to CE<lt>pushdE<gt>.
+ to C<pushd>.
=head2 preserve
- {
- my $dir = tempd();
- $dir->preserve; # mark to preserve at end of scope
- $dir->preserve(0); # mark to delete at end of scope
- }
+ {
+ my $dir = tempd();
+ $dir->preserve; # mark to preserve at end of scope
+ $dir->preserve(0); # mark to delete at end of scope
+ }
Controls whether a temporary directory will be cleaned up when the object is
- destroyed. With no arguments, C<<< preserve >>> sets the directory to be preserved.
+ destroyed. With no arguments, C<preserve> sets the directory to be preserved.
With an argument, the directory will be preserved if the argument is true, or
- marked for cleanup if the argument is false. Only C<<< tempd >>> objects may be
- marked for cleanup. (Target directories to C<<< pushd >>> are always preserved.)
- C<<< preserve >>> returns true if the directory will be preserved, and false
+ marked for cleanup if the argument is false. Only C<tempd> objects may be
+ marked for cleanup. (Target directories to C<pushd> are always preserved.)
+ C<preserve> returns true if the directory will be preserved, and false
otherwise.
=head1 SEE ALSO
- =over
+ =over 4
=item *
@@ -12133,7 +13352,7 @@ $fatpacked{"File/pushd.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE
=head2 Bugs / Feature Requests
Please report any bugs or feature requests through the issue tracker
- at L<https://github.com/dagolden/file-pushd/issues>.
+ at L<https://github.com/dagolden/File-pushd/issues>.
You will be notified automatically of any progress on your issue.
=head2 Source Code
@@ -12141,27 +13360,42 @@ $fatpacked{"File/pushd.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE
This is open source software. The code repository is available for
public review and contribution under the terms of the license.
- L<https://github.com/dagolden/file-pushd>
+ L<https://github.com/dagolden/File-pushd>
- git clone git://github.com/dagolden/file-pushd.git
+ git clone https://github.com/dagolden/File-pushd.git
=head1 AUTHOR
David Golden <dagolden@cpan.org>
- =head1 CONTRIBUTOR
+ =head1 CONTRIBUTORS
+
+ =over 4
+
+ =item *
Diab Jerius <djerius@cfa.harvard.edu>
+ =item *
+
+ Graham Ollis <plicease@cpan.org>
+
+ =back
+
=head1 COPYRIGHT AND LICENSE
- This software is Copyright (c) 2013 by David A Golden.
+ This software is Copyright (c) 2014 by David A Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
+
+ __END__
+
+
+ # vim: ts=4 sts=4 sw=4 et:
FILE_PUSHD
$fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINY';
@@ -12170,60 +13404,63 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
use strict;
use warnings;
# ABSTRACT: A small, simple, correct HTTP/1.1 client
- our $VERSION = '0.043'; # VERSION
+ our $VERSION = '0.050'; # VERSION
use Carp ();
- # =method new
- #
- # $http = HTTP::Tiny->new( %attributes );
- #
- # This constructor returns a new HTTP::Tiny object. Valid attributes include:
- #
- # =for :list
- # * C<agent>
- # A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C<agent> ends in a space character, the default user-agent string is appended.
- # * C<cookie_jar>
- # An instance of L<HTTP::CookieJar> or equivalent class that supports the C<add> and C<cookie_header> methods
- # * C<default_headers>
- # A hashref of default headers to apply to requests
- # * C<local_address>
- # The local IP address to bind to
- # * C<keep_alive>
- # Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1)
- # * C<max_redirect>
- # Maximum number of redirects allowed (defaults to 5)
- # * C<max_size>
- # Maximum response size (only when not using a data callback). If defined, responses larger than this will return an exception.
- # * C<http_proxy>
- # URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> if set)
- # * C<https_proxy>
- # URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> if set)
- # * C<proxy>
- # URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> if set)
- # * C<no_proxy>
- # List of domain suffixes that should not be proxied. Must be a comma-separated string or an array reference. (default is C<$ENV{no_proxy}>)
- # * C<timeout>
- # Request timeout in seconds (default is 60)
- # * C<verify_SSL>
- # A boolean that indicates whether to validate the SSL certificate of an C<https>
- # connection (default is false)
- # * C<SSL_options>
- # A hashref of C<SSL_*> options to pass through to L<IO::Socket::SSL>
- #
- # Exceptions from C<max_size>, C<timeout> or other errors will result in a
- # pseudo-HTTP status code of 599 and a reason of "Internal Exception". The
- # content field in the response will contain the text of the exception.
- #
- # The C<keep_alive> parameter enables a persistent connection, but only to a
- # single destination scheme, host and port. Also, if any connection-relevant
- # attributes are modified, a persistent connection will be dropped. If you want
- # persistent connections across multiple destinations, use multiple HTTP::Tiny
- # objects.
- #
- # See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.
- #
- # =cut
+ #pod =method new
+ #pod
+ #pod $http = HTTP::Tiny->new( %attributes );
+ #pod
+ #pod This constructor returns a new HTTP::Tiny object. Valid attributes include:
+ #pod
+ #pod =for :list
+ #pod * C<agent> —
+ #pod A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C<agent> — ends in a space character, the default user-agent string is appended.
+ #pod * C<cookie_jar> —
+ #pod An instance of L<HTTP::CookieJar> — or equivalent class that supports the C<add> and C<cookie_header> methods
+ #pod * C<default_headers> —
+ #pod A hashref of default headers to apply to requests
+ #pod * C<local_address> —
+ #pod The local IP address to bind to
+ #pod * C<keep_alive> —
+ #pod Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1)
+ #pod * C<max_redirect> —
+ #pod Maximum number of redirects allowed (defaults to 5)
+ #pod * C<max_size> —
+ #pod Maximum response size (only when not using a data callback). If defined, responses larger than this will return an exception.
+ #pod * C<http_proxy> —
+ #pod URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> — if set)
+ #pod * C<https_proxy> —
+ #pod URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> — if set)
+ #pod * C<proxy> —
+ #pod URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> — if set)
+ #pod * C<no_proxy> —
+ #pod List of domain suffixes that should not be proxied. Must be a comma-separated string or an array reference. (default is C<$ENV{no_proxy}> —)
+ #pod * C<timeout> —
+ #pod Request timeout in seconds (default is 60)
+ #pod * C<verify_SSL> —
+ #pod A boolean that indicates whether to validate the SSL certificate of an C<https> —
+ #pod connection (default is false)
+ #pod * C<SSL_options> —
+ #pod A hashref of C<SSL_*> — options to pass through to L<IO::Socket::SSL>
+ #pod
+ #pod Passing an explicit C<undef> for C<proxy>, C<http_proxy> or C<https_proxy> will
+ #pod prevent getting the corresponding proxies from the environment.
+ #pod
+ #pod Exceptions from C<max_size>, C<timeout> or other errors will result in a
+ #pod pseudo-HTTP status code of 599 and a reason of "Internal Exception". The
+ #pod content field in the response will contain the text of the exception.
+ #pod
+ #pod The C<keep_alive> parameter enables a persistent connection, but only to a
+ #pod single destination scheme, host and port. Also, if any connection-relevant
+ #pod attributes are modified, or if the process ID or thread ID change, the
+ #pod persistent connection will be dropped. If you want persistent connections
+ #pod across multiple destinations, use multiple HTTP::Tiny objects.
+ #pod
+ #pod See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.
+ #pod
+ #pod =cut
my @attributes;
BEGIN {
@@ -12287,36 +13524,45 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
sub _set_proxies {
my ($self) = @_;
- if (! $self->{proxy} ) {
+ # get proxies from %ENV only if not provided; explicit undef will disable
+ # getting proxies from the environment
+
+ # generic proxy
+ if (! exists $self->{proxy} ) {
$self->{proxy} = $ENV{all_proxy} || $ENV{ALL_PROXY};
- if ( defined $self->{proxy} ) {
- $self->_split_proxy( 'generic proxy' => $self->{proxy} ); # validate
- }
- else {
- delete $self->{proxy};
- }
}
- if (! $self->{http_proxy} ) {
+ if ( defined $self->{proxy} ) {
+ $self->_split_proxy( 'generic proxy' => $self->{proxy} ); # validate
+ }
+ else {
+ delete $self->{proxy};
+ }
+
+ # http proxy
+ if (! exists $self->{http_proxy} ) {
$self->{http_proxy} = $ENV{http_proxy} || $self->{proxy};
- if ( defined $self->{http_proxy} ) {
- $self->_split_proxy( http_proxy => $self->{http_proxy} ); # validate
- $self->{_has_proxy}{http} = 1;
- }
- else {
- delete $self->{http_proxy};
- }
}
- if (! $self->{https_proxy} ) {
+ if ( defined $self->{http_proxy} ) {
+ $self->_split_proxy( http_proxy => $self->{http_proxy} ); # validate
+ $self->{_has_proxy}{http} = 1;
+ }
+ else {
+ delete $self->{http_proxy};
+ }
+
+ # https proxy
+ if (! exists $self->{https_proxy} ) {
$self->{https_proxy} = $ENV{https_proxy} || $ENV{HTTPS_PROXY} || $self->{proxy};
- if ( $self->{https_proxy} ) {
- $self->_split_proxy( https_proxy => $self->{https_proxy} ); # validate
- $self->{_has_proxy}{https} = 1;
- }
- else {
- delete $self->{https_proxy};
- }
+ }
+
+ if ( $self->{https_proxy} ) {
+ $self->_split_proxy( https_proxy => $self->{https_proxy} ); # validate
+ $self->{_has_proxy}{https} = 1;
+ }
+ else {
+ delete $self->{https_proxy};
}
# Split no_proxy to array reference if not provided as such
@@ -12328,19 +13574,19 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
return;
}
- # =method get|head|put|post|delete
- #
- # $response = $http->get($url);
- # $response = $http->get($url, \%options);
- # $response = $http->head($url);
- #
- # These methods are shorthand for calling C<request()> for the given method. The
- # URL must have unsafe characters escaped and international domain names encoded.
- # See C<request()> for valid options and a description of the response.
- #
- # The C<success> field of the response will be true if the status code is 2XX.
- #
- # =cut
+ #pod =method get|head|put|post|delete
+ #pod
+ #pod $response = $http->get($url);
+ #pod $response = $http->get($url, \%options);
+ #pod $response = $http->head($url);
+ #pod
+ #pod These methods are shorthand for calling C<request()> for the given method. The
+ #pod URL must have unsafe characters escaped and international domain names encoded.
+ #pod See C<request()> for valid options and a description of the response.
+ #pod
+ #pod The C<success> field of the response will be true if the status code is 2XX.
+ #pod
+ #pod =cut
for my $sub_name ( qw/get head put post delete/ ) {
my $req_method = uc $sub_name;
@@ -12355,25 +13601,25 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
HERE
}
- # =method post_form
- #
- # $response = $http->post_form($url, $form_data);
- # $response = $http->post_form($url, $form_data, \%options);
- #
- # This method executes a C<POST> request and sends the key/value pairs from a
- # form data hash or array reference to the given URL with a C<content-type> of
- # C<application/x-www-form-urlencoded>. If data is provided as an array
- # reference, the order is preserved; if provided as a hash reference, the terms
- # are sorted on key and value for consistency. See documentation for the
- # C<www_form_urlencode> method for details on the encoding.
- #
- # The URL must have unsafe characters escaped and international domain names
- # encoded. See C<request()> for valid options and a description of the response.
- # Any C<content-type> header or content in the options hashref will be ignored.
- #
- # The C<success> field of the response will be true if the status code is 2XX.
- #
- # =cut
+ #pod =method post_form
+ #pod
+ #pod $response = $http->post_form($url, $form_data);
+ #pod $response = $http->post_form($url, $form_data, \%options);
+ #pod
+ #pod This method executes a C<POST> request and sends the key/value pairs from a
+ #pod form data hash or array reference to the given URL with a C<content-type> of
+ #pod C<application/x-www-form-urlencoded>. If data is provided as an array
+ #pod reference, the order is preserved; if provided as a hash reference, the terms
+ #pod are sorted on key and value for consistency. See documentation for the
+ #pod C<www_form_urlencode> method for details on the encoding.
+ #pod
+ #pod The URL must have unsafe characters escaped and international domain names
+ #pod encoded. See C<request()> for valid options and a description of the response.
+ #pod Any C<content-type> header or content in the options hashref will be ignored.
+ #pod
+ #pod The C<success> field of the response will be true if the status code is 2XX.
+ #pod
+ #pod =cut
sub post_form {
my ($self, $url, $data, $args) = @_;
@@ -12397,28 +13643,28 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
);
}
- # =method mirror
- #
- # $response = $http->mirror($url, $file, \%options)
- # if ( $response->{success} ) {
- # print "$file is up to date\n";
- # }
- #
- # Executes a C<GET> request for the URL and saves the response body to the file
- # name provided. The URL must have unsafe characters escaped and international
- # domain names encoded. If the file already exists, the request will include an
- # C<If-Modified-Since> header with the modification timestamp of the file. You
- # may specify a different C<If-Modified-Since> header yourself in the C<<
- # $options->{headers} >> hash.
- #
- # The C<success> field of the response will be true if the status code is 2XX
- # or if the status code is 304 (unmodified).
- #
- # If the file was modified and the server response includes a properly
- # formatted C<Last-Modified> header, the file modification time will
- # be updated accordingly.
- #
- # =cut
+ #pod =method mirror
+ #pod
+ #pod $response = $http->mirror($url, $file, \%options)
+ #pod if ( $response->{success} ) {
+ #pod print "$file is up to date\n";
+ #pod }
+ #pod
+ #pod Executes a C<GET> request for the URL and saves the response body to the file
+ #pod name provided. The URL must have unsafe characters escaped and international
+ #pod domain names encoded. If the file already exists, the request will include an
+ #pod C<If-Modified-Since> header with the modification timestamp of the file. You
+ #pod may specify a different C<If-Modified-Since> header yourself in the C<<
+ #pod $options->{headers} >> hash.
+ #pod
+ #pod The C<success> field of the response will be true if the status code is 2XX
+ #pod or if the status code is 304 (unmodified).
+ #pod
+ #pod If the file was modified and the server response includes a properly
+ #pod formatted C<Last-Modified> header, the file modification time will
+ #pod be updated accordingly.
+ #pod
+ #pod =cut
sub mirror {
my ($self, $url, $file, $args) = @_;
@@ -12451,86 +13697,90 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
return $response;
}
- # =method request
- #
- # $response = $http->request($method, $url);
- # $response = $http->request($method, $url, \%options);
- #
- # Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST',
- # 'PUT', etc.) on the given URL. The URL must have unsafe characters escaped and
- # international domain names encoded.
- #
- # If the URL includes a "user:password" stanza, they will be used for Basic-style
- # authorization headers. (Authorization headers will not be included in a
- # redirected request.) For example:
- #
- # $http->request('GET', 'http://Aladdin:open sesame@example.com/');
- #
- # If the "user:password" stanza contains reserved characters, they must
- # be percent-escaped:
- #
- # $http->request('GET', 'http://john%40example.com:password@example.com/');
- #
- # A hashref of options may be appended to modify the request.
- #
- # Valid options are:
- #
- # =for :list
- # * C<headers>
- # A hashref containing headers to include with the request. If the value for
- # a header is an array reference, the header will be output multiple times with
- # each value in the array. These headers over-write any default headers.
- # * C<content>
- # A scalar to include as the body of the request OR a code reference
- # that will be called iteratively to produce the body of the request
- # * C<trailer_callback>
- # A code reference that will be called if it exists to provide a hashref
- # of trailing headers (only used with chunked transfer-encoding)
- # * C<data_callback>
- # A code reference that will be called for each chunks of the response
- # body received.
- #
- # If the C<content> option is a code reference, it will be called iteratively
- # to provide the content body of the request. It should return the empty
- # string or undef when the iterator is exhausted.
- #
- # If the C<content> option is the empty string, no C<content-type> or
- # C<content-length> headers will be generated.
- #
- # If the C<data_callback> option is provided, it will be called iteratively until
- # the entire response body is received. The first argument will be a string
- # containing a chunk of the response body, the second argument will be the
- # in-progress response hash reference, as described below. (This allows
- # customizing the action of the callback based on the C<status> or C<headers>
- # received prior to the content body.)
- #
- # The C<request> method returns a hashref containing the response. The hashref
- # will have the following keys:
- #
- # =for :list
- # * C<success>
- # Boolean indicating whether the operation returned a 2XX status code
- # * C<url>
- # URL that provided the response. This is the URL of the request unless
- # there were redirections, in which case it is the last URL queried
- # in a redirection chain
- # * C<status>
- # The HTTP status code of the response
- # * C<reason>
- # The response phrase returned by the server
- # * C<content>
- # The body of the response. If the response does not have any content
- # or if a data callback is provided to consume the response body,
- # this will be the empty string
- # * C<headers>
- # A hashref of header fields. All header field names will be normalized
- # to be lower case. If a header is repeated, the value will be an arrayref;
- # it will otherwise be a scalar string containing the value
- #
- # On an exception during the execution of the request, the C<status> field will
- # contain 599, and the C<content> field will contain the text of the exception.
- #
- # =cut
+ #pod =method request
+ #pod
+ #pod $response = $http->request($method, $url);
+ #pod $response = $http->request($method, $url, \%options);
+ #pod
+ #pod Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST',
+ #pod 'PUT', etc.) on the given URL. The URL must have unsafe characters escaped and
+ #pod international domain names encoded.
+ #pod
+ #pod If the URL includes a "user:password" stanza, they will be used for Basic-style
+ #pod authorization headers. (Authorization headers will not be included in a
+ #pod redirected request.) For example:
+ #pod
+ #pod $http->request('GET', 'http://Aladdin:open sesame@example.com/');
+ #pod
+ #pod If the "user:password" stanza contains reserved characters, they must
+ #pod be percent-escaped:
+ #pod
+ #pod $http->request('GET', 'http://john%40example.com:password@example.com/');
+ #pod
+ #pod A hashref of options may be appended to modify the request.
+ #pod
+ #pod Valid options are:
+ #pod
+ #pod =for :list
+ #pod * C<headers> —
+ #pod A hashref containing headers to include with the request. If the value for
+ #pod a header is an array reference, the header will be output multiple times with
+ #pod each value in the array. These headers over-write any default headers.
+ #pod * C<content> —
+ #pod A scalar to include as the body of the request OR a code reference
+ #pod that will be called iteratively to produce the body of the request
+ #pod * C<trailer_callback> —
+ #pod A code reference that will be called if it exists to provide a hashref
+ #pod of trailing headers (only used with chunked transfer-encoding)
+ #pod * C<data_callback> —
+ #pod A code reference that will be called for each chunks of the response
+ #pod body received.
+ #pod
+ #pod The C<Host> header is generated from the URL in accordance with RFC 2616. It
+ #pod is a fatal error to specify C<Host> in the C<headers> option. Other headers
+ #pod may be ignored or overwritten if necessary for transport compliance.
+ #pod
+ #pod If the C<content> option is a code reference, it will be called iteratively
+ #pod to provide the content body of the request. It should return the empty
+ #pod string or undef when the iterator is exhausted.
+ #pod
+ #pod If the C<content> option is the empty string, no C<content-type> or
+ #pod C<content-length> headers will be generated.
+ #pod
+ #pod If the C<data_callback> option is provided, it will be called iteratively until
+ #pod the entire response body is received. The first argument will be a string
+ #pod containing a chunk of the response body, the second argument will be the
+ #pod in-progress response hash reference, as described below. (This allows
+ #pod customizing the action of the callback based on the C<status> or C<headers>
+ #pod received prior to the content body.)
+ #pod
+ #pod The C<request> method returns a hashref containing the response. The hashref
+ #pod will have the following keys:
+ #pod
+ #pod =for :list
+ #pod * C<success> —
+ #pod Boolean indicating whether the operation returned a 2XX status code
+ #pod * C<url> —
+ #pod URL that provided the response. This is the URL of the request unless
+ #pod there were redirections, in which case it is the last URL queried
+ #pod in a redirection chain
+ #pod * C<status> —
+ #pod The HTTP status code of the response
+ #pod * C<reason> —
+ #pod The response phrase returned by the server
+ #pod * C<content> —
+ #pod The body of the response. If the response does not have any content
+ #pod or if a data callback is provided to consume the response body,
+ #pod this will be the empty string
+ #pod * C<headers> —
+ #pod A hashref of header fields. All header field names will be normalized
+ #pod to be lower case. If a header is repeated, the value will be an arrayref;
+ #pod it will otherwise be a scalar string containing the value
+ #pod
+ #pod On an exception during the execution of the request, the C<status> field will
+ #pod contain 599, and the C<content> field will contain the text of the exception.
+ #pod
+ #pod =cut
my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/;
@@ -12571,19 +13821,19 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
return $response;
}
- # =method www_form_urlencode
- #
- # $params = $http->www_form_urlencode( $data );
- # $response = $http->get("http://example.com/query?$params");
- #
- # This method converts the key/value pairs from a data hash or array reference
- # into a C<x-www-form-urlencoded> string. The keys and values from the data
- # reference will be UTF-8 encoded and escaped per RFC 3986. If a value is an
- # array reference, the key will be repeated with each of the values of the array
- # reference. If data is provided as a hash reference, the key/value pairs in the
- # resulting string will be sorted by key and value for consistent ordering.
- #
- # =cut
+ #pod =method www_form_urlencode
+ #pod
+ #pod $params = $http->www_form_urlencode( $data );
+ #pod $response = $http->get("http://example.com/query?$params");
+ #pod
+ #pod This method converts the key/value pairs from a data hash or array reference
+ #pod into a C<x-www-form-urlencoded> string. The keys and values from the data
+ #pod reference will be UTF-8 encoded and escaped per RFC 3986. If a value is an
+ #pod array reference, the key will be repeated with each of the values of the array
+ #pod reference. If data is provided as a hash reference, the key/value pairs in the
+ #pod resulting string will be sorted by key and value for consistent ordering.
+ #pod
+ #pod =cut
sub www_form_urlencode {
my ($self, $data) = @_;
@@ -12634,6 +13884,7 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
method => $method,
scheme => $scheme,
host => $host,
+ port => $port,
host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
uri => $path_query,
headers => {},
@@ -12770,9 +14021,9 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
my $connect_request = {
method => 'CONNECT',
- uri => $request->{host_port},
+ uri => "$request->{host}:$request->{port}",
headers => {
- host => $request->{host_port},
+ host => "$request->{host}:$request->{port}",
'user-agent' => $agent,
}
};
@@ -12808,6 +14059,11 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
$request->{headers}{lc $k} = $v;
}
}
+
+ if (exists $request->{headers}{'host'}) {
+ die(qq/The 'Host' header must not be provided as header option\n/);
+ }
+
$request->{headers}{'host'} = $request->{host_port};
$request->{headers}{'user-agent'} ||= $self->{agent};
$request->{headers}{'connection'} = "close"
@@ -12924,31 +14180,27 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
my $url = pop;
# URI regex adapted from the URI module
- my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
+ my ($scheme, $host, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
or die(qq/Cannot parse URL: '$url'\n/);
$scheme = lc $scheme;
$path_query = "/$path_query" unless $path_query =~ m<\A/>;
- my ($auth,$host);
- $authority = (length($authority)) ? $authority : 'localhost';
- if ( $authority =~ /@/ ) {
- ($auth,$host) = $authority =~ m/\A([^@]*)@(.*)\z/; # user:pass@host
+ my $auth = '';
+ if ( (my $i = index $host, '@') != -1 ) {
+ # user:pass@host
+ $auth = substr $host, 0, $i, ''; # take up to the @ for auth
+ substr $host, 0, 1, ''; # knock the @ off the host
+
# userinfo might be percent escaped, so recover real auth info
$auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
}
- 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);
- };
+ my $port = $host =~ s/:(\d*)\z// && length $1 ? $1
+ : $scheme eq 'http' ? 80
+ : $scheme eq 'https' ? 443
+ : undef;
- return ($scheme, $host, $port, $path_query, $auth);
+ return ($scheme, (length $host ? lc $host : "localhost") , $port, $path_query, $auth);
}
# Date conversions adapted from HTTP::Date
@@ -13011,6 +14263,15 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
use Errno qw[EINTR EPIPE];
use IO::Socket qw[SOCK_STREAM];
+ # for thread safety, we need to know thread id or else fake it;
+ # requires "threads.pm" to hide it from the minimum version detector
+ if ( eval { require "threads.pm"; 1 } ) { ## no critic
+ *_get_tid = sub { threads->tid };
+ }
+ else {
+ *_get_tid = sub () { 0 };
+ }
+
# PERL_HTTP_TINY_IPV4_ONLY is a private environment variable to force old
# behavior if someone is unable to boostrap CPAN from a new perl install; it is
# not intended for general, per-client use and may be removed in the future
@@ -13074,6 +14335,8 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
$self->{scheme} = $scheme;
$self->{host} = $host;
$self->{port} = $port;
+ $self->{pid} = $$;
+ $self->{tid} = _get_tid();
return $self;
}
@@ -13299,8 +14562,7 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
$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");
+ $_ = '' unless defined $_;
$buf .= "$field_name: $_\x0D\x0A";
}
}
@@ -13518,7 +14780,9 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
sub can_reuse {
my ($self,$scheme,$host,$port) = @_;
return 0 if
- length($self->{rbuf})
+ $self->{pid} != $$
+ || $self->{tid} != _get_tid()
+ || length($self->{rbuf})
|| $scheme ne $self->{scheme}
|| $host ne $self->{host}
|| $port ne $self->{port}
@@ -13595,7 +14859,7 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
=head1 VERSION
- version 0.043
+ version 0.050
=head1 SYNOPSIS
@@ -13640,100 +14904,74 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
=item *
- C<agent>
-
- A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C<agent> ends in a space character, the default user-agent string is appended.
+ C<agent> — A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C<agent> — ends in a space character, the default user-agent string is appended.
=item *
- C<cookie_jar>
-
- An instance of L<HTTP::CookieJar> or equivalent class that supports the C<add> and C<cookie_header> methods
+ C<cookie_jar> — An instance of L<HTTP::CookieJar> — or equivalent class that supports the C<add> and C<cookie_header> methods
=item *
- C<default_headers>
-
- A hashref of default headers to apply to requests
+ C<default_headers> — A hashref of default headers to apply to requests
=item *
- C<local_address>
-
- The local IP address to bind to
+ C<local_address> — The local IP address to bind to
=item *
- C<keep_alive>
-
- Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1)
+ C<keep_alive> — Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1)
=item *
- C<max_redirect>
-
- Maximum number of redirects allowed (defaults to 5)
+ C<max_redirect> — Maximum number of redirects allowed (defaults to 5)
=item *
- C<max_size>
-
- Maximum response size (only when not using a data callback). If defined, responses larger than this will return an exception.
+ C<max_size> — Maximum response size (only when not using a data callback). If defined, responses larger than this will return an exception.
=item *
- C<http_proxy>
-
- URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> if set)
+ C<http_proxy> — URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> — if set)
=item *
- C<https_proxy>
-
- URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> if set)
+ C<https_proxy> — URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> — if set)
=item *
- C<proxy>
-
- URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> if set)
+ C<proxy> — URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> — if set)
=item *
- C<no_proxy>
-
- List of domain suffixes that should not be proxied. Must be a comma-separated string or an array reference. (default is C<$ENV{no_proxy}>)
+ C<no_proxy> — List of domain suffixes that should not be proxied. Must be a comma-separated string or an array reference. (default is C<$ENV{no_proxy}> —)
=item *
- C<timeout>
-
- Request timeout in seconds (default is 60)
+ C<timeout> — Request timeout in seconds (default is 60)
=item *
- C<verify_SSL>
-
- A boolean that indicates whether to validate the SSL certificate of an C<https>
- connection (default is false)
+ C<verify_SSL> — A boolean that indicates whether to validate the SSL certificate of an C<https> — connection (default is false)
=item *
- C<SSL_options>
-
- A hashref of C<SSL_*> options to pass through to L<IO::Socket::SSL>
+ C<SSL_options> — A hashref of C<SSL_*> — options to pass through to L<IO::Socket::SSL>
=back
+ Passing an explicit C<undef> for C<proxy>, C<http_proxy> or C<https_proxy> will
+ prevent getting the corresponding proxies from the environment.
+
Exceptions from C<max_size>, C<timeout> or other errors will result in a
pseudo-HTTP status code of 599 and a reason of "Internal Exception". The
content field in the response will contain the text of the exception.
The C<keep_alive> parameter enables a persistent connection, but only to a
single destination scheme, host and port. Also, if any connection-relevant
- attributes are modified, a persistent connection will be dropped. If you want
- persistent connections across multiple destinations, use multiple HTTP::Tiny
- objects.
+ attributes are modified, or if the process ID or thread ID change, the
+ persistent connection will be dropped. If you want persistent connections
+ across multiple destinations, use multiple HTTP::Tiny objects.
See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.
@@ -13816,35 +15054,26 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
=item *
- C<headers>
-
- A hashref containing headers to include with the request. If the value for
- a header is an array reference, the header will be output multiple times with
- each value in the array. These headers over-write any default headers.
+ C<headers> — A hashref containing headers to include with the request. If the value for a header is an array reference, the header will be output multiple times with each value in the array. These headers over-write any default headers.
=item *
- C<content>
-
- A scalar to include as the body of the request OR a code reference
- that will be called iteratively to produce the body of the request
+ C<content> — A scalar to include as the body of the request OR a code reference that will be called iteratively to produce the body of the request
=item *
- C<trailer_callback>
-
- A code reference that will be called if it exists to provide a hashref
- of trailing headers (only used with chunked transfer-encoding)
+ C<trailer_callback> — A code reference that will be called if it exists to provide a hashref of trailing headers (only used with chunked transfer-encoding)
=item *
- C<data_callback>
-
- A code reference that will be called for each chunks of the response
- body received.
+ C<data_callback> — A code reference that will be called for each chunks of the response body received.
=back
+ The C<Host> header is generated from the URL in accordance with RFC 2616. It
+ is a fatal error to specify C<Host> in the C<headers> option. Other headers
+ may be ignored or overwritten if necessary for transport compliance.
+
If the C<content> option is a code reference, it will be called iteratively
to provide the content body of the request. It should return the empty
string or undef when the iterator is exhausted.
@@ -13866,45 +15095,27 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
=item *
- C<success>
-
- Boolean indicating whether the operation returned a 2XX status code
+ C<success> — Boolean indicating whether the operation returned a 2XX status code
=item *
- C<url>
-
- URL that provided the response. This is the URL of the request unless
- there were redirections, in which case it is the last URL queried
- in a redirection chain
+ C<url> — URL that provided the response. This is the URL of the request unless there were redirections, in which case it is the last URL queried in a redirection chain
=item *
- C<status>
-
- The HTTP status code of the response
+ C<status> — The HTTP status code of the response
=item *
- C<reason>
-
- The response phrase returned by the server
+ C<reason> — The response phrase returned by the server
=item *
- C<content>
-
- The body of the response. If the response does not have any content
- or if a data callback is provided to consume the response body,
- this will be the empty string
+ C<content> — The body of the response. If the response does not have any content or if a data callback is provided to consume the response body, this will be the empty string
=item *
- C<headers>
-
- A hashref of header fields. All header field names will be normalized
- to be lower case. If a header is repeated, the value will be an arrayref;
- it will otherwise be a scalar string containing the value
+ C<headers> — A hashref of header fields. All header field names will be normalized to be lower case. If a header is repeated, the value will be an arrayref; it will otherwise be a scalar string containing the value
=back
@@ -13942,7 +15153,7 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
Direct C<https> connections are supported only if L<IO::Socket::SSL> 1.56 or
greater and L<Net::SSLeay> 1.49 or greater are installed. An exception will be
- thrown if a new enough versions of these modules not installed or if the SSL
+ thrown if new enough versions of these modules are not installed or if the SSL
encryption fails. An C<https> connection may be made via an C<http> proxy that
supports the CONNECT command (i.e. RFC 2817). You may not proxy C<https> via
a proxy that itself requires C<https> to communicate.
@@ -14062,9 +15273,40 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
=head1 LIMITATIONS
HTTP::Tiny is I<conditionally compliant> with the
- L<HTTP/1.1 specification|http://www.w3.org/Protocols/rfc2616/rfc2616.html>.
+ L<HTTP/1.1 specifications|http://www.w3.org/Protocols/>:
+
+ =over 4
+
+ =item *
+
+ "Message Syntax and Routing" [RFC7230]
+
+ =item *
+
+ "Semantics and Content" [RFC7231]
+
+ =item *
+
+ "Conditional Requests" [RFC7232]
+
+ =item *
+
+ "Range Requests" [RFC7233]
+
+ =item *
+
+ "Caching" [RFC7234]
+
+ =item *
+
+ "Authentication" [RFC7235]
+
+ =back
+
It attempts to meet all "MUST" requirements of the specification, but does not
- implement all "SHOULD" requirements.
+ implement all "SHOULD" requirements. (Note: it was developed against the
+ earlier RFC 2616 specification and may not yet meet the revised RFC 7230-7235
+ spec.)
Some particular limitations of note include:
@@ -14182,6 +15424,8 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
=head1 CONTRIBUTORS
+ =for stopwords Alan Gardner Edward Zborowski James Raspass Jess Robinson Lukas Eklund Martin J. Evans Martin-Louis Bright Mike Doherty Petr Písař Serguei Trouchelle Syohei YOSHIDA Alessandro Ghedini Sören Kornetzki Tom Hukins Tony Cook Brad Gilbert Chris Nehren Weyl Claes Jakobsson Clinton Gormley Craig Berry David Mitchell Dean Pearce
+
=over 4
=item *
@@ -14190,75 +15434,91 @@ $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_
=item *
- Alessandro Ghedini <al3xbio@gmail.com>
+ Edward Zborowski <ed@rubensteintech.com>
=item *
- Brad Gilbert <bgills@cpan.org>
+ James Raspass <jraspass@gmail.com>
=item *
- Chris Nehren <apeiron@cpan.org>
+ Jess Robinson <castaway@desert-island.me.uk>
=item *
- Chris Weyl <cweyl@alumni.drew.edu>
+ Lukas Eklund <leklund@gmail.com>
=item *
- Claes Jakobsson <claes@surfar.nu>
+ Martin J. Evans <mjegh@ntlworld.com>
=item *
- Clinton Gormley <clint@traveljury.com>
+ Martin-Louis Bright <mlbright@gmail.com>
=item *
- Craig Berry <cberry@cpan.org>
+ Mike Doherty <doherty@cpan.org>
=item *
- David Mitchell <davem@iabyn.com>
+ Petr Písař <ppisar@redhat.com>
=item *
- Edward Zborowski <ed@rubensteintech.com>
+ Serguei Trouchelle <stro@cpan.org>
=item *
- Jess Robinson <castaway@desert-island.me.uk>
+ Syohei YOSHIDA <syohex@gmail.com>
=item *
- Lukas Eklund <leklund@gmail.com>
+ Alessandro Ghedini <al3xbio@gmail.com>
=item *
- Martin J. Evans <mjegh@ntlworld.com>
+ Sören Kornetzki <soeren.kornetzki@delti.com>
=item *
- Martin-Louis Bright <mlbright@gmail.com>
+ Tom Hukins <tom@eborcom.com>
=item *
- Mike Doherty <doherty@cpan.org>
+ Tony Cook <tony@develop-help.com>
=item *
- Petr Písař <ppisar@redhat.com>
+ Brad Gilbert <bgills@cpan.org>
=item *
- Serguei Trouchelle <stro@cpan.org>
+ Chris Nehren <apeiron@cpan.org>
=item *
- Syohei YOSHIDA <syohex@gmail.com>
+ Chris Weyl <rsrchboy@cpan.org>
=item *
- Tony Cook <tony@develop-help.com>
+ Claes Jakobsson <claes@surfar.nu>
+
+ =item *
+
+ Clinton Gormley <clint@traveljury.com>
+
+ =item *
+
+ Craig Berry <cberry@cpan.org>
+
+ =item *
+
+ David Mitchell <davem@iabyn.com>
+
+ =item *
+
+ Dean Pearce <pearce@pythian.com>
=back
@@ -14286,7 +15546,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
use B ();
#use Devel::Peek;
- $JSON::PP::VERSION = '2.27203';
+ $JSON::PP::VERSION = '2.27300';
@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
@@ -14930,6 +16190,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
}
else {
utf8::upgrade( $text );
+ utf8::encode( $text );
}
$len = length $text;
@@ -15081,17 +16342,12 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
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;
- }
+ unless( $ch = is_valid_utf8($ch) ) {
+ $at -= 1;
+ decode_error("malformed UTF-8 character in JSON string");
}
else {
- utf8::encode( $ch );
+ $at += $utf8_len - 1;
}
$is_utf8 = 1;
@@ -15905,7 +17161,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
=head1 VERSION
- 2.27202
+ 2.27300
L<JSON::XS> 2.27 (~2.30) compatible.
@@ -17066,7 +18322,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
=head1 COPYRIGHT AND LICENSE
- Copyright 2007-2013 by Makamaka Hannyaharamitu
+ Copyright 2007-2014 by Makamaka Hannyaharamitu
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
@@ -17110,9 +18366,9 @@ $fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
use Cwd;
use Carp ();
use Module::CPANfile::Environment;
- use Module::CPANfile::Result;
+ use Module::CPANfile::Requirement;
- our $VERSION = '1.0002';
+ our $VERSION = '1.1000';
sub new {
my($class, $file) = @_;
@@ -17143,42 +18399,46 @@ $fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
};
my $env = Module::CPANfile::Environment->new($file);
- $self->{result} = $env->parse($code) or die $@;
+ $env->parse($code) or die $@;
+
+ $self->{_mirrors} = $env->mirrors;
+ $self->{_prereqs} = $env->prereqs;
}
sub from_prereqs {
my($proto, $prereqs) = @_;
my $self = $proto->new;
- $self->{result} = Module::CPANfile::Result->from_prereqs($prereqs);
+ $self->{_prereqs} = Module::CPANfile::Prereqs->from_cpan_meta($prereqs);
$self;
}
+ sub mirrors {
+ my $self = shift;
+ $self->{_mirrors} || [];
+ }
+
sub features {
my $self = shift;
- map $self->feature($_), keys %{$self->{result}{features}};
+ map $self->feature($_), $self->{_prereqs}->identifiers;
}
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},
- });
+ $self->{_prereqs}->feature($identifier);
}
sub prereq { shift->prereqs }
sub prereqs {
my $self = shift;
- require CPAN::Meta::Prereqs;
- CPAN::Meta::Prereqs->new($self->prereq_specs);
+ $self->{_prereqs}->as_cpan_meta;
+ }
+
+ sub merged_requirements {
+ my $self = shift;
+ $self->{_prereqs}->merged_requirements;
}
sub effective_prereqs {
@@ -17197,7 +18457,18 @@ $fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
sub prereq_specs {
my $self = shift;
- $self->{result}{spec};
+ $self->prereqs->as_string_hash;
+ }
+
+ sub prereq_for_module {
+ my($self, $module) = @_;
+ $self->{_prereqs}->find($module);
+ }
+
+ sub options_for_module {
+ my($self, $module) = @_;
+ my $prereq = $self->prereq_for_module($module) or return;
+ $prereq->requirement->options;
}
sub merge_meta {
@@ -17226,12 +18497,14 @@ $fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
sub to_string {
my($self, $include_empty) = @_;
- my $prereqs = $self->{result}{spec};
+ my $mirrors = $self->mirrors;
+ my $prereqs = $self->prereq_specs;
my $code = '';
- $code .= $self->_dump_prereqs($self->{result}{spec}, $include_empty);
+ $code .= $self->_dump_mirrors($mirrors);
+ $code .= $self->_dump_prereqs($prereqs, $include_empty);
- for my $feature (values %{$self->{result}{features}}) {
+ for my $feature ($self->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";
@@ -17241,6 +18514,19 @@ $fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$code;
}
+ sub _dump_mirrors {
+ my($self, $mirrors) = @_;
+
+ my $code = "";
+
+ for my $url (@$mirrors) {
+ $code .= "mirror '$url';\n";
+ }
+
+ $code =~ s/\n+$/\n/s;
+ $code;
+ }
+
sub _dump_prereqs {
my($self, $prereqs, $include_empty, $base_indent) = @_;
@@ -17356,7 +18642,7 @@ $fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
# read MYMETA's prereqs and print cpanfile representation of it
my $meta = CPAN::Meta->load_file('MYMETA.json');
my $file = Module::CPANfile->from_prereqs($meta->prereqs);
- print $file->to_sring;
+ print $file->to_string;
By default, it omits the phase where there're no modules
registered. If you pass the argument of a true value, it will print
@@ -17403,13 +18689,14 @@ $fatpacked{"Module/CPANfile/Environment.pm"} = '#line '.(1+__LINE__).' "'.__FILE
package Module::CPANfile::Environment;
use strict;
use warnings;
- use Module::CPANfile::Result;
+ use Module::CPANfile::Prereqs;
use Carp ();
my @bindings = qw(
on requires recommends suggests conflicts
feature
osname
+ mirror
configure_requires build_requires test_requires author_requires
);
@@ -17418,79 +18705,63 @@ $fatpacked{"Module/CPANfile/Environment.pm"} = '#line '.(1+__LINE__).' "'.__FILE
sub new {
my($class, $file) = @_;
bless {
- file => $file,
+ file => $file,
+ phase => 'runtime', # default phase
+ feature => undef,
+ features => {},
+ prereqs => Module::CPANfile::Prereqs->new,
+ mirrors => [],
}, $class;
}
sub bind {
- my $class = shift;
+ my $self = shift;
my $pkg = caller;
- my $result = Module::CPANfile::Result->new;
for my $binding (@bindings) {
no strict 'refs';
- *{"$pkg\::$binding"} = sub { $result->$binding(@_) };
+ *{"$pkg\::$binding"} = sub { $self->$binding(@_) };
}
-
- return $result;
}
sub parse {
my($self, $code) = @_;
- my($res, $err);
-
+ my $err;
{
local $@;
$file_id++;
- $res = eval <<EVAL;
+ $self->_evaluate(<<EVAL);
package Module::CPANfile::Sandbox$file_id;
no warnings;
- my \$_result;
- BEGIN { \$_result = Module::CPANfile::Environment->bind }
+ BEGIN { \$_environment->bind }
# line 1 "$self->{file}"
$code;
-
- \$_result;
EVAL
$err = $@;
}
if ($err) { die "Parsing $self->{file} failed: $err" };
- return $res;
+ return 1;
}
- 1;
+ sub _evaluate {
+ my $_environment = $_[0];
+ eval $_[1];
+ }
-MODULE_CPANFILE_ENVIRONMENT
-
-$fatpacked{"Module/CPANfile/Result.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_RESULT';
- package Module::CPANfile::Result;
- use strict;
+ sub prereqs { $_[0]->{prereqs} }
- sub from_prereqs {
- my($class, $spec) = @_;
- bless {
- phase => 'runtime',
- spec => $spec,
- }, $class;
- }
+ sub mirrors { $_[0]->{mirrors} }
- sub new {
- bless {
- phase => 'runtime', # default phase
- features => {},
- feature => undef,
- spec => {},
- }, shift;
- }
+ # DSL goes from here
sub on {
my($self, $phase, $code) = @_;
local $self->{phase} = $phase;
- $code->()
+ $code->();
}
sub feature {
@@ -17506,35 +18777,62 @@ $fatpacked{"Module/CPANfile/Result.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
Carp::croak("Usage: feature 'identifier', 'Description' => sub { ... }");
}
- local $self->{feature} = $self->{features}{$identifier}
- = { identifier => $identifier, description => $description, spec => {} };
+ local $self->{feature} = $identifier;
+ $self->prereqs->add_feature($identifier, $description);
+
$code->();
}
sub osname { die "TODO" }
+ sub mirror {
+ my($self, $url) = @_;
+ push @{$self->{mirrors}}, $url;
+ }
+
+ sub requirement_for {
+ my($self, $module, @args) = @_;
+
+ my $requirement = 0;
+ $requirement = shift @args if @args % 2;
+
+ return Module::CPANfile::Requirement->new(
+ name => $module,
+ version => $requirement,
+ @args,
+ );
+ }
+
sub requires {
- my($self, $module, $requirement) = @_;
- ($self->{feature} ? $self->{feature}{spec} : $self->{spec})
- ->{$self->{phase}}{requires}{$module} = $requirement || 0;
+ my $self = shift;
+ $self->add_prereq(requires => @_);
}
sub recommends {
- my($self, $module, $requirement) = @_;
- ($self->{feature} ? $self->{feature}{spec} : $self->{spec})
- ->{$self->{phase}}{recommends}{$module} = $requirement || 0;
+ my $self = shift;
+ $self->add_prereq(recommends => @_);
}
sub suggests {
- my($self, $module, $requirement) = @_;
- ($self->{feature} ? $self->{feature}{spec} : $self->{spec})
- ->{$self->{phase}}{suggests}{$module} = $requirement || 0;
+ my $self = shift;
+ $self->add_prereq(suggests => @_);
}
sub conflicts {
- my($self, $module, $requirement) = @_;
- ($self->{feature} ? $self->{feature}{spec} : $self->{spec})
- ->{$self->{phase}}{conflicts}{$module} = $requirement || 0;
+ my $self = shift;
+ $self->add_prereq(conflicts => @_);
+ }
+
+ sub add_prereq {
+ my($self, $type, $module, @args) = @_;
+
+ $self->prereqs->add_prereq(
+ feature => $self->{feature},
+ phase => $self->{phase},
+ type => $type,
+ module => $module,
+ requirement => $self->requirement_for($module, @args),
+ );
}
# Module::Install compatible shortcuts
@@ -17560,66 +18858,246 @@ $fatpacked{"Module/CPANfile/Result.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
}
1;
-MODULE_CPANFILE_RESULT
+
+MODULE_CPANFILE_ENVIRONMENT
-$fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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;
+$fatpacked{"Module/CPANfile/Prereq.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_PREREQ';
+ package Module::CPANfile::Prereq;
+ use strict;
- # Adapted from Perl-licensed code originally distributed with
- # Module-Build by Ken Williams
+ sub new {
+ my($class, %options) = @_;
+ bless \%options, $class;
+ }
- # 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).
+ sub feature { $_[0]->{feature} }
+ sub phase { $_[0]->{phase} }
+ sub type { $_[0]->{type} }
+ sub module { $_[0]->{module} }
+ sub requirement { $_[0]->{requirement} }
+ sub match_feature {
+ my($self, $identifier) = @_;
+ no warnings 'uninitialized';
+ $self->feature eq $identifier;
+ }
+
+ 1;
+MODULE_CPANFILE_PREREQ
+
+$fatpacked{"Module/CPANfile/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_PREREQS';
+ package Module::CPANfile::Prereqs;
use strict;
- use warnings;
+ use Carp ();
+ use CPAN::Meta::Feature;
+ use Module::CPANfile::Prereq;
+
+ sub from_cpan_meta {
+ my($class, $prereqs) = @_;
+
+ my $self = $class->new;
+
+ for my $phase (keys %$prereqs) {
+ for my $type (keys %{ $prereqs->{$phase} }) {
+ while (my($module, $requirement) = each %{ $prereqs->{$phase}{$type} }) {
+ $self->add_prereq(
+ phase => $phase,
+ type => $type,
+ module => $module,
+ requirement => Module::CPANfile::Requirement->new(name => $module, version => $requirement),
+ );
+ }
+ }
+ }
- our $VERSION = '1.000019';
- $VERSION = eval $VERSION;
+ $self;
+ }
- 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]->() };
- }
+ sub new {
+ my $class = shift;
+ bless {
+ prereqs => [],
+ features => {},
+ }, $class;
}
- use File::Find qw(find);
- my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal
+ sub add_feature {
+ my($self, $identifier, $description) = @_;
+ $self->{features}{$identifier} = { description => $description };
+ }
- 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;
+ sub add_prereq {
+ my($self, %args) = @_;
+ $self->add( Module::CPANfile::Prereq->new(%args) );
+ }
- 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;
+ sub add {
+ my($self, $prereq) = @_;
+ push @{$self->{prereqs}}, $prereq;
+ }
+
+ sub as_cpan_meta {
+ my $self = shift;
+ $self->{cpanmeta} ||= $self->build_cpan_meta;
+ }
+
+ sub build_cpan_meta {
+ my($self, $identifier) = @_;
+
+ my $prereq_spec = {};
+ $self->prereq_each($identifier, sub {
+ my $prereq = shift;
+ $prereq_spec->{$prereq->phase}{$prereq->type}{$prereq->module} = $prereq->requirement->version;
+ });
+
+ CPAN::Meta::Prereqs->new($prereq_spec);
+ }
+
+ sub prereq_each {
+ my($self, $identifier, $code) = @_;
+
+ for my $prereq (@{$self->{prereqs}}) {
+ next unless $prereq->match_feature($identifier);
+ $code->($prereq);
+ }
+ }
+
+ sub merged_requirements {
+ my $self = shift;
+
+ my $reqs = CPAN::Meta::Requirements->new;
+ for my $prereq (@{$self->{prereqs}}) {
+ $reqs->add_string_requirement($prereq->module, $prereq->requirement->version);
+ }
+
+ $reqs;
+ }
+
+ sub find {
+ my($self, $module) = @_;
+
+ for my $prereq (@{$self->{prereqs}}) {
+ return $prereq if $prereq->module eq $module;
+ }
+
+ return;
+ }
+
+ sub identifiers {
+ my $self = shift;
+ keys %{$self->{features}};
+ }
+
+ sub feature {
+ my($self, $identifier) = @_;
+
+ my $data = $self->{features}{$identifier}
+ or Carp::croak("Unknown feature '$identifier'");
+
+ my $prereqs = $self->build_cpan_meta($identifier);
+
+ CPAN::Meta::Feature->new($identifier, {
+ description => $data->{description},
+ prereqs => $prereqs->as_string_hash,
+ });
+ }
+
+ 1;
+MODULE_CPANFILE_PREREQS
+
+$fatpacked{"Module/CPANfile/Requirement.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_REQUIREMENT';
+ package Module::CPANfile::Requirement;
+ use strict;
+
+ sub new {
+ my ($class, %args) = @_;
+
+ $args{version} ||= 0;
+
+ bless +{
+ name => delete $args{name},
+ version => delete $args{version},
+ options => \%args,
+ }, $class;
+ }
+
+ sub name { $_[0]->{name} }
+ sub version { $_[0]->{version} }
+
+ sub options { $_[0]->{options} }
+
+ sub has_options {
+ keys %{$_[0]->{options}} > 0;
+ }
+
+ 1;
+MODULE_CPANFILE_REQUIREMENT
+
+$fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'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;
+ BEGIN {
+ $Module::Metadata::AUTHORITY = 'cpan:MSTROUT';
+ }
+ # git description: v1.000023-1-g6bfd8b6
+ $Module::Metadata::VERSION = '1.000024';
+
+ # 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 warnings;
+
+ use Carp qw/croak/;
+ use File::Spec;
+ BEGIN {
+ # Try really hard to not depend ony any DynaLoaded module, such as IO::File or Fcntl
+ eval {
+ require Fcntl; Fcntl->import('SEEK_SET'); 1;
+ } or *SEEK_SET = sub { 0 }
+ }
+ use version 0.87;
+ BEGIN {
+ if ($INC{'Log/Contextual.pm'}) {
+ Log::Contextual->import('log_info');
+ } else {
+ *log_info = sub (&) { warn $_[0]->() };
+ }
+ }
+ use File::Find qw(find);
+
+ my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal
+
+ my $PKG_FIRST_WORD_REGEXP = qr{ # the FIRST word in a package name
+ [a-zA-Z_] # the first word CANNOT start with a digit
+ (?:
+ [\w']? # can contain letters, digits, _, or ticks
+ \w # But, NO multi-ticks or trailing ticks
+ )*
+ }x;
+
+ my $PKG_ADDL_WORD_REGEXP = qr{ # the 2nd+ word in a package name
+ \w # the 2nd+ word CAN start with digits
+ (?:
+ [\w']? # and can contain letters or ticks
+ \w # But, NO multi-ticks or trailing ticks
+ )*
+ }x;
my $PKG_NAME_REGEXP = qr{ # match a package name
- (?: :: )? # a pkg name can start with aristotle
+ (?: :: )? # a pkg name can start with arisdottle
$PKG_FIRST_WORD_REGEXP # a package word
(?:
- (?: :: )+ ### aristotle (allow one or many times)
+ (?: :: )+ ### arisdottle (allow one or many times)
$PKG_ADDL_WORD_REGEXP ### a package word
)* # ^ zero, one or many times
(?:
- :: # allow trailing aristotle
+ :: # allow trailing arisdottle
)?
}x;
@@ -17652,7 +19130,7 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$VARNAME_REGEXP # without parens
)
\s*
- =[^=~] # = but not ==, nor =~
+ =[^=~>] # = but not ==, nor =~, nor =>
}x;
sub new_from_file {
@@ -17727,19 +19205,19 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
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};
- }
+ 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} );
- }
+ $file ||= $p->{file} if defined( $p->{file} );
+ }
if ( $err ) {
$err = " $file ($version)\n" . $err;
@@ -17852,45 +19330,45 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
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
+ # 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}
+ "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->(
+ # 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"
+ " $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 {
+ # 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
+ # 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
@@ -17898,7 +19376,7 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
if ( $result->{err} ) {
log_info {
"Found conflicting versions for package '$package'\n" .
- $result->{err}
+ $result->{err}
};
}
@@ -17906,7 +19384,7 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
# something rather than nothing
$prime{$package}{file} = $result->{file};
$prime{$package}{version} = $result->{version}
- if defined( $result->{version} );
+ if defined( $result->{version} );
}
}
@@ -17948,12 +19426,14 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
my $self = bless(\%data, $class);
- if ( $handle ) {
- $self->_parse_fh($handle);
- }
- else {
- $self->_parse_file();
+ if ( not $handle ) {
+ my $filename = $self->{filename};
+ open $handle, '<', $filename
+ or croak( "Can't open '$filename': $!" );
+
+ $self->_handle_bom($handle, $filename);
}
+ $self->_parse_fh($handle);
unless($self->{module} and length($self->{module})) {
my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
@@ -17988,9 +19468,10 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
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";
+ if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
+ $testfile .= '.pm';
+ return [ File::Spec->rel2abs( $testfile ), $dir ]
+ if -e $testfile;
}
return;
}
@@ -18014,28 +19495,16 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
my $self = shift;
my $line = shift;
- my( $sig, $var, $pkg );
+ my( $sigil, $variable_name, $package);
if ( $line =~ /$VERS_REGEXP/o ) {
- ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
- if ( $pkg ) {
- $pkg = ($pkg eq '::') ? 'main' : $pkg;
- $pkg =~ s/::$//;
+ ( $sigil, $variable_name, $package) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
+ if ( $package ) {
+ $package = ($package eq '::') ? 'main' : $package;
+ $package =~ 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);
+ return ( $sigil, $variable_name, $package );
}
# Look for a UTF-8/UTF-16BE/UTF-16LE BOM at the beginning of the stream.
@@ -18043,11 +19512,11 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
sub _handle_bom {
my ($self, $fh, $filename) = @_;
- my $pos = $fh->getpos;
+ my $pos = tell $fh;
return unless defined $pos;
my $buf = ' ' x 2;
- my $count = $fh->read( $buf, length $buf );
+ my $count = read $fh, $buf, length $buf;
return unless defined $count and $count >= 2;
my $encoding;
@@ -18057,7 +19526,7 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$encoding = 'UTF-16LE';
} elsif ( $buf eq "\x{EF}\x{BB}" ) {
$buf = ' ';
- $count = $fh->read( $buf, length $buf );
+ $count = read $fh, $buf, length $buf;
if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) {
$encoding = 'UTF-8';
}
@@ -18065,11 +19534,10 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
if ( defined $encoding ) {
if ( "$]" >= 5.008 ) {
- # $fh->binmode requires perl 5.10
binmode( $fh, ":encoding($encoding)" );
}
} else {
- $fh->setpos($pos)
+ seek $fh, $pos, SEEK_SET
or croak( sprintf "Can't reset position to the top of '$filename'" );
}
@@ -18080,8 +19548,8 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
my ($self, $fh) = @_;
my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
- my( @pkgs, %vers, %pod, @pod );
- my $pkg = 'main';
+ my( @packages, %vers, %pod, @pod );
+ my $package = 'main';
my $pod_sect = '';
my $pod_data = '';
my $in_end = 0;
@@ -18105,15 +19573,15 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
if ( $in_pod ) {
if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) {
- push( @pod, $1 );
- if ( $self->{collect_pod} && length( $pod_data ) ) {
+ push( @pod, $1 );
+ if ( $self->{collect_pod} && length( $pod_data ) ) {
$pod{$pod_sect} = $pod_data;
$pod_data = '';
}
- $pod_sect = $1;
+ $pod_sect = $1;
} elsif ( $self->{collect_pod} ) {
- $pod_data .= "$line\n";
+ $pod_data .= "$line\n";
}
@@ -18141,56 +19609,57 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
last if $line eq '__DATA__';
# parse $line to see if it's a $VERSION declaration
- my( $vers_sig, $vers_fullname, $vers_pkg ) =
- ($line =~ /VERSION/)
+ my( $version_sigil, $version_fullname, $version_package ) =
+ index($line, 'VERSION') >= 1
? $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;
+ $package = $1;
+ my $version = $2;
+ push( @packages, $package ) unless grep( $package eq $_, @packages );
+ $need_vers = defined $version ? 0 : 1;
+
+ if ( not exists $vers{$package} and defined $version ){
+ # Upgrade to a version object.
+ my $dwim_version = eval { _dwim_version($version) };
+ croak "Version '$version' from $self->{filename} does not appear to be valid:\n$line\n\nThe fatal error was: $@\n"
+ unless defined $dwim_version; # "0" is OK!
+ $vers{$package} = $dwim_version;
+ }
# 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;
+ } elsif ( $version_fullname && $version_package ) {
+ push( @packages, $version_package ) unless grep( $version_package eq $_, @packages );
+ $need_vers = 0 if $version_package eq $package;
- unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
- $vers{$vers_pkg} =
- $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
- }
+ unless ( defined $vers{$version_package} && length $vers{$version_package} ) {
+ $vers{$version_package} = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
+ }
# first non-comment line in undeclared package main is VERSION
- } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
- $need_vers = 0;
- my $v =
- $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
- $vers{$pkg} = $v;
- push( @pkgs, 'main' );
+ } elsif ( $package eq 'main' && $version_fullname && !exists($vers{main}) ) {
+ $need_vers = 0;
+ my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
+ $vers{$package} = $v;
+ push( @packages, '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' );
+ } elsif ( $package eq 'main' && !exists($vers{main}) && $line =~ /\w/ ) {
+ $need_vers = 1;
+ $vers{main} = '';
+ push( @packages, '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;
- }
+ } elsif ( $version_fullname && $need_vers ) {
+ $need_vers = 0;
+ my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
+ unless ( defined $vers{$package} && length $vers{$package} ) {
+ $vers{$package} = $v;
+ }
}
-
}
-
}
if ( $self->{collect_pod} && length($pod_data) ) {
@@ -18198,7 +19667,7 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
}
$self->{versions} = \%vers;
- $self->{packages} = \@pkgs;
+ $self->{packages} = \@packages;
$self->{pod} = \%pod;
$self->{pod_headings} = \@pod;
}
@@ -18207,7 +19676,7 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
my $pn = 0;
sub _evaluate_version_line {
my $self = shift;
- my( $sigil, $var, $line ) = @_;
+ my( $sigil, $variable_name, $line ) = @_;
# Some of this code came from the ExtUtils:: hierarchy.
@@ -18222,10 +19691,10 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
no warnings;
\$vsub = sub {
- local $sigil$var;
- \$$var=undef;
+ local $sigil$variable_name;
+ \$$variable_name=undef;
$line;
- \$$var
+ \$$variable_name
};
}};
@@ -18234,7 +19703,7 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
local $^W;
# Try to get the $VERSION
eval $eval;
- # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
+ # some modules say $VERSION <equal sign> $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);
@@ -18245,12 +19714,14 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
(ref($vsub) eq 'CODE') or
croak "failed to build version sub for $self->{filename}";
my $result = eval { $vsub->() };
+ # FIXME: $eval is not the right thing to print here
croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
if $@;
# Upgrade it into a version object
my $version = eval { _dwim_version($result) };
+ # FIXME: $eval is not the right thing to print here
croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
unless defined $version; # "0" is OK!
@@ -18330,10 +19801,10 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
my $mod = shift || $self->{module};
my $vers;
if ( defined( $mod ) && length( $mod ) &&
- exists( $self->{versions}{$mod} ) ) {
- return $self->{versions}{$mod};
+ exists( $self->{versions}{$mod} ) ) {
+ return $self->{versions}{$mod};
} else {
- return undef;
+ return undef;
}
}
@@ -18341,13 +19812,25 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
my $self = shift;
my $sect = shift;
if ( defined( $sect ) && length( $sect ) &&
- exists( $self->{pod}{$sect} ) ) {
- return $self->{pod}{$sect};
+ exists( $self->{pod}{$sect} ) ) {
+ return $self->{pod}{$sect};
} else {
- return undef;
+ return undef;
}
}
+ sub is_indexable {
+ my ($self, $package) = @_;
+
+ my @indexable_packages = grep { $_ ne 'main' } $self->packages_inside;
+
+ # check for specific package, if provided
+ return !! grep { $_ eq $package } @indexable_packages if $package;
+
+ # otherwise, check for any indexable packages at all
+ return !! @indexable_packages;
+ }
+
1;
=head1 NAME
@@ -18521,7 +20004,7 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
=item C<< name() >>
Returns the name of the package represented by this module. If there
- are more than one packages, it makes a best guess based on the
+ is more than one package, it makes a best guess based on the
filename. If it's a script (i.e. not a *.pm) the package name is
'main'.
@@ -18558,6 +20041,13 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
Returns the POD data in the given section.
+ =item C<< is_indexable($package) >> or C<< is_indexable() >>
+
+ Returns a boolean indicating whether the package (if provided) or any package
+ (otherwise) is eligible for indexing by PAUSE, the Perl Authors Upload Server.
+ Note This only checks for valid C<package> declarations, and does not take any
+ ownership information into account.
+
=back
=head1 AUTHOR
@@ -18582,65 +20072,66 @@ $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
MODULE_METADATA
$fatpacked{"Parse/CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARSE_CPAN_META';
+ use 5.008001;
use strict;
package Parse::CPAN::Meta;
# ABSTRACT: Parse META.yml and META.json CPAN metadata files
- our $VERSION = '1.4407'; # VERSION
+ our $VERSION = '1.4414'; # VERSION
+ use Exporter;
use Carp 'croak';
- # UTF Support?
- sub HAVE_UTF8 () { $] >= 5.007003 }
- sub IO_LAYER () { $] >= 5.008001 ? ":utf8" : "" }
-
- BEGIN {
- if ( HAVE_UTF8 ) {
- # The string eval helps hide this from Test::MinimumVersion
- eval "require utf8;";
- die "Failed to load UTF-8 support" if $@;
- }
-
- # Class structure
- require 5.004;
- require Exporter;
- @Parse::CPAN::Meta::ISA = qw{ Exporter };
- @Parse::CPAN::Meta::EXPORT_OK = qw{ Load LoadFile };
- }
+ our @ISA = qw/Exporter/;
+ our @EXPORT_OK = qw/Load LoadFile/;
sub load_file {
my ($class, $filename) = @_;
+ my $meta = _slurp($filename);
+
if ($filename =~ /\.ya?ml$/) {
- return $class->load_yaml_string(_slurp($filename));
+ return $class->load_yaml_string($meta);
}
-
- if ($filename =~ /\.json$/) {
- return $class->load_json_string(_slurp($filename));
+ elsif ($filename =~ /\.json$/) {
+ return $class->load_json_string($meta);
}
+ else {
+ $class->load_string($meta); # try to detect yaml/json
+ }
+ }
- croak("file type cannot be determined by filename");
+ sub load_string {
+ my ($class, $string) = @_;
+ if ( $string =~ /^---/ ) { # looks like YAML
+ return $class->load_yaml_string($string);
+ }
+ elsif ( $string =~ /^\s*\{/ ) { # looks like JSON
+ return $class->load_json_string($string);
+ }
+ else { # maybe doc-marker-free YAML
+ return $class->load_yaml_string($string);
+ }
}
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 : $@
- }
+ croak $@ if $@;
return $data || {}; # in case document was valid but empty
}
sub load_json_string {
my ($class, $string) = @_;
- return $class->json_backend()->new->decode($string);
+ my $data = eval { $class->json_backend()->new->decode($string) };
+ croak $@ if $@;
+ return $data || {};
}
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";
+ _can_load( 'CPAN::Meta::YAML', 0.011 )
+ or croak "CPAN::Meta::YAML 0.011 is not available\n";
return "CPAN::Meta::YAML";
}
else {
@@ -18654,7 +20145,6 @@ $fatpacked{"Parse/CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
}
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";
@@ -18669,9 +20159,12 @@ $fatpacked{"Parse/CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
}
sub _slurp {
- open my $fh, "<" . IO_LAYER, "$_[0]"
+ require Encode;
+ open my $fh, "<:raw", "$_[0]" ## no critic
or die "can't open $_[0] for reading: $!";
- return do { local $/; <$fh> };
+ my $content = do { local $/; <$fh> };
+ $content = Encode::decode('UTF-8', $content, Encode::PERLQQ());
+ return $content;
}
sub _can_load {
@@ -18692,226 +20185,1122 @@ $fatpacked{"Parse/CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
# Kept for backwards compatibility only
# Create an object from a file
sub LoadFile ($) {
+ return Load(_slurp(shift));
+ }
+
+ # Parse a document from a string.
+ sub Load ($) {
require CPAN::Meta::YAML;
- my $object = CPAN::Meta::YAML::LoadFile(shift)
- or die CPAN::Meta::YAML->errstr;
+ my $object = eval { CPAN::Meta::YAML::Load(shift) };
+ croak $@ if $@;
return $object;
}
- # Parse a document from a string.
- sub Load ($) {
- require CPAN::Meta::YAML;
- my $object = CPAN::Meta::YAML::Load(shift)
- or die CPAN::Meta::YAML->errstr;
- return $object;
+ 1;
+
+ __END__
+
+ =pod
+
+ =encoding UTF-8
+
+ =head1 NAME
+
+ Parse::CPAN::Meta - Parse META.yml and META.json CPAN metadata files
+
+ =head1 VERSION
+
+ version 1.4414
+
+ =head1 SYNOPSIS
+
+ #############################################
+ # In your file
+
+ ---
+ name: My-Distribution
+ version: 1.23
+ resources:
+ homepage: "http://example.com/dist/My-Distribution"
+
+
+ #############################################
+ # In your program
+
+ use Parse::CPAN::Meta;
+
+ my $distmeta = Parse::CPAN::Meta->load_file('META.yml');
+
+ # Reading properties
+ my $name = $distmeta->{name};
+ my $version = $distmeta->{version};
+ my $homepage = $distmeta->{resources}{homepage};
+
+ =head1 DESCRIPTION
+
+ B<Parse::CPAN::Meta> is a parser for F<META.json> and F<META.yml> files, using
+ L<JSON::PP> and/or L<CPAN::Meta::YAML>.
+
+ B<Parse::CPAN::Meta> provides three methods: C<load_file>, C<load_json_string>,
+ and C<load_yaml_string>. These will read and deserialize CPAN metafiles, and
+ are described below in detail.
+
+ B<Parse::CPAN::Meta> provides a legacy API of only two functions,
+ based on the YAML functions of the same name. Wherever possible,
+ identical calling semantics are used. These may only be used with YAML sources.
+
+ All error reporting is done with exceptions (die'ing).
+
+ Note that META files are expected to be in UTF-8 encoding, only. When
+ converted string data, it must first be decoded from UTF-8.
+
+ =begin Pod::Coverage
+
+
+
+
+ =end Pod::Coverage
+
+ =head1 METHODS
+
+ =head2 load_file
+
+ my $metadata_structure = Parse::CPAN::Meta->load_file('META.json');
+
+ my $metadata_structure = Parse::CPAN::Meta->load_file('META.yml');
+
+ This method will read the named file and deserialize it to a data structure,
+ determining whether it should be JSON or YAML based on the filename.
+ The file will be read using the ":utf8" IO layer.
+
+ =head2 load_yaml_string
+
+ my $metadata_structure = Parse::CPAN::Meta->load_yaml_string($yaml_string);
+
+ This method deserializes the given string of YAML and returns the first
+ document in it. (CPAN metadata files should always have only one document.)
+ If the source was UTF-8 encoded, the string must be decoded before calling
+ C<load_yaml_string>.
+
+ =head2 load_json_string
+
+ my $metadata_structure = Parse::CPAN::Meta->load_json_string($json_string);
+
+ This method deserializes the given string of JSON and the result.
+ If the source was UTF-8 encoded, the string must be decoded before calling
+ C<load_json_string>.
+
+ =head2 load_string
+
+ my $metadata_structure = Parse::CPAN::Meta->load_string($some_string);
+
+ If you don't know whether a string contains YAML or JSON data, this method
+ will use some heuristics and guess. If it can't tell, it assumes YAML.
+
+ =head2 yaml_backend
+
+ my $backend = Parse::CPAN::Meta->yaml_backend;
+
+ Returns the module name of the YAML serializer. See L</ENVIRONMENT>
+ for details.
+
+ =head2 json_backend
+
+ my $backend = Parse::CPAN::Meta->json_backend;
+
+ Returns the module name of the JSON serializer. This will either
+ be L<JSON::PP> or L<JSON>. Even if C<PERL_JSON_BACKEND> is set,
+ this will return L<JSON> as further delegation is handled by
+ the L<JSON> module. See L</ENVIRONMENT> for details.
+
+ =head1 FUNCTIONS
+
+ For maintenance clarity, no functions are exported by default. These functions
+ are available for backwards compatibility only and are best avoided in favor of
+ C<load_file>.
+
+ =head2 Load
+
+ my @yaml = Parse::CPAN::Meta::Load( $string );
+
+ Parses a string containing a valid YAML stream into a list of Perl data
+ structures.
+
+ =head2 LoadFile
+
+ my @yaml = Parse::CPAN::Meta::LoadFile( 'META.yml' );
+
+ Reads the YAML stream from a file instead of a string.
+
+ =head1 ENVIRONMENT
+
+ =head2 PERL_JSON_BACKEND
+
+ By default, L<JSON::PP> will be used for deserializing JSON data. If the
+ C<PERL_JSON_BACKEND> environment variable exists, is true and is not
+ "JSON::PP", then the L<JSON> module (version 2.5 or greater) will be loaded and
+ used to interpret C<PERL_JSON_BACKEND>. If L<JSON> is not installed or is too
+ old, an exception will be thrown.
+
+ =head2 PERL_YAML_BACKEND
+
+ By default, L<CPAN::Meta::YAML> will be used for deserializing YAML data. If
+ the C<PERL_YAML_BACKEND> environment variable is defined, then it is interpreted
+ as a module to use for deserialization. The given module must be installed,
+ must load correctly and must implement the C<Load()> function or an exception
+ will be thrown.
+
+ =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
+
+ =head1 SUPPORT
+
+ =head2 Bugs / Feature Requests
+
+ Please report any bugs or feature requests through the issue tracker
+ at L<http://rt.cpan.org/Public/Dist/Display.html?Name=Parse-CPAN-Meta>.
+ You will be notified automatically of any progress on your issue.
+
+ =head2 Source Code
+
+ This is open source software. The code repository is available for
+ public review and contribution under the terms of the license.
+
+ L<https://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta>
+
+ git clone https://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta.git
+
+ =head1 AUTHORS
+
+ =over 4
+
+ =item *
+
+ Adam Kennedy <adamk@cpan.org>
+
+ =item *
+
+ David Golden <dagolden@cpan.org>
+
+ =back
+
+ =head1 CONTRIBUTORS
+
+ =over 4
+
+ =item *
+
+ Graham Knop <haarg@haarg.org>
+
+ =item *
+
+ Joshua ben Jore <jjore@cpan.org>
+
+ =item *
+
+ Neil Bowers <neil@bowers.com>
+
+ =item *
+
+ Ricardo Signes <rjbs@cpan.org>
+
+ =item *
+
+ Steffen Mueller <smueller@cpan.org>
+
+ =back
+
+ =head1 COPYRIGHT AND LICENSE
+
+ This software is copyright (c) 2014 by Adam Kennedy and Contributors.
+
+ This is free software; you can redistribute it and/or modify it under
+ the same terms as the Perl 5 programming language system itself.
+
+ =cut
+PARSE_CPAN_META
+
+$fatpacked{"Parse/PMFile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARSE_PMFILE';
+ package Parse::PMFile;
+
+ use strict;
+ use warnings;
+ use Safe;
+ use JSON::PP ();
+ use Dumpvalue;
+ use version ();
+ use File::Spec ();
+
+ our $VERSION = '0.28';
+ our $VERBOSE = 0;
+ our $ALLOW_DEV_VERSION = 0;
+ our $FORK = 0;
+ our $UNSAFE = $] < 5.010000 ? 1 : 0;
+
+ sub new {
+ my ($class, $meta, $opts) = @_;
+ bless {%{ $opts || {} }, META_CONTENT => $meta}, $class;
+ }
+
+ # from PAUSE::pmfile::examine_fio
+ sub parse {
+ my ($self, $pmfile) = @_;
+
+ $pmfile =~ s|\\|/|g;
+
+ my($filemtime) = (stat $pmfile)[9];
+ $self->{MTIME} = $filemtime;
+ $self->{PMFILE} = $pmfile;
+
+ unless ($self->_version_from_meta_ok) {
+ my $version;
+ unless (eval { $version = $self->_parse_version; 1 }) {
+ $self->_verbose(1, "error with version in $pmfile: $@");
+ return;
+ }
+
+ $self->{VERSION} = $version;
+ if ($self->{VERSION} =~ /^\{.*\}$/) {
+ # JSON error message
+ } elsif ($self->{VERSION} =~ /[_\s]/ && !$self->{ALLOW_DEV_VERSION} && !$ALLOW_DEV_VERSION){ # ignore developer releases and "You suck!"
+ return;
+ }
+ }
+
+ my($ppp) = $self->_packages_per_pmfile;
+ my @keys_ppp = $self->_filter_ppps(sort keys %$ppp);
+ $self->_verbose(1,"Will check keys_ppp[@keys_ppp]\n");
+
+ #
+ # Immediately after each package (pmfile) examined contact
+ # the database
+ #
+
+ my ($package, %errors);
+ my %checked_in;
+ DBPACK: foreach $package (@keys_ppp) {
+ # this part is taken from PAUSE::package::examine_pkg
+ # and PAUSE::package::_pkg_name_insane
+ 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;
+ }
+
+ if ($self->{USERID} && $self->{PERMISSIONS} && !$self->_perm_check($package)) {
+ delete $ppp->{$package};
+ next;
+ }
+
+ # Check that package name matches case of file name
+ {
+ my (undef, $module) = split m{/lib/}, $self->{PMFILE}, 2;
+ if ($module) {
+ $module =~ s{\.pm\z}{};
+ $module =~ s{/}{::}g;
+
+ if (lc $module eq lc $package && $module ne $package) {
+ # warn "/// $self->{PMFILE} vs. $module vs. $package\n";
+ $errors{$package} = {
+ indexing_warning => "Capitalization of package ($package) does not match filename!",
+ infile => $self->{PMFILE},
+ };
+ }
+ }
+ }
+
+ my $pp = $ppp->{$package};
+ if ($pp->{version} && $pp->{version} =~ /^\{.*\}$/) { # JSON parser error
+ my $dont_delete;
+ my $err = JSON::PP::decode_json($pp->{version});
+ if ($err->{x_normalize}) {
+ $errors{$package} = {
+ normalize => $err->{version},
+ infile => $pp->{infile},
+ };
+ $pp->{version} = "undef";
+ $dont_delete = 1;
+ } elsif ($err->{openerr}) {
+ $self->_verbose(1,
+ qq{Parse::PMFile was not able to
+ read the file. It issued the following error: C< $err->{r} >},
+ );
+ $errors{$package} = {
+ open => $err->{r},
+ infile => $pp->{infile},
+ };
+ } 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.)},
+
+ );
+ $errors{$package} = {
+ parse_version => $err->{line},
+ infile => $err->{file},
+ };
+ }
+ unless ($dont_delete) {
+ delete $ppp->{$package};
+ next;
+ }
+ }
+
+ # Sanity checks
+
+ for (
+ $package,
+ $pp->{version},
+ ) {
+ if (!defined || /^\s*$/ || /\s/){ # for whatever reason I come here
+ delete $ppp->{$package};
+ next; # don't screw up 02packages
+ }
+ }
+ $checked_in{$package} = $ppp->{$package};
+ } # end foreach package
+
+ return (wantarray && %errors) ? (\%checked_in, \%errors) : \%checked_in;
+ }
+
+ sub _perm_check {
+ my ($self, $package) = @_;
+ my $userid = $self->{USERID};
+ my $module = $self->{PERMISSIONS}->module_permissions($package);
+ return 1 if !$module; # not listed yet
+ return 1 if defined $module->m && $module->m eq $userid;
+ return 1 if defined $module->f && $module->f eq $userid;
+ return 1 if defined $module->c && grep {$_ eq $userid} @{$module->c};
+ return;
+ }
+
+ # from PAUSE::pmfile;
+ sub _parse_version {
+ my $self = shift;
+
+ use strict;
+
+ my $pmfile = $self->{PMFILE};
+ my $tmpfile = File::Spec->catfile(File::Spec->tmpdir, "ParsePMFile$$" . rand(1000));
+
+ my $pmcp = $pmfile;
+ for ($pmcp) {
+ s/([^\\](\\\\)*)@/$1\\@/g; # thanks to Raphael Manfredi for the
+ # solution to escape @s and \
+ }
+ my($v);
+ {
+
+ package main; # seems necessary
+
+ # XXX: do we need to fork as PAUSE does?
+ # or, is alarm() just fine?
+ my $pid;
+ if ($self->{FORK} || $FORK) {
+ $pid = fork();
+ die "Can't fork: $!" unless defined $pid;
+ }
+ if ($pid) {
+ waitpid($pid, 0);
+ if (open my $fh, '<', $tmpfile) {
+ $v = <$fh>;
+ }
+ } else {
+ # XXX Limit Resources too
+
+ my($comp) = Safe->new("_pause::mldistwatch");
+ my $eval = qq{
+ local(\$^W) = 0;
+ Parse::PMFile::_parse_version_safely("$pmcp");
+ };
+ $comp->permit("entereval"); # for MBARBON/Module-Info-0.30.tar.gz
+ $comp->share("*Parse::PMFile::_parse_version_safely");
+ $comp->share("*version::new");
+ $comp->share("*version::numify");
+ $comp->share_from('main', ['*version::',
+ '*charstar::',
+ '*Exporter::',
+ '*DynaLoader::']);
+ $comp->share_from('version', ['&qv']);
+ $comp->permit(":base_math"); # atan2 (Acme-Pi)
+ # $comp->permit("require"); # no strict!
+ $comp->deny(qw/enteriter iter unstack goto/); # minimum protection against Acme::BadExample
+
+ version->import('qv') if $self->{UNSAFE} || $UNSAFE;
+ {
+ no strict;
+ $v = ($self->{UNSAFE} || $UNSAFE) ? eval $eval : $comp->reval($eval);
+ }
+ if ($@){ # still in the child process, out of Safe::reval
+ my $err = $@;
+ # warn ">>>>>>>err[$err]<<<<<<<<";
+ if (ref $err) {
+ if ($err->{line} =~ /([\$*])([\w\:\']*)\bVERSION\b.*?\=(.*)/) {
+ local($^W) = 0;
+ $self->_restore_overloaded_stuff if version->isa('version::vpp');
+ $v = ($self->{UNSAFE} || $UNSAFE) ? eval $3 : $comp->reval($3);
+ $v = $$v if $1 eq '*' && ref $v;
+ }
+ if ($@ or !$v) {
+ $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) =~ /^version(::vpp)?$/;
+ } else {
+ $v = "";
+ }
+ if ($self->{FORK} || $FORK) {
+ open my $fh, '>:utf8', $tmpfile;
+ print $fh $v;
+ exit 0;
+ } else {
+ utf8::encode($v);
+ # undefine empty $v as if read from the tmpfile
+ $v = undef if defined $v && !length $v;
+ $comp->erase;
+ $self->_restore_overloaded_stuff;
+ }
+ }
+ }
+ unlink $tmpfile if ($self->{FORK} || $FORK) && -e $tmpfile;
+
+ return $self->_normalize_version($v);
+ }
+
+ sub _restore_overloaded_stuff {
+ my $self = shift;
+ return if $self->{UNSAFE} || $UNSAFE;
+
+ no strict 'refs';
+ no warnings 'redefine';
+
+ # version XS in CPAN
+ if (version->isa('version::vxs')) {
+ *{'version::(""'} = \&version::vxs::stringify;
+ *{'version::(0+'} = \&version::vxs::numify;
+ *{'version::(cmp'} = \&version::vxs::VCMP;
+ *{'version::(<=>'} = \&version::vxs::VCMP;
+ *{'version::(bool'} = \&version::vxs::boolean;
+ # version PP in CPAN
+ } elsif (version->isa('version::vpp')) {
+ {
+ package # hide from PAUSE
+ charstar;
+ overload->import;
+ }
+ *{'version::(""'} = \&version::vpp::stringify;
+ *{'version::(0+'} = \&version::vpp::numify;
+ *{'version::(cmp'} = \&version::vpp::vcmp;
+ *{'version::(<=>'} = \&version::vpp::vcmp;
+ *{'version::(bool'} = \&version::vpp::vbool;
+ *{'charstar::(""'} = \&charstar::thischar;
+ *{'charstar::(0+'} = \&charstar::thischar;
+ *{'charstar::(++'} = \&charstar::increment;
+ *{'charstar::(--'} = \&charstar::decrement;
+ *{'charstar::(+'} = \&charstar::plus;
+ *{'charstar::(-'} = \&charstar::minus;
+ *{'charstar::(*'} = \&charstar::multiply;
+ *{'charstar::(cmp'} = \&charstar::cmp;
+ *{'charstar::(<=>'} = \&charstar::spaceship;
+ *{'charstar::(bool'} = \&charstar::thischar;
+ *{'charstar::(='} = \&charstar::clone;
+ # version in core
+ } else {
+ *{'version::(""'} = \&version::stringify;
+ *{'version::(0+'} = \&version::numify;
+ *{'version::(cmp'} = \&version::vcmp;
+ *{'version::(<=>'} = \&version::vcmp;
+ *{'version::(bool'} = \&version::boolean;
+ }
+ }
+
+ # from PAUSE::pmfile;
+ sub _packages_per_pmfile {
+ my $self = shift;
+
+ my $ppp = {};
+ my $pmfile = $self->{PMFILE};
+ my $filemtime = $self->{MTIME};
+ my $version = $self->{VERSION};
+
+ $DB::single++;
+ open my $fh, "<", "$pmfile" or return $ppp;
+
+ local $/ = "\n";
+ my $inpod = 0;
+
+ PLINE: while (<$fh>) {
+ chomp;
+ my($pline) = $_;
+ $inpod = $pline =~ /^=(?!cut)/ ? 1 :
+ $pline =~ /^=cut/ ? 0 : $inpod;
+ next if $inpod;
+ next if substr($pline,0,4) eq "=cut";
+
+ $pline =~ s/\#.*//;
+ next if $pline =~ /^\s*$/;
+ if ($pline =~ /^__(?:END|DATA)__\b/
+ and $pmfile !~ /\.PL$/ # PL files may well have code after __DATA__
+ ){
+ last PLINE;
+ }
+
+ my $pkg;
+ my $strict_version;
+
+ if (
+ $pline =~ m{
+ # (.*) # takes too much time if $pline is long
+ (?<![*\$\\@%&]) # no sigils
+ \bpackage\s+
+ ([\w\:\']+)
+ \s*
+ (?: $ | [\}\;] | \{ | \s+($version::STRICT) )
+ }x) {
+ $pkg = $1;
+ $strict_version = $2;
+ if ($pkg eq "DB"){
+ # XXX if pumpkin and perl make him comaintainer! I
+ # think I always made the pumpkins comaint on DB
+ # without further ado (?)
+ next PLINE;
+ }
+ }
+
+ if ($pkg) {
+ # Found something
+
+ # from package
+ $pkg =~ s/\'/::/;
+ next PLINE unless $pkg =~ /^[A-Za-z]/;
+ next PLINE unless $pkg =~ /\w$/;
+ next PLINE if $pkg eq "main";
+ # Perl::Critic::Policy::TestingAndDebugging::ProhibitShebangWarningsArg
+ # database for modid in mods, package in packages, package in perms
+ # alter table mods modify modid varchar(128) binary NOT NULL default '';
+ # alter table packages modify package varchar(128) binary NOT NULL default '';
+ next PLINE if length($pkg) > 128;
+ #restriction
+ $ppp->{$pkg}{parsed}++;
+ $ppp->{$pkg}{infile} = $pmfile;
+ if ($self->_simile($pmfile,$pkg)) {
+ $ppp->{$pkg}{simile} = $pmfile;
+ if ($self->_version_from_meta_ok) {
+ my $provides = $self->{META_CONTENT}{provides};
+ if (exists $provides->{$pkg}) {
+ if (defined $provides->{$pkg}{version}) {
+ my $v = $provides->{$pkg}{version};
+ if ($v =~ /[_\s]/ && !$self->{ALLOW_DEV_VERSION} && !$ALLOW_DEV_VERSION){ # ignore developer releases and "You suck!"
+ next PLINE;
+ }
+
+ unless (eval { $version = $self->_normalize_version($v); 1 }) {
+ $self->_verbose(1, "error with version in $pmfile: $@");
+ next;
+
+ }
+ $ppp->{$pkg}{version} = $version;
+ } else {
+ $ppp->{$pkg}{version} = "undef";
+ }
+ }
+ } else {
+ if (defined $strict_version){
+ $ppp->{$pkg}{version} = $strict_version ;
+ } else {
+ $ppp->{$pkg}{version} = defined $version ? $version : "";
+ }
+ no warnings;
+ if ($version eq 'undef') {
+ $ppp->{$pkg}{version} = $version unless defined $ppp->{$pkg}{version};
+ } else {
+ $ppp->{$pkg}{version} =
+ $version
+ if $version
+ > $ppp->{$pkg}{version} ||
+ $version
+ gt $ppp->{$pkg}{version};
+ }
+ }
+ } else { # not simile
+ #### it comes later, it would be nonsense
+ #### to set to "undef". MM_Unix gives us
+ #### the best we can reasonably consider
+ $ppp->{$pkg}{version} =
+ $version
+ unless defined $ppp->{$pkg}{version} &&
+ length($ppp->{$pkg}{version});
+ }
+ $ppp->{$pkg}{filemtime} = $filemtime;
+ } else {
+ # $self->_verbose(2,"no pkg found");
+ }
+ }
+
+ close $fh;
+ $ppp;
+ }
+
+ # from PAUSE::pmfile;
+ {
+ no strict;
+ sub _parse_version_safely {
+ my($parsefile) = @_;
+ my $result;
+ local *FH;
+ local $/ = "\n";
+ open(FH,$parsefile) or die "Could not open '$parsefile': $!";
+ my $inpod = 0;
+ while (<FH>) {
+ $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
+ next if $inpod || /^\s*#/;
+ last if /^__(?:END|DATA)__\b/; # fails on quoted __END__ but this is rare -> __END__ in the middle of a line is rarer
+ chop;
+
+ if (my ($ver) = /package \s+ \S+ \s+ (\S+) \s* [;{]/x) {
+ # XXX: should handle this better if version is bogus -- rjbs,
+ # 2014-03-16
+ return $ver if version::is_lax($ver);
+ }
+
+ # next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/;
+ next unless /(?<!\\)([\$*])(([\w\:\']*)\bVERSION)\b.*(?<![!><=])\=(?![=>])/;
+ my $current_parsed_line = $_;
+ my $eval = qq{
+ package #
+ ExtUtils::MakeMaker::_version;
+
+ local $1$2;
+ \$$2=undef; do {
+ $_
+ }; \$$2
+ };
+ local $^W = 0;
+ local $SIG{__WARN__} = sub {};
+ $result = eval($eval);
+ # warn "current_parsed_line[$current_parsed_line]\$\@[$@]";
+ if ($@ or !defined $result){
+ die +{
+ eval => $eval,
+ line => $current_parsed_line,
+ file => $parsefile,
+ err => $@,
+ };
+ }
+ last;
+ } #;
+ close FH;
+
+ $result = "undef" unless defined $result;
+ return $result;
+ }
+ }
+
+ # from PAUSE::pmfile;
+ sub _filter_ppps {
+ my($self,@ppps) = @_;
+ my @res;
+
+ # very similar code is in PAUSE::dist::filter_pms
+ MANI: for my $ppp ( @ppps ) {
+ if ($self->{META_CONTENT}){
+ my $no_index = $self->{META_CONTENT}{no_index}
+ || $self->{META_CONTENT}{private}; # backward compat
+ if (ref($no_index) eq 'HASH') {
+ my %map = (
+ package => qr{\z},
+ namespace => qr{::},
+ );
+ for my $k (qw(package namespace)) {
+ next unless my $v = $no_index->{$k};
+ my $rest = $map{$k};
+ if (ref $v eq "ARRAY") {
+ for my $ve (@$v) {
+ $ve =~ s|::$||;
+ if ($ppp =~ /^$ve$rest/){
+ $self->_verbose(1,"Skipping ppp[$ppp] due to ve[$ve]");
+ next MANI;
+ } else {
+ $self->_verbose(1,"NOT skipping ppp[$ppp] due to ve[$ve]");
+ }
+ }
+ } else {
+ $v =~ s|::$||;
+ if ($ppp =~ /^$v$rest/){
+ $self->_verbose(1,"Skipping ppp[$ppp] due to v[$v]");
+ next MANI;
+ } else {
+ $self->_verbose(1,"NOT skipping ppp[$ppp] due to v[$v]");
+ }
+ }
+ }
+ } else {
+ $self->_verbose(1,"No keyword 'no_index' or 'private' in META_CONTENT");
+ }
+ } else {
+ # $self->_verbose(1,"no META_CONTENT"); # too noisy
+ }
+ push @res, $ppp;
+ }
+ $self->_verbose(1,"Result of filter_ppps: res[@res]");
+ @res;
+ }
+
+ # from PAUSE::pmfile;
+ sub _simile {
+ my($self,$file,$package) = @_;
+ # MakeMaker gives them the chance to have the file Simple.pm in
+ # this directory but have the package HTML::Simple in it.
+ # Afaik, they wouldn't be able to do so with deeper nested packages
+ $file =~ s|.*/||;
+ $file =~ s|\.pm(?:\.PL)?||;
+ my $ret = $package =~ m/\b\Q$file\E$/;
+ $ret ||= 0;
+ unless ($ret) {
+ # Apache::mod_perl_guide stuffs it into Version.pm
+ $ret = 1 if lc $file eq 'version';
+ }
+ $self->_verbose(1,"Result of simile(): file[$file] package[$package] ret[$ret]\n");
+ $ret;
}
- 1;
-
- __END__
-
- =pod
-
- =encoding utf-8
-
- =head1 NAME
-
- Parse::CPAN::Meta - Parse META.yml and META.json CPAN metadata files
-
- =head1 VERSION
-
- version 1.4407
-
- =head1 SYNOPSIS
-
- #############################################
- # In your file
-
- ---
- name: My-Distribution
- version: 1.23
- resources:
- homepage: "http://example.com/dist/My-Distribution"
-
-
- #############################################
- # In your program
-
- use Parse::CPAN::Meta;
-
- my $distmeta = Parse::CPAN::Meta->load_file('META.yml');
-
- # Reading properties
- my $name = $distmeta->{name};
- my $version = $distmeta->{version};
- my $homepage = $distmeta->{resources}{homepage};
+ # from PAUSE::pmfile
+ sub _normalize_version {
+ my($self,$v) = @_;
+ $v = "undef" unless defined $v;
+ my $dv = Dumpvalue->new;
+ my $sdv = $dv->stringify($v,1); # second argument prevents ticks
+ $self->_verbose(1,"Result of normalize_version: sdv[$sdv]\n");
- =head1 DESCRIPTION
+ return $v if $v eq "undef";
+ return $v if $v =~ /^\{.*\}$/; # JSON object
+ $v =~ s/^\s+//;
+ $v =~ s/\s+\z//;
+ if ($v =~ /_/) {
+ # XXX should pass something like EDEVELOPERRELEASE up e.g.
+ # SIXTEASE/XML-Entities-0.0306.tar.gz had nothing but one
+ # such modules and the mesage was not helpful that "nothing
+ # was found".
+ return $v ;
+ }
+ if (!version::is_lax($v)) {
+ return JSON::PP::encode_json({ x_normalize => 'version::is_lax failed', version => $v });
+ }
+ # may warn "Integer overflow"
+ my $vv = eval { no warnings; version->new($v)->numify };
+ if ($@) {
+ # warn "$v: $@";
+ return JSON::PP::encode_json({ x_normalize => $@, version => $v });
+ # return "undef";
+ }
+ if ($vv eq $v) {
+ # the boring 3.14
+ } else {
+ my $forced = $self->_force_numeric($v);
+ if ($forced eq $vv) {
+ } elsif ($forced =~ /^v(.+)/) {
+ # rare case where a v1.0.23 slipped in (JANL/w3mir-1.0.10.tar.gz)
+ $vv = version->new($1)->numify;
+ } else {
+ # warn "Unequal forced[$forced] and vv[$vv]";
+ if ($forced == $vv) {
+ # the trailing zeroes would cause unnecessary havoc
+ $vv = $forced;
+ }
+ }
+ }
+ return $vv;
+ }
- B<Parse::CPAN::Meta> is a parser for F<META.json> and F<META.yml> files, using
- L<JSON::PP> and/or L<CPAN::Meta::YAML>.
+ # from PAUSE::pmfile;
+ sub _force_numeric {
+ my($self,$v) = @_;
+ $v = $self->_readable($v);
- B<Parse::CPAN::Meta> provides three methods: C<load_file>, C<load_json_string>,
- and C<load_yaml_string>. These will read and deserialize CPAN metafiles, and
- are described below in detail.
+ if (
+ $v =~
+ /^(\+?)(\d*)(\.(\d*))?/ &&
+ # "$2$4" ne ''
+ (
+ defined $2 && length $2
+ ||
+ defined $4 && length $4
+ )
+ ) {
+ my $two = defined $2 ? $2 : "";
+ my $three = defined $3 ? $3 : "";
+ $v = "$two$three";
+ }
+ # no else branch! We simply say, everything else is a string.
+ $v;
+ }
- B<Parse::CPAN::Meta> provides a legacy API of only two functions,
- based on the YAML functions of the same name. Wherever possible,
- identical calling semantics are used. These may only be used with YAML sources.
+ # from PAUSE::dist
+ sub _version_from_meta_ok {
+ my($self) = @_;
+ return $self->{VERSION_FROM_META_OK} if exists $self->{VERSION_FROM_META_OK};
+ my $c = $self->{META_CONTENT};
- All error reporting is done with exceptions (die'ing).
+ # If there's no provides hash, we can't get our module versions from the
+ # provides hash! -- rjbs, 2012-03-31
+ return($self->{VERSION_FROM_META_OK} = 0) unless $c->{provides};
- Note that META files are expected to be in UTF-8 encoding, only. When
- converted string data, it must first be decoded from UTF-8.
+ # Some versions of Module::Build geneated an empty provides hash. If we're
+ # *not* looking at a Module::Build-generated metafile, then it's okay.
+ my ($mb_v) = (defined $c->{generated_by} ? $c->{generated_by} : '') =~ /Module::Build version ([\d\.]+)/;
+ return($self->{VERSION_FROM_META_OK} = 1) unless $mb_v;
- =for Pod::Coverage HAVE_UTF8 IO_LAYER
+ # ??? I don't know why this is here.
+ return($self->{VERSION_FROM_META_OK} = 1) if $mb_v eq '0.250.0';
- =head1 METHODS
+ if ($mb_v >= 0.19 && $mb_v < 0.26 && ! keys %{$c->{provides}}) {
+ # RSAVAGE/Javascript-SHA1-1.01.tgz had an empty provides hash. Ron
+ # did not find the reason why this happened, but let's not go
+ # overboard, 0.26 seems a good threshold from the statistics: there
+ # are not many empty provides hashes from 0.26 up.
+ return($self->{VERSION_FROM_META_OK} = 0);
+ }
- =head2 load_file
+ # We're not in the suspect range of M::B versions. It's good to go.
+ return($self->{VERSION_FROM_META_OK} = 1);
+ }
- my $metadata_structure = Parse::CPAN::Meta->load_file('META.json');
+ sub _verbose {
+ my($self,$level,@what) = @_;
+ warn @what if $level <= ((ref $self && $self->{VERBOSE}) || $VERBOSE);
+ }
- my $metadata_structure = Parse::CPAN::Meta->load_file('META.yml');
+ # all of the following methods are stripped from CPAN::Version
+ # (as of version 5.5001, bundled in CPAN 2.03), and slightly
+ # modified (ie. made private, as well as CPAN->debug(...) are
+ # replaced with $self->_verbose(9, ...).)
- This method will read the named file and deserialize it to a data structure,
- determining whether it should be JSON or YAML based on the filename. On
- Perl 5.8.1 or later, the file will be read using the ":utf8" IO layer.
+ # CPAN::Version::vcmp courtesy Jost Krieger
+ sub _vcmp {
+ my($self,$l,$r) = @_;
+ local($^W) = 0;
+ $self->_verbose(9, "l[$l] r[$r]");
- =head2 load_yaml_string
+ return 0 if $l eq $r; # short circuit for quicker success
- my $metadata_structure = Parse::CPAN::Meta->load_yaml_string($yaml_string);
+ for ($l,$r) {
+ s/_//g;
+ }
+ $self->_verbose(9, "l[$l] r[$r]");
+ for ($l,$r) {
+ next unless tr/.// > 1 || /^v/;
+ s/^v?/v/;
+ 1 while s/\.0+(\d)/.$1/; # remove leading zeroes per group
+ }
+ $self->_verbose(9, "l[$l] r[$r]");
+ if ($l=~/^v/ <=> $r=~/^v/) {
+ for ($l,$r) {
+ next if /^v/;
+ $_ = $self->_float2vv($_);
+ }
+ }
+ $self->_verbose(9, "l[$l] r[$r]");
+ my $lvstring = "v0";
+ my $rvstring = "v0";
+ if ($] >= 5.006
+ && $l =~ /^v/
+ && $r =~ /^v/) {
+ $lvstring = $self->_vstring($l);
+ $rvstring = $self->_vstring($r);
+ $self->_verbose(9, sprintf "lv[%vd] rv[%vd]", $lvstring, $rvstring);
+ }
- This method deserializes the given string of YAML and returns the first
- document in it. (CPAN metadata files should always have only one document.)
- If the source was UTF-8 encoded, the string must be decoded before calling
- C<load_yaml_string>.
+ return (
+ ($l ne "undef") <=> ($r ne "undef")
+ ||
+ $lvstring cmp $rvstring
+ ||
+ $l <=> $r
+ ||
+ $l cmp $r
+ );
+ }
- =head2 load_json_string
+ sub _vgt {
+ my($self,$l,$r) = @_;
+ $self->_vcmp($l,$r) > 0;
+ }
- my $metadata_structure = Parse::CPAN::Meta->load_json_string($json_string);
+ sub _vlt {
+ my($self,$l,$r) = @_;
+ $self->_vcmp($l,$r) < 0;
+ }
- This method deserializes the given string of JSON and the result.
- If the source was UTF-8 encoded, the string must be decoded before calling
- C<load_json_string>.
+ sub _vge {
+ my($self,$l,$r) = @_;
+ $self->_vcmp($l,$r) >= 0;
+ }
- =head2 yaml_backend
+ sub _vle {
+ my($self,$l,$r) = @_;
+ $self->_vcmp($l,$r) <= 0;
+ }
- my $backend = Parse::CPAN::Meta->yaml_backend;
+ sub _vstring {
+ my($self,$n) = @_;
+ $n =~ s/^v// or die "Parse::PMFile::_vstring() called with invalid arg [$n]";
+ pack "U*", split /\./, $n;
+ }
- Returns the module name of the YAML serializer. See L</ENVIRONMENT>
- for details.
+ # vv => visible vstring
+ sub _float2vv {
+ my($self,$n) = @_;
+ my($rev) = int($n);
+ $rev ||= 0;
+ my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
+ # architecture influence
+ $mantissa ||= 0;
+ $mantissa .= "0" while length($mantissa)%3;
+ my $ret = "v" . $rev;
+ while ($mantissa) {
+ $mantissa =~ s/(\d{1,3})// or
+ die "Panic: length>0 but not a digit? mantissa[$mantissa]";
+ $ret .= ".".int($1);
+ }
+ # warn "n[$n]ret[$ret]";
+ $ret =~ s/(\.0)+/.0/; # v1.0.0 => v1.0
+ $ret;
+ }
- =head2 json_backend
+ sub _readable {
+ my($self,$n) = @_;
+ $n =~ /^([\w\-\+\.]+)/;
- my $backend = Parse::CPAN::Meta->json_backend;
+ return $1 if defined $1 && length($1)>0;
+ # if the first user reaches version v43, he will be treated as "+".
+ # We'll have to decide about a new rule here then, depending on what
+ # will be the prevailing versioning behavior then.
- Returns the module name of the JSON serializer. This will either
- be L<JSON::PP> or L<JSON>. Even if C<PERL_JSON_BACKEND> is set,
- this will return L<JSON> as further delegation is handled by
- the L<JSON> module. See L</ENVIRONMENT> for details.
+ if ($] < 5.006) { # or whenever v-strings were introduced
+ # we get them wrong anyway, whatever we do, because 5.005 will
+ # have already interpreted 0.2.4 to be "0.24". So even if he
+ # indexer sends us something like "v0.2.4" we compare wrongly.
- =head1 FUNCTIONS
+ # And if they say v1.2, then the old perl takes it as "v12"
- For maintenance clarity, no functions are exported. These functions are
- available for backwards compatibility only and are best avoided in favor of
- C<load_file>.
+ $self->_verbose(9, "Suspicious version string seen [$n]\n");
+ return $n;
+ }
+ my $better = sprintf "v%vd", $n;
+ $self->_verbose(9, "n[$n] better[$better]");
+ return $better;
+ }
- =head2 Load
+ 1;
- my @yaml = Parse::CPAN::Meta::Load( $string );
+ __END__
- Parses a string containing a valid YAML stream into a list of Perl data
- structures.
+ =head1 NAME
- =head2 LoadFile
+ Parse::PMFile - parses .pm file as PAUSE does
- my @yaml = Parse::CPAN::Meta::LoadFile( 'META.yml' );
+ =head1 SYNOPSIS
- Reads the YAML stream from a file instead of a string.
+ use Parse::PMFile;
- =head1 ENVIRONMENT
+ my $parser = Parse::PMFile->new($metadata, {VERBOSE => 1});
+ my $packages_info = $parser->parse($pmfile);
- =head2 PERL_JSON_BACKEND
+ # if you need info about invalid versions
+ my ($packages_info, $errors) = $parser->parse($pmfile);
- By default, L<JSON::PP> will be used for deserializing JSON data. If the
- C<PERL_JSON_BACKEND> environment variable exists, is true and is not
- "JSON::PP", then the L<JSON> module (version 2.5 or greater) will be loaded and
- used to interpret C<PERL_JSON_BACKEND>. If L<JSON> is not installed or is too
- old, an exception will be thrown.
+ # to check permissions
+ my $parser = Parse::PMFile->new($metadata, {
+ USERID => 'ISHIGAKI',
+ PERMISSIONS => PAUSE::Permissions->new,
+ });
- =head2 PERL_YAML_BACKEND
+ =head1 DESCRIPTION
- By default, L<CPAN::Meta::YAML> will be used for deserializing YAML data. If
- the C<PERL_YAML_BACKEND> environment variable is defined, then it is interpreted
- as a module to use for deserialization. The given module must be installed,
- must load correctly and must implement the C<Load()> function or an exception
- will be thrown.
+ The most of the code of this module is taken from the PAUSE code as of April 2013 almost verbatim. Thus, the heart of this module should be quite stable. However, I made it not to use pipe ("-|") as well as I stripped database-related code. If you encounter any issue, that's most probably because of my modification.
- =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
+ This module doesn't provide features to extract a distribution or parse meta files intentionally.
- =head1 SUPPORT
+ =head1 METHODS
- =head2 Bugs / Feature Requests
+ =head2 new
- Please report any bugs or feature requests through the issue tracker
- at L<http://rt.cpan.org/Public/Dist/Display.html?Name=Parse-CPAN-Meta>.
- You will be notified automatically of any progress on your issue.
+ creates an object. You can also pass a hashref taken from META.yml etc, and an optional hashref. Options are:
- =head2 Source Code
+ =over 4
- This is open source software. The code repository is available for
- public review and contribution under the terms of the license.
+ =item ALLOW_DEV_VERSION
- L<https://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta>
+ Parse::PMFile usually ignores a version with an underscore as PAUSE does (because it's for a developer release, and should not be indexed). Set this option to true if you happen to need to keep such a version for better analysis.
- git clone https://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta.git
+ =item VERBOSE
- =head1 AUTHORS
+ Set this to true if you need to know some details.
- =over 4
+ =item FORK
- =item *
+ As of version 0.17, Parse::PMFile stops forking while parsing a version for better performance. Parse::PMFile should return the same result no matter how this option is set, but if you do care, set this to true to fork as PAUSE does.
- Adam Kennedy <adamk@cpan.org>
+ =item USERID, PERMISSIONS
- =item *
+ As of version 0.21, Parse::PMFile checks permissions of a package if both USERID and PERMISSIONS (which should be an instance of L<PAUSE::Permissions>) are provided. Unauthorized packages are removed.
- David Golden <dagolden@cpan.org>
+ =item UNSAFE
- =back
+ Parse::PMFile usually parses a module version in a Safe compartment. However, this approach doesn't work smoothly under older perls (prior to 5.10) plus some combinations of recent versions of Safe.pm (2.24 and above) and version.pm (0.9905 and above) for various reasons. As of version 0.27, Parse::PMFile simply uses C<eval> to parse a version under older perls. If you want it to use always C<eval> (even under recent perls), set this to true.
- =head1 CONTRIBUTORS
+ =back
- =over 4
+ =head2 parse
- =item *
+ takes a path to a .pm file, and returns a hash reference that holds information for package(s) found in the file.
- Joshua ben Jore <jjore@cpan.org>
+ =head1 SEE ALSO
- =item *
+ L<Parse::LocalDistribution>, L<PAUSE::Permissions>
- Neil Bowers <neil@bowers.com>
+ Most part of this module is derived from PAUSE and CPAN::Version.
- =item *
+ L<https://github.com/andk/pause>
- Ricardo SIGNES <rjbs@cpan.org>
+ L<https://github.com/andk/cpanpm>
- =item *
+ =head1 AUTHOR
- Steffen Müller <smueller@cpan.org>
+ Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
- =back
+ Kenichi Ishigaki, E<lt>ishigaki@cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
- This software is copyright (c) 2013 by Adam Kennedy and Contributors.
+ Copyright 1995 - 2013 by Andreas Koenig E<lt>andk@cpan.orgE<gt> for most of the code.
- This is free software; you can redistribute it and/or modify it under
- the same terms as the Perl 5 programming language system itself.
+ Copyright 2013 by Kenichi Ishigaki for some.
+
+ This program is free software; you can redistribute it and/or
+ modify it under the same terms as Perl itself.
=cut
-PARSE_CPAN_META
+PARSE_PMFILE
$fatpacked{"String/ShellQuote.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STRING_SHELLQUOTE';
# $Id: ShellQuote.pm,v 1.11 2010-06-11 20:08:57 roderick Exp $
@@ -19112,338 +21501,6 @@ $fatpacked{"String/ShellQuote.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
=cut
STRING_SHELLQUOTE
-$fatpacked{"aliased.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'ALIASED';
- package aliased;
-
- our $VERSION = '0.31';
- $VERSION = eval $VERSION;
-
- require Exporter;
- @ISA = qw(Exporter);
- @EXPORT = qw(alias prefix);
-
- use strict;
-
- sub _croak {
- require Carp;
- Carp::croak(@_);
- }
-
- sub import {
- my ( $class, $package, $alias, @import ) = @_;
-
- if ( @_ <= 1 ) {
- $class->export_to_level(1);
- return;
- }
-
- my $callpack = caller(0);
- _load_alias( $package, $callpack, @import );
- _make_alias( $package, $callpack, $alias );
- }
-
- sub _get_alias {
- my $package = shift;
- $package =~ s/.*(?:::|')//;
- return $package;
- }
-
- sub _make_alias {
- my ( $package, $callpack, $alias ) = @_;
-
- $alias ||= _get_alias($package);
-
- my $destination = $alias =~ /::/
- ? $alias
- : "$callpack\::$alias";
-
- no strict 'refs';
- *{ $destination } = sub () { $package };
- }
-
- sub _load_alias {
- my ( $package, $callpack, @import ) = @_;
-
- # We don't localize $SIG{__DIE__} here because we need to be careful about
- # restoring its value if there is a failure. Very, very tricky.
- my $sigdie = $SIG{__DIE__};
- {
- my $code =
- @import == 0
- ? "package $callpack; use $package;"
- : "package $callpack; use $package (\@import)";
- eval $code;
- if ( my $error = $@ ) {
- $SIG{__DIE__} = $sigdie;
- _croak($error);
- }
- $sigdie = $SIG{__DIE__}
- if defined $SIG{__DIE__};
- }
-
- # Make sure a global $SIG{__DIE__} makes it out of the localization.
- $SIG{__DIE__} = $sigdie if defined $sigdie;
- return $package;
- }
-
- sub alias {
- my ( $package, @import ) = @_;
-
- my $callpack = scalar caller(0);
- return _load_alias( $package, $callpack, @import );
- }
-
- sub prefix {
- my ($class) = @_;
- return sub {
- my ($name) = @_;
- my $callpack = caller(0);
- if ( not @_ ) {
- return _load_alias( $class, $callpack );
- }
- elsif ( @_ == 1 && defined $name ) {
- return _load_alias( "${class}::$name", $callpack );
- }
- else {
- _croak("Too many arguments to prefix('$class')");
- }
- };
- }
-
- 1;
- __END__
-
- =head1 NAME
-
- aliased - Use shorter versions of class names.
-
- =head1 VERSION
-
- 0.31
-
- =head1 SYNOPSIS
-
- # Class name interface
- use aliased 'My::Company::Namespace::Customer';
- my $cust = Customer->new;
-
- use aliased 'My::Company::Namespace::Preferred::Customer' => 'Preferred';
- my $pref = Preferred->new;
-
-
- # Variable interface
- use aliased;
- my $Customer = alias "My::Other::Namespace::Customer";
- my $cust = $Customer->new;
-
- my $Preferred = alias "My::Other::Namespace::Preferred::Customer";
- my $pref = $Preferred->new;
-
-
- =head1 DESCRIPTION
-
- C<aliased> is simple in concept but is a rather handy module. It loads the
- class you specify and exports into your namespace a subroutine that returns
- the class name. You can explicitly alias the class to another name or, if you
- prefer, you can do so implicitly. In the latter case, the name of the
- subroutine is the last part of the class name. Thus, it does something
- similar to the following:
-
- #use aliased 'Some::Annoyingly::Long::Module::Name::Customer';
-
- use Some::Annoyingly::Long::Module::Name::Customer;
- sub Customer {
- return 'Some::Annoyingly::Long::Module::Name::Customer';
- }
- my $cust = Customer->new;
-
- This module is useful if you prefer a shorter name for a class. It's also
- handy if a class has been renamed.
-
- (Some may object to the term "aliasing" because we're not aliasing one
- namespace to another, but it's a handy term. Just keep in mind that this is
- done with a subroutine and not with typeglobs and weird namespace munging.)
-
- Note that this is B<only> for C<use>ing OO modules. You cannot use this to
- load procedural modules. See the L<Why OO Only?|Why OO Only?> section. Also,
- don't let the version number fool you. This code is ridiculously simple and
- is just fine for most use.
-
- =head2 Implicit Aliasing
-
- The most common use of this module is:
-
- use aliased 'Some::Module::name';
-
- C<aliased> will allow you to reference the class by the last part of the
- class name. Thus, C<Really::Long::Name> becomes C<Name>. It does this by
- exporting a subroutine into your namespace with the same name as the aliased
- name. This subroutine returns the original class name.
-
- For example:
-
- use aliased "Acme::Company::Customer";
- my $cust = Customer->find($id);
-
- Note that any class method can be called on the shorter version of the class
- name, not just the constructor.
-
- =head2 Explicit Aliasing
-
- Sometimes two class names can cause a conflict (they both end with C<Customer>
- for example), or you already have a subroutine with the same name as the
- aliased name. In that case, you can make an explicit alias by stating the
- name you wish to alias to:
-
- use aliased 'Original::Module::Name' => 'NewName';
-
- Here's how we use C<aliased> to avoid conflicts:
-
- use aliased "Really::Long::Name";
- use aliased "Another::Really::Long::Name" => "Aname";
- my $name = Name->new;
- my $aname = Aname->new;
-
- You can even alias to a different package:
-
- use aliased "Another::Really::Long::Name" => "Another::Name";
- my $aname = Another::Name->new;
-
- Messing around with different namespaces is a really bad idea and you probably
- don't want to do this. However, it might prove handy if the module you are
- using has been renamed. If the interface has not changed, this allows you to
- use the new module by only changing one line of code.
-
- use aliased "New::Module::Name" => "Old::Module::Name";
- my $thing = Old::Module::Name->new;
-
- =head2 Import Lists
-
- Sometimes, even with an OO module, you need to specify extra arguments when
- using the module. When this happens, simply use L<Explicit Aliasing> followed
- by the import list:
-
- Snippet 1:
-
- use Some::Module::Name qw/foo bar/;
- my $o = Some::Module::Name->some_class_method;
-
- Snippet 2 (equivalent to snippet 1):
-
- use aliased 'Some::Module::Name' => 'Name', qw/foo bar/;
- my $o = Name->some_class_method;
-
- B<Note>: remember, you cannot use import lists with L<Implicit Aliasing>. As
- a result, you may simply prefer to only use L<Explicit Aliasing> as a matter
- of style.
-
- =head2 alias()
-
- This function is only exported if you specify C<use aliased> with no import
- list.
-
- use aliased;
- my $alias = alias($class);
- my $alias = alias($class, @imports);
-
- alias() is an alternative to C<use aliased ...> which uses less magic and
- avoids some of the ambiguities.
-
- Like C<use aliased> it C<use>s the $class (pass in @imports, if given) but
- instead of providing an C<Alias> constant it simply returns a scalar set to
- the $class name.
-
- my $thing = alias("Some::Thing::With::A::Long::Name");
-
- # Just like Some::Thing::With::A::Long::Name->method
- $thing->method;
-
- The use of a scalar instead of a constant avoids any possible ambiguity
- when aliasing two similar names:
-
- # No ambiguity despite the fact that they both end with "Name"
- my $thing = alias("Some::Thing::With::A::Long::Name");
- my $other = alias("Some::Other::Thing::With::A::Long::Name");
-
- and there is no magic constant exported into your namespace.
-
- The only caveat is loading of the $class happens at run time. If $class
- exports anything you might want to ensure it is loaded at compile time with:
-
- my $thing;
- BEGIN { $thing = alias("Some::Thing"); }
-
- However, since OO classes rarely export this should not be necessary.
-
- =head2 prefix() (experimental)
-
- This function is only exported if you specify C<use aliased> with no import
- list.
-
- use aliased;
-
- Sometimes you find you have a ton of packages in the same top-level namespace
- and you want to alias them, but only use them on demand. For example:
-
- # instead of:
- MailVerwaltung::Client::Exception::REST::Response->throw()
-
- my $error = prefix('MailVerwaltung::Client::Exception');
- $error->('REST::Response')->throw(); # same as above
- $error->()->throw; # same as MailVerwaltung::Client::Exception->throw
-
- =head2 Why OO Only?
-
- Some people have asked why this code only support object-oriented modules
- (OO). If I were to support normal subroutines, I would have to allow the
- following syntax:
-
- use aliased 'Some::Really::Long::Module::Name';
- my $data = Name::data();
-
- That causes a serious problem. The only (reasonable) way it can be done is to
- handle the aliasing via typeglobs. Thus, instead of a subroutine that
- provides the class name, we alias one package to another (as the
- L<namespace|namespace> module does.) However, we really don't want to simply
- alias one package to another and wipe out namespaces willy-nilly. By merely
- exporting a single subroutine to a namespace, we minimize the issue.
-
- Fortunately, this doesn't seem to be that much of a problem. Non-OO modules
- generally support exporting of the functions you need and this eliminates the
- need for a module such as this.
-
- =head1 EXPORT
-
- This modules exports a subroutine with the same name as the "aliased" name.
-
- =head1 BUGS
-
- There are no known bugs in this module, but feel free to email me reports.
-
- =head1 SEE ALSO
-
- The L<namespace> module.
-
- =head1 THANKS
-
- Many thanks to Rentrak, Inc. (http://www.rentrak.com/) for graciously allowing
- me to replicate the functionality of some of their internal code.
-
- =head1 AUTHOR
-
- Curtis Poe, C<< ovid [at] cpan [dot] org >>
-
- =head1 COPYRIGHT AND LICENSE
-
- Copyright (C) 2005 by Curtis "Ovid" Poe
-
- This library is free software; you can redistribute it and/or modify
- it under the same terms as Perl itself, either Perl version 5.8.5 or,
- at your option, any later version of Perl 5 you may have available.
-
- =cut
-ALIASED
-
$fatpacked{"lib/core/only.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LIB_CORE_ONLY';
package lib::core::only;
@@ -19553,11 +21610,88 @@ $fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL
use strict;
use warnings;
use Config;
- use File::Spec ();
- our $VERSION = '2.000008'; # 2.0.8
+ our $VERSION = '2.000014';
$VERSION = eval $VERSION;
+ BEGIN {
+ *_WIN32 = ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'symbian')
+ ? sub(){1} : sub(){0};
+ # punt on these systems
+ *_USE_FSPEC = ($^O eq 'MacOS' || $^O eq 'VMS' || $INC{'File/Spec.pm'})
+ ? sub(){1} : sub(){0};
+ }
+ our $_DIR_JOIN = _WIN32 ? '\\' : '/';
+ our $_DIR_SPLIT = (_WIN32 || $^O eq 'cygwin') ? qr{[\\/]}
+ : qr{/};
+ our $_ROOT = _WIN32 ? do {
+ my $UNC = qr{[\\/]{2}[^\\/]+[\\/][^\\/]+};
+ qr{^(?:$UNC|[A-Za-z]:|)$_DIR_SPLIT};
+ } : qr{^/};
+ our $_PERL;
+
+ sub _cwd {
+ my $drive = shift;
+ if (!$_PERL) {
+ ($_PERL) = $^X =~ /(.+)/; # $^X is internal how could it be tainted?!
+ if (_is_abs($_PERL)) {
+ }
+ elsif (-x $Config{perlpath}) {
+ $_PERL = $Config{perlpath};
+ }
+ else {
+ ($_PERL) =
+ map { /(.*)/ }
+ grep { -x $_ }
+ map { join($_DIR_JOIN, $_, $_PERL) }
+ split /\Q$Config{path_sep}\E/, $ENV{PATH};
+ }
+ }
+ local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};
+ my $cmd = $drive ? "eval { Cwd::getdcwd(q($drive)) }"
+ : 'getcwd';
+ my $cwd = `"$_PERL" -MCwd -le "print $cmd"`;
+ chomp $cwd;
+ if (!length $cwd && $drive) {
+ $cwd = $drive;
+ }
+ $cwd =~ s/$_DIR_SPLIT?$/$_DIR_JOIN/;
+ $cwd;
+ }
+
+ sub _catdir {
+ if (_USE_FSPEC) {
+ require File::Spec;
+ File::Spec->catdir(@_);
+ }
+ else {
+ my $dir = join($_DIR_JOIN, @_);
+ $dir =~ s{($_DIR_SPLIT)(?:\.?$_DIR_SPLIT)+}{$1}g;
+ $dir;
+ }
+ }
+
+ sub _is_abs {
+ if (_USE_FSPEC) {
+ require File::Spec;
+ File::Spec->file_name_is_absolute($_[0]);
+ }
+ else {
+ $_[0] =~ $_ROOT;
+ }
+ }
+
+ sub _rel2abs {
+ my ($dir, $base) = @_;
+ return $dir
+ if _is_abs($dir);
+
+ $base = _WIN32 && $dir =~ s/^([A-Za-z]:)// ? _cwd("$1")
+ : $base ? $base
+ : _cwd;
+ return _catdir($base, $dir);
+ }
+
sub import {
my ($class, @args) = @_;
push @args, @ARGV
@@ -19683,21 +21817,21 @@ $fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL
sub install_base_bin_path {
my ($class, $path) = @_;
- return File::Spec->catdir($path, 'bin');
+ return _catdir($path, 'bin');
}
sub install_base_perl_path {
my ($class, $path) = @_;
- return File::Spec->catdir($path, 'lib', 'perl5');
+ return _catdir($path, 'lib', 'perl5');
}
sub install_base_arch_path {
my ($class, $path) = @_;
- File::Spec->catdir($class->install_base_perl_path($path), $_archname);
+ _catdir($class->install_base_perl_path($path), $_archname);
}
sub lib_paths_for {
my ($class, $path) = @_;
my $base = $class->install_base_perl_path($path);
- return map { File::Spec->catdir($base, @$_) } @_lib_subdirs;
+ return map { _catdir($base, @$_) } @_lib_subdirs;
}
sub _mm_escape_path {
@@ -19830,6 +21964,18 @@ $fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL
my $self = $_[0]->new->activate($_[1]);
$self->build_environment_vars;
}
+ sub build_activate_environment_vars_for {
+ my $self = $_[0]->new->activate($_[1]);
+ $self->build_environment_vars;
+ }
+ sub build_deactivate_environment_vars_for {
+ my $self = $_[0]->new->deactivate($_[1]);
+ $self->build_environment_vars;
+ }
+ sub build_deact_all_environment_vars_for {
+ my $self = $_[0]->new->deactivate_all;
+ $self->build_environment_vars;
+ }
sub build_environment_vars {
my $self = shift;
(
@@ -19847,6 +21993,12 @@ $fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL
sub setup_local_lib {
my $self = shift;
+
+ # if Carp is already loaded, ensure Carp::Heavy is also loaded, to avoid
+ # $VERSION mismatch errors (Carp::Heavy loads Carp, so we do not need to
+ # check in the other direction)
+ require Carp::Heavy if $INC{'Carp.pm'};
+
$self->setup_env_hash;
@INC = @{$self->inc};
}
@@ -19881,8 +22033,6 @@ $fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL
$shelltype ||= $self->guess_shelltype;
- my $build_method = "build_${shelltype}_env_declaration";
-
my $extra = $self->extra;
my @envs = (
PATH => $self->bins,
@@ -19890,6 +22040,15 @@ $fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL
PERL_LOCAL_LIB_ROOT => $self->roots,
map { $_ => $extra->{$_} } sort keys %$extra,
);
+ $self->_build_env_string($shelltype, \@envs);
+ }
+
+ sub _build_env_string {
+ my ($self, $shelltype, $envs) = @_;
+ my @envs = @$envs;
+
+ my $build_method = "build_${shelltype}_env_declaration";
+
my $out = '';
while (@envs) {
my ($name, $value) = (shift(@envs), shift(@envs));
@@ -19901,14 +22060,6 @@ $fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL
&& ${$value->[0]} eq $name) {
next;
}
- if (
- !ref $value
- and defined $value
- ? (defined $ENV{$name} && $value eq $ENV{$name})
- : !defined $ENV{$name}
- ) {
- next;
- }
$out .= $self->$build_method($name, $value);
}
my $wrap_method = "wrap_${shelltype}_output";
@@ -19920,21 +22071,21 @@ $fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL
sub build_bourne_env_declaration {
my ($class, $name, $args) = @_;
- my $value = $class->_interpolate($args, '$%s', '"', '\\%s');
+ my $value = $class->_interpolate($args, '${%s}', qr/["\\\$!`]/, '\\%s');
if (!defined $value) {
return qq{unset $name;\n};
}
- $value =~ s/(^|\G|$_path_sep)\$$name$_path_sep/$1\$$name\${$name+$_path_sep}/g;
- $value =~ s/$_path_sep\$$name$/\${$name+$_path_sep}\$$name/;
+ $value =~ s/(^|\G|$_path_sep)\$\{$name\}$_path_sep/$1\${$name}\${$name+$_path_sep}/g;
+ $value =~ s/$_path_sep\$\{$name\}$/\${$name+$_path_sep}\${$name}/;
qq{${name}="$value"; export ${name};\n}
}
sub build_csh_env_declaration {
my ($class, $name, $args) = @_;
- my ($value, @vars) = $class->_interpolate($args, '$%s', '"', '"\\%s"');
+ my ($value, @vars) = $class->_interpolate($args, '${%s}', '"', '"\\%s"');
if (!defined $value) {
return qq{unsetenv $name;\n};
}
@@ -19945,9 +22096,9 @@ $fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL
}
my $value_without = $value;
- if ($value_without =~ s/(?:^|$_path_sep)\$$name(?:$_path_sep|$)//g) {
- $out .= qq{if "\$$name" != '' setenv $name "$value";\n};
- $out .= qq{if "\$$name" == '' };
+ if ($value_without =~ s/(?:^|$_path_sep)\$\{$name\}(?:$_path_sep|$)//g) {
+ $out .= qq{if "\${$name}" != '' setenv $name "$value";\n};
+ $out .= qq{if "\${$name}" == '' };
}
$out .= qq{setenv $name "$value_without";\n};
return $out;
@@ -19955,7 +22106,7 @@ $fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL
sub build_cmd_env_declaration {
my ($class, $name, $args) = @_;
- my $value = $class->_interpolate($args, '%%%s%%', qr([()!^"<>&|]), '^%s');
+ my $value = $class->_interpolate($args, '%%%s%%', qr(%), '%s');
if (!$value) {
return qq{\@set $name=\n};
}
@@ -19963,10 +22114,10 @@ $fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL
my $out = '';
my $value_without = $value;
if ($value_without =~ s/(?:^|$_path_sep)%$name%(?:$_path_sep|$)//g) {
- $out .= qq{\@if not "%$name%"=="" set $name=$value\n};
+ $out .= qq{\@if not "%$name%"=="" set "$name=$value"\n};
$out .= qq{\@if "%$name%"=="" };
}
- $out .= qq{\@set $name=$value_without\n};
+ $out .= qq{\@set "$name=$value_without"\n};
return $out;
}
@@ -19991,7 +22142,7 @@ $fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL
sub build_fish_env_declaration {
my ($class, $name, $args) = @_;
- my $value = $class->_interpolate($args, '$%s', '"', '\\%s');
+ my $value = $class->_interpolate($args, '$%s', qr/[\\"' ]/, '\\%s');
if (!defined $value) {
return qq{set -e $name;\n};
}
@@ -20069,7 +22220,7 @@ $fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL
}
};
unless (defined $homedir) {
- require Carp;
+ require Carp; require Carp::Heavy;
Carp::croak(
"Couldn't resolve homedir for "
.(defined $user ? $user : 'current user')
@@ -20081,7 +22232,7 @@ $fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL
sub resolve_relative_path {
my ($class, $path) = @_;
- $path = File::Spec->rel2abs($path);
+ _rel2abs($path);
}
sub ensure_dir_structure_for {
@@ -20757,11 +22908,10 @@ $fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL
=item * Should probably auto-fixup CPAN config if not already done.
- =item * local::lib loads L<File::Spec>. When used to set shell variables,
- this isn't a problem. When used inside a perl script, any L<File::Spec>
- version inside the local::lib will be ignored. A workaround for this is using
- C<use lib "$ENV{HOME}/perl5/lib/perl5";> inside the script instead of using
- C<local::lib> directly.
+ =item * On VMS and MacOS Classic (pre-OS X), local::lib loads L<File::Spec>.
+ This means any L<File::Spec> version installed in the local::lib will be
+ ignored by scripts using local::lib. A workaround for this is using
+ C<use lib "$local_lib/lib/perl5";> instead of using C<local::lib> directly.
=item * Conflicts with L<ExtUtils::MakeMaker>'s C<PREFIX> option.
C<local::lib> uses the C<INSTALL_BASE> option, as it has more predictable and
@@ -20895,7 +23045,7 @@ $fatpacked{"parent.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARENT';
package parent;
use strict;
use vars qw($VERSION);
- $VERSION = '0.225';
+ $VERSION = '0.228';
sub import {
my $class = shift;
@@ -21039,14 +23189,13 @@ $fatpacked{"version.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION
use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
- $VERSION = 0.9908;
+ $VERSION = 0.9909;
$CLASS = 'version';
# !!!!Delete this next block completely when adding to Perl core!!!!
{
local $SIG{'__DIE__'};
- eval "use version::vxs $VERSION";
- if ( $@ ) { # don't have the XS version installed
+ if (1) { # always pretend there's no XS
eval "use version::vpp $VERSION"; # don't tempt fate
die "$@" if ( $@ );
push @ISA, "version::vpp";
@@ -21158,7 +23307,7 @@ $fatpacked{"version/regex.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'V
use vars qw($VERSION $CLASS $STRICT $LAX);
- $VERSION = 0.9908;
+ $VERSION = 0.9909;
#--------------------------------------------------------------------------#
# Version regexp components
@@ -21396,7 +23545,7 @@ $fatpacked{"version/vpp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VER
use Config;
use vars qw($VERSION $CLASS @ISA $LAX $STRICT);
- $VERSION = 0.9908;
+ $VERSION = 0.9909;
$CLASS = 'version::vpp';
require version::regex;
@@ -22428,23 +24577,6 @@ 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.
@@ -22524,6 +24656,10 @@ directory C<extlib>, which can be loaded from your application with:
use local::lib '/path/to/extlib';
+Note that this option does B<NOT> reliably work with perl
+installations supplied by operating system vendors that strips
+standard modules from perl, such as RHEL, Fedora and CentOS.
+
=item --self-contained
When examining the dependencies, assume no non-core modules are
@@ -22772,7 +24908,7 @@ 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
+A dialog will 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.